summaryrefslogtreecommitdiffstats
path: root/release_docs
diff options
context:
space:
mode:
Diffstat (limited to 'release_docs')
-rw-r--r--release_docs/RELEASE.txt4
1 files changed, 3 insertions, 1 deletions
diff --git a/release_docs/RELEASE.txt b/release_docs/RELEASE.txt
index e5f4539..9af0ef0 100644
--- a/release_docs/RELEASE.txt
+++ b/release_docs/RELEASE.txt
@@ -90,13 +90,15 @@ Bug Fixes since HDF5-1.8.0 release
- Fixed bug in h5diff that prevented datasets & attributes with
variable-length string elements from comparing correctly.
(QAK - 2008/02/28)
-
- h5import bug on Windows w/binary datasets. fread in windows needs a
binary file to be open with 'rb' instead of 'r' otherwise it
terminates execution if an end of file character is found on the
input file. Besides that the binary file generated needs to be open
with 'wb' , otherwise an end of line character is read twice.
(PVN - 2008/02/19)
+ - Fixed bug in h5dump that caused binary output to be made only for the first
+ dataset, when several datasets were requested. (PVN - 2008/04/07)
+
Documentation
generated by cgit v0.12 at 2024-08-23 01:49:20 (GMT)
mcunknown]]] +} + +# msgcat::mcexists -- +# +# Check if a catalog item is set or if mc would invoke mcunknown. +# +# Arguments: +# -exactnamespace Only check the exact namespace and no +# parent namespaces +# -exactlocale Only check the exact locale and not all members +# of the preferences list +# src Message catalog key +# +# Results: +# true if an adequate catalog key was found + +proc msgcat::mcexists {args} { + + variable Msgs + variable Loclist + variable PackageConfig + + set ns [uplevel 1 [list ::namespace current]] + set loclist [PackagePreferences $ns] + + while {[llength $args] > 1} { + set args [lassign $args option] + switch -glob -- $option { + -exactnamespace { set exactnamespace 1 } + -exactlocale { set loclist [lrange $loclist 0 0] } + -* { return -code error "unknown option \"$option\"" } + default { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?-exactnamespace?\ + ?-exactlocale? src\"" + } + } + } + set src [lindex $args 0] + + while {$ns ne ""} { + foreach loc $loclist { + if {[dict exists $Msgs $ns $loc $src]} { + return 1 + } + } + if {[info exists exactnamespace]} {return 0} + set ns [namespace parent $ns] + } + return 0 } # msgcat::mclocale -- @@ -255,11 +287,11 @@ proc msgcat::mc {src args} { # separated by underscores (e.g. en_US). # # Results: -# Returns the current locale. +# Returns the normalized set locale. proc msgcat::mclocale {args} { variable Loclist - variable Locale + variable LoadedLocales set len [llength $args] if {$len > 1} { @@ -268,24 +300,49 @@ proc msgcat::mclocale {args} { } if {$len == 1} { - set newLocale [lindex $args 0] + set newLocale [string tolower [lindex $args 0]] if {$newLocale ne [file tail $newLocale]} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } - set Locale [string tolower $newLocale] - set Loclist {} - set word "" - foreach part [split $Locale _] { - set word [string trim "${word}_${part}" _] - if {$word ne [lindex $Loclist 0]} { - set Loclist [linsert $Loclist 0 $word] - } + if {[lindex $Loclist 0] ne $newLocale} { + set Loclist [GetPreferences $newLocale] + + # locale not loaded jet + LoadAll $Loclist + # Invoke callback + Invoke changecmd $Loclist + } + } + return [lindex $Loclist 0] +} + +# msgcat::GetPreferences -- +# +# Get list of locales from a locale. +# The first element is always the lowercase locale. +# Other elements have one component separated by "_" less. +# Multiple "_" are seen as one separator: de__ch_spec de__ch de {} +# +# Arguments: +# Locale. +# +# Results: +# Locale list + +proc msgcat::GetPreferences {locale} { + set locale [string tolower $locale] + set loclist [list $locale] + while {-1 !=[set pos [string last "_" $locale]]} { + set locale [string range $locale 0 $pos-1] + if { "_" ne [string index $locale end] } { + lappend loclist $locale } - lappend Loclist {} - set Locale [lindex $Loclist 0] } - return $Locale + if {"" ne [lindex $loclist end]} { + lappend loclist {} + } + return $loclist } # msgcat::mcpreferences -- @@ -304,6 +361,383 @@ proc msgcat::mcpreferences {} { return $Loclist } +# msgcat::mcloadedlocales -- +# +# Get or change the list of currently loaded default locales +# +# The following subcommands are available: +# loaded +# Get the current list of loaded locales +# clear +# Remove all loaded locales not present in mcpreferences. +# +# Arguments: +# subcommand One of loaded or clear +# +# Results: +# Empty string, if not stated differently for the subcommand + +proc msgcat::mcloadedlocales {subcommand} { + variable Loclist + variable LoadedLocales + variable Msgs + variable PackageConfig + switch -exact -- $subcommand { + clear { + # Remove all locales not contained in Loclist + # skip any packages with package locale + set LoadedLocales $Loclist + foreach ns [dict keys $Msgs] { + if {![dict exists $PackageConfig loclist $ns]} { + foreach locale [dict keys [dict get $Msgs $ns]] { + if {$locale ni $Loclist} { + dict unset Msgs $ns $locale + } + } + } + } + } + loaded { return $LoadedLocales } + default { + return -code error "unknown subcommand \"$subcommand\": must be\ + clear, or loaded" + } + } + return +} + +# msgcat::mcpackagelocale -- +# +# Get or change the package locale of the calling package. +# +# The following subcommands are available: +# set +# Set a package locale. +# This may load message catalog files and may clear message catalog +# items, if the former locale was the default locale. +# Returns the normalized set locale. +# The default locale is taken, if locale is not given. +# get +# Get the locale valid for this package. +# isset +# Returns true, if a package locale is set +# unset +# Unset the package locale and activate the default locale. +# This may clear message catalog data and may load message catalog +# files +# preferences +# Return locale preference list valid for the package. +# loaded +# Return loaded locale list valid for the current package. +# clear +# If the current package has a package locale, remove all package +# locales not containes in package mcpreferences. +# It is an error to call this without a package locale set. +# +# The subcommands get, preferences and loaded return the corresponding +# default data, if no package locale is set. +# +# Arguments: +# subcommand One of get, init, present, add or remove +# locale package locale (only set subcommand) +# +# Results: +# Empty string, if not stated differently for the subcommand + +proc msgcat::mcpackagelocale {subcommand {locale ""}} { + # todo: implement using an ensemble + variable Loclist + variable LoadedLocales + variable Msgs + variable PackageConfig + # Check option + # check if required item is exactly provided + if {[llength [info level 0]] == 2} { + # locale not given + unset locale + } else { + # locale given + if {$subcommand in + {"get" "isset" "unset" "preferences" "loaded" "clear"} } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1]\"" + } + set locale [string tolower $locale] + } + set ns [uplevel 1 {::namespace current}] + + switch -exact -- $subcommand { + get { return [lindex [PackagePreferences $ns] 0] } + preferences { return [PackagePreferences $ns] } + loaded { return [PackageLocales $ns] } + isset { return [dict exists $PackageConfig loclist $ns] } + set { # set a package locale or add a package locale + + # Copy the default locale if no package locale set so far + if {![dict exists $PackageConfig loclist $ns]} { + dict set PackageConfig loclist $ns $Loclist + dict set PackageConfig loadedlocales $ns $LoadedLocales + } + + # Check if changed + set loclist [dict get $PackageConfig loclist $ns] + if {! [info exists locale] || $locale eq [lindex $loclist 0] } { + return [lindex $loclist 0] + } + + # Change loclist + set loclist [GetPreferences $locale] + set locale [lindex $loclist 0] + dict set PackageConfig loclist $ns $loclist + + # load eventual missing locales + set loadedLocales [dict get $PackageConfig loadedlocales $ns] + if {$locale in $loadedLocales} { return $locale } + set loadLocales [ListComplement $loadedLocales $loclist] + dict set PackageConfig loadedlocales $ns\ + [concat $loadedLocales $loadLocales] + Load $ns $loadLocales + return $locale + } + clear { # Remove all locales not contained in Loclist + if {![dict exists $PackageConfig loclist $ns]} { + return -code error "clear only when package locale set" + } + set loclist [dict get $PackageConfig loclist $ns] + dict set PackageConfig loadedlocales $ns $loclist + if {[dict exists $Msgs $ns]} { + foreach locale [dict keys [dict get $Msgs $ns]] { + if {$locale ni $loclist} { + dict unset Msgs $ns $locale + } + } + } + } + unset { # unset package locale and restore default locales + + if { ![dict exists $PackageConfig loclist $ns] } { return } + + # unset package locale + set loadedlocales [dict get $PackageConfig loadedlocales $ns] + dict unset PackageConfig loadedlocales $ns + dict unset PackageConfig loclist $ns + + # Remove unwanted locales + foreach locale [dict keys [dict get $Msgs $ns]] { + if { $locale ni $LoadedLocales } { + dict unset Msgs $ns $locale + } + } + # Add missing locales + Load $ns [ListComplement $loadedlocales $LoadedLocales] + } + default { + return -code error "unknown subcommand \"$subcommand\": must be\ + clear, get, isset, loaded, present, set, or unset" + } + } + return +} + +# msgcat::mcforgetpackage -- +# +# Remove any data of the calling package from msgcat +# + +proc msgcat::mcforgetpackage {} { + # todo: this may be implemented using an ensemble + variable PackageConfig + variable Msgs + set ns [uplevel 1 {::namespace current}] + # Remove MC items + dict unset Msgs $ns + # Remove config items + foreach key [dict keys $PackageConfig] { + dict unset PackageConfig $key $ns + } + return +} + +# msgcat::mcpackageconfig -- +# +# Get or modify the per caller namespace (e.g. packages) config options. +# +# Available subcommands are: +# +# get get the current value or an error if not set. +# isset return true, if the option is set +# set set the value (see also distinct option). +# Returns the number of loaded message files. +# unset Clear option. return "". +# +# Available options are: +# +# mcfolder +# The message catalog folder of the package. +# This is automatically set by mcload. +# If the value is changed using the set subcommand, an evntual +# loadcmd is invoked and all message files of the package locale are +# loaded. +# +# loadcmd +# The command gets executed before a message file would be +# sourced for this module. +# The command is invoked with the expanded locale list to load. +# The command is not invoked if the registering package namespace +# is not present. +# This callback might also be used as an alternative to message +# files. +# If the value is changed using the set subcommand, the callback is +# directly invoked with the current file locale list. No file load is +# executed. +# +# changecmd +# The command is invoked, after an executed locale change. +# Appended argument is expanded mcpreferences. +# +# unknowncmd +# Use a package locale mcunknown procedure instead the global one. +# The appended arguments are identical to mcunknown. +# +# Arguments: +# subcommand Operation on the package +# option The package option to get or set. +# ?value? Eventual value for the subcommand +# +# Results: +# Depends on the subcommand and option and is described there + +proc msgcat::mcpackageconfig {subcommand option {value ""}} { + variable PackageConfig + # get namespace + set ns [uplevel 1 {::namespace current}] + + if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { + return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ + changecmd, or unknowncmd" + } + + # check if value argument is exactly provided + if {[llength [info level 0]] == 4 } { + # value provided + if {$subcommand in {"get" "isset" "unset"}} { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 2] value\"" + } + } elseif {$subcommand eq "set"} { + return -code error\ + "wrong # args: should be \"[lrange [info level 0] 0 2]\"" + } + + # Execute subcommands + switch -exact -- $subcommand { + get { # Operation get return current value + if {![dict exists $PackageConfig $option $ns]} { + return -code error "package option \"$option\" not set" + } + return [dict get $PackageConfig $option $ns] + } + isset { return [dict exists $PackageConfig $option $ns] } + unset { dict unset PackageConfig $option $ns } + set { # Set option + + if {$option eq "mcfolder"} { + set value [file normalize $value] + } + # Check if changed + if { [dict exists $PackageConfig $option $ns] + && $value eq [dict get $PackageConfig $option $ns] } { + return 0 + } + + # set new value + dict set PackageConfig $option $ns $value + + # Reload pending message catalogs + switch -exact -- $option { + mcfolder { return [Load $ns [PackageLocales $ns]] } + loadcmd { return [Load $ns [PackageLocales $ns] 1] } + } + return 0 + } + default { + return -code error "unknown subcommand \"$subcommand\":\ + must be get, isset, unset, or set" + } + } + return +} + +# msgcat::PackagePreferences -- +# +# Return eventual present package preferences or the default list if not +# present. +# +# Arguments: +# ns Package namespace +# +# Results: +# locale list + +proc msgcat::PackagePreferences {ns} { + variable PackageConfig + if {[dict exists $PackageConfig loclist $ns]} { + return [dict get $PackageConfig loclist $ns] + } + variable Loclist + return $Loclist +} + +# msgcat::PackageLocales -- +# +# Return eventual present package locales or the default list if not +# present. +# +# Arguments: +# ns Package namespace +# +# Results: +# locale list + +proc msgcat::PackageLocales {ns} { + variable PackageConfig + if {[dict exists $PackageConfig loadedlocales $ns]} { + return [dict get $PackageConfig loadedlocales $ns] + } + variable LoadedLocales + return $LoadedLocales +} + +# msgcat::ListComplement -- +# +# Build the complement of two lists. +# Return a list with all elements in list2 but not in list1. +# Optionally return the intersection. +# +# Arguments: +# list1 excluded list +# list2 included list +# inlistname If not "", write in this variable the intersection list +# +# Results: +# list with all elements in list2 but not in list1 + +proc msgcat::ListComplement {list1 list2 {inlistname ""}} { + if {"" ne $inlistname} { + upvar 1 $inlistname inlist + } + set inlist {} + set outlist {} + foreach item $list2 { + if {$item in $list1} { + lappend inlist $item + } else { + lappend outlist $item + } + } + return $outlist +} + # msgcat::mcload -- # # Attempt to load message catalogs for each locale in the @@ -316,29 +750,90 @@ proc msgcat::mcpreferences {} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { - variable Patternlist + return [uplevel 1 [list\ + [namespace origin mcpackageconfig] set mcfolder $langdir]] +} + +# msgcat::LoadAll -- +# +# Load a list of locales for all packages not having a package locale +# list. +# +# Arguments: +# langdir The directory to search. +# +# Results: +# Returns the number of message catalogs that were loaded. + +proc msgcat::LoadAll {locales} { + variable PackageConfig + variable LoadedLocales + if {0 == [llength $locales]} { return {} } + # filter jet unloaded locales + set locales [ListComplement $LoadedLocales $locales] + if {0 == [llength $locales]} { return {} } + lappend LoadedLocales {*}$locales + + set packages [lsort -unique [concat\ + [dict keys [dict get $PackageConfig loadcmd]]\ + [dict keys [dict get $PackageConfig mcfolder]]]] + foreach ns $packages { + if {! [dict exists $PackageConfig loclist $ns] } { + Load $ns $locales + } + } + return $locales +} + +# msgcat::Load -- +# +# Invoke message load callback and load message catalog files. +# +# Arguments: +# ns Namespace (equal package) to load the message catalog. +# locales List of locales to load. +# callbackonly true if only callback should be invoked +# +# Results: +# Returns the number of message catalogs that were loaded. + +proc msgcat::Load {ns locales {callbackonly 0}} { variable FileLocale + variable PackageConfig + variable LoadedLocals + + if {0 == [llength $locales]} { return 0 } + + # Invoke callback + Invoke loadcmd $locales $ns + + if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} { + return 0 + } + + # Invoke file load + set langdir [dict get $PackageConfig mcfolder $ns] + # Save the file locale if we are recursively called if {[info exists FileLocale]} { set nestedFileLocale $FileLocale } set x 0 - set filelist {} - foreach pattern [lsort -unique [concat [mcpreferences] $Patternlist]] { - if { $pattern eq {} } { - set pattern ROOT + foreach p $locales { + if { $p eq {} } { + set p ROOT } - lappend filelist {*}[glob -directory $langdir -nocomplain -types {f r}\ - -- $pattern.msg] - } - foreach langfile [lsort -unique $filelist] { - incr x - set FileLocale [string tolower [file tail [file rootname $langfile]]] - if {"root" eq $FileLocale} { - set FileLocale "" + set langfile [file join $langdir $p.msg] + if {[file exists $langfile]} { + incr x + set FileLocale [string tolower\ + [file tail [file rootname $langfile]]] + if {"root" eq $FileLocale} { + set FileLocale "" + } + namespace inscope $ns [list ::source -encoding utf-8 $langfile] + unset FileLocale } - uplevel 1 [list ::source -encoding utf-8 $langfile] - unset FileLocale } if {[info exists nestedFileLocale]} { set FileLocale $nestedFileLocale @@ -346,6 +841,44 @@ proc msgcat::mcload {langdir} { return $x } +# msgcat::Invoke -- +# +# Invoke a set of registered callbacks. +# The callback is only invoked, if its registered namespace exists. +# +# Arguments: +# index Index into PackageConfig to get callback command +# arglist parameters to the callback invocation +# ns (Optional) package to call. +# If not given or empty, check all registered packages. +# resultname Variable to save the callback result of the last called +# callback to. May be set to "" to discard the result. +# +# Results: +# Returns true if at least one command was called + +proc msgcat::Invoke {index arglist {ns ""} {resultname ""}} { + variable PackageConfig + variable Config + if {"" ne $resultname} { + upvar 1 $resultname result + } + if {"" eq $ns} { + set packageList [dict keys [dict get $PackageConfig $index]] + } else { + set packageList [list $ns] + } + set called 0 + foreach ns $packageList { + if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} { + set result [namespace inscope $ns\ + [dict get $PackageConfig $index $ns] {*}$arglist] + set called 1 + } + } + return $called +} + # msgcat::mcset -- # # Set the translation for a given string in a specified locale. @@ -369,7 +902,7 @@ proc msgcat::mcset {locale src {dest ""}} { set locale [string tolower $locale] - dict set Msgs $locale $ns $src $dest + dict set Msgs $ns $locale $src $dest return $dest } @@ -390,16 +923,10 @@ proc msgcat::mcflset {src {dest ""}} { variable Msgs if {![info exists FileLocale]} { - return -code error \ - "must only be used inside a message catalog loaded with ::msgcat::mcload" + return -code error "must only be used inside a message catalog loaded\ + with ::msgcat::mcload" } - if {[llength [info level 0]] == 2} { ;# dest not specified - set dest $src - } - - set ns [uplevel 1 [list ::namespace current]] - dict set Msgs $FileLocale $ns $src $dest - return $dest + return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]] } # msgcat::mcmset -- @@ -419,14 +946,14 @@ proc msgcat::mcmset {locale pairs } { set length [llength $pairs] if {$length % 2} { return -code error "bad translation list:\ - should be \"[lindex [info level 0] 0] locale {src dest ...}\"" + should be \"[lindex [info level 0] 0] locale {src dest ...}\"" } set locale [string tolower $locale] set ns [uplevel 1 [list ::namespace current]] foreach {src dest} $pairs { - dict set Msgs $locale $ns $src $dest + dict set Msgs $ns $locale $src $dest } return [expr {$length / 2}] @@ -447,20 +974,10 @@ proc msgcat::mcflmset {pairs} { variable Msgs if {![info exists FileLocale]} { - return -code error \ - "must only be used inside a message catalog loaded with ::msgcat::mcload" + return -code error "must only be used inside a message catalog loaded\ + with ::msgcat::mcload" } - set length [llength $pairs] - if {$length % 2} { - return -code error "bad translation list:\ - should be \"[lindex [info level 0] 0] locale {src dest ...}\"" - } - - set ns [uplevel 1 [list ::namespace current]] - foreach {src dest} $pairs { - dict set Msgs $FileLocale $ns $src $dest - } - return [expr {$length / 2}] + return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]] } # msgcat::mcunknown -- -- cgit v0.12 From f9c9b71cd327714fabe221f91e2f9af29fdd9b85 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 20 Sep 2012 09:53:02 +0000 Subject: clock uses new msgcat features --- ChangeLog | 3 +- library/clock.tcl | 1203 +++++++++++++++++++++++---------------------- library/msgcat/msgcat.tcl | 88 ++-- 3 files changed, 688 insertions(+), 606 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9920962..2c6a2ce 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,8 @@ 2012-09-19 Harald Oehlmann * library/msgcat/msgcat.tcl: dynamic locale change with mc file - load on locale change. + * library/clock.tcl: load on locale change. + clock uses new msgcat features. 2012-09-19 Jan Nijtmans diff --git a/library/clock.tcl b/library/clock.tcl index 0696c47..38394d2 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -2,9 +2,9 @@ # # clock.tcl -- # -# This file implements the portions of the [clock] ensemble that are -# coded in Tcl. Refer to the users' manual to see the description of -# the [clock] command and its subcommands. +# This file implements the portions of the [clock] ensemble that +# are coded in Tcl. Refer to the users' manual to see the description +# of the [clock] command and its subcommands. # # #---------------------------------------------------------------------- @@ -15,11 +15,11 @@ # #---------------------------------------------------------------------- -# We must have message catalogs that support the root locale, and we need -# access to the Registry on Windows systems. +# We must have message catalogs that support the root locale, and +# we need access to the Registry on Windows systems. uplevel \#0 { - package require msgcat 1.4 + package require msgcat 1.6 if { $::tcl_platform(platform) eq {windows} } { if { [catch { package require registry 1.1 }] } { namespace eval ::tcl::clock [list variable NoRegistry {}] @@ -27,8 +27,9 @@ uplevel \#0 { } } -# Put the library directory into the namespace for the ensemble so that the -# library code can find message catalogs and time zone definition files. +# Put the library directory into the namespace for the ensemble +# so that the library code can find message catalogs and time zone +# definition files. namespace eval ::tcl::clock \ [list variable LibDir [file dirname [info script]]] @@ -39,10 +40,10 @@ namespace eval ::tcl::clock \ # # Manipulate times. # -# The 'clock' command manipulates time. Refer to the user documentation for -# the available subcommands and what they do. +# The 'clock' command manipulates time. Refer to the user documentation +# for the available subcommands and what they do. # -#---------------------------------------------------------------------- +#---------------------------------------------------------------------- namespace eval ::tcl::clock { @@ -58,8 +59,8 @@ namespace eval ::tcl::clock { # Import the message catalog commands that we use. - namespace import ::msgcat::mcload - namespace import ::msgcat::mclocale + namespace import ::msgcat::mc + namespace import ::msgcat::mcpackagelocale } @@ -75,11 +76,11 @@ namespace eval ::tcl::clock { # Side effects: # Namespace variable in the 'clock' subsystem are initialized. # -# The '::tcl::clock::Initialize' procedure initializes the namespace variables -# and root locale message catalog for the 'clock' subsystem. It is broken -# into a procedure rather than simply evaluated as a script so that it will be -# able to use local variables, avoiding the dangers of 'creative writing' as -# in Bug 1185933. +# The '::tcl::clock::Initialize' procedure initializes the namespace +# variables and root locale message catalog for the 'clock' subsystem. +# It is broken into a procedure rather than simply evaluated as a script +# so that it will be able to use local variables, avoiding the dangers +# of 'creative writing' as in Bug 1185933. # #---------------------------------------------------------------------- @@ -106,6 +107,10 @@ proc ::tcl::clock::Initialize {} { } InitTZData + mcpackagelocale set {} + ::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs] + ::msgcat::mcpackageconfig set unknowncmd "" + # Define the message catalog for the root locale. ::msgcat::mcmset {} { @@ -171,8 +176,8 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227 - # For Belgium, we follow Southern Netherlands; Liege Diocese changed - # several weeks later. + # For Belgium, we follow Southern Netherlands; Liege Diocese + # changed several weeks later. ::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238 ::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238 @@ -188,13 +193,13 @@ proc ::tcl::clock::Initialize {} { # Germany, Norway, Denmark (Catholic Germany changed earlier) ::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032 - ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032 + ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032 - # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed at - # various times) + # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed + # at various times) ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165 @@ -216,23 +221,23 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639 - # Romania (Transylvania changed earler - perhaps de_RO should show the - # earlier date?) + # Romania (Transylvania changed earler - perhaps de_RO should show + # the earlier date?) ::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063 # Greece ::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480 - + #------------------------------------------------------------------ # # CONSTANTS # #------------------------------------------------------------------ - # Paths at which binary time zone data for the Olson libraries are known - # to reside on various operating systems + # Paths at which binary time zone data for the Olson libraries + # are known to reside on various operating systems variable ZoneinfoPaths {} foreach path { @@ -249,7 +254,6 @@ proc ::tcl::clock::Initialize {} { # Define the directories for time zone data and message catalogs. variable DataDir [file join $LibDir tzdata] - variable MsgDir [file join $LibDir msgs] # Number of days in the months, in common years and leap years. @@ -281,10 +285,10 @@ proc ::tcl::clock::Initialize {} { variable FEB_28 58 - # Translation table to map Windows TZI onto cities, so that the Olson - # rules can apply. In some cases the mapping is ambiguous, so it's wise - # to specify $::env(TCL_TZ) rather than simply depending on the system - # time zone. + # Translation table to map Windows TZI onto cities, so that + # the Olson rules can apply. In some cases the mapping is ambiguous, + # so it's wise to specify $::env(TCL_TZ) rather than simply depending + # on the system time zone. # The keys are long lists of values obtained from the time zone # information in the Registry. In order, the list elements are: @@ -295,10 +299,10 @@ proc ::tcl::clock::Initialize {} { # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute # DaylightDate.wSecond DaylightDate.wMilliseconds - # The values are the names of time zones where those rules apply. There - # is considerable ambiguity in certain zones; an attempt has been made to - # make a reasonable guess, but this table needs to be taken with a grain - # of salt. + # The values are the names of time zones where those rules apply. + # There is considerable ambiguity in certain zones; an attempt has + # been made to make a reasonable guess, but this table needs to be + # taken with a grain of salt. variable WinZoneInfo [dict create {*}{ {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein @@ -377,10 +381,10 @@ proc ::tcl::clock::Initialize {} { {46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu }] - # Groups of fields that specify the date, priorities, and code bursts that - # determine Julian Day Number given those groups. The code in [clock - # scan] will choose the highest priority (lowest numbered) set of fields - # that determines the date. + # Groups of fields that specify the date, priorities, and + # code bursts that determine Julian Day Number given those groups. + # The code in [clock scan] will choose the highest priority + # (lowest numbered) set of fields that determines the date. variable DateParseActions { @@ -484,8 +488,8 @@ proc ::tcl::clock::Initialize {} { } } - # Groups of fields that specify time of day, priorities, and code that - # processes them + # Groups of fields that specify time of day, priorities, + # and code that processes them variable TimeParseActions { @@ -623,11 +627,6 @@ proc ::tcl::clock::Initialize {} { # in the given locales and dictionaries # mapping the numerals to their numeric # values. - variable McLoaded {}; # Dictionary whose keys are locales - # in which [mcload] has been executed - # and whose values are second-level - # dictionaries indexed by message - # name and giving message text. # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists, # it contains the value of the # system time zone, as determined from @@ -651,14 +650,16 @@ proc ::tcl::clock::Initialize {} { # # clock format -- # -# Formats a count of seconds since the Posix Epoch as a time of day. +# Formats a count of seconds since the Posix Epoch as a time +# of day. # -# The 'clock format' command formats times of day for output. Refer to the -# user documentation to see what it does. +# The 'clock format' command formats times of day for output. +# Refer to the user documentation to see what it does. # #---------------------------------------------------------------------- proc ::tcl::clock::format { args } { + variable FormatProc variable TZData @@ -667,7 +668,7 @@ proc ::tcl::clock::format { args } { set clockval [lindex $args 0] # Get the data for time changes in the given zone - + if {$timezone eq ""} { set timezone [GetSystemTimeZone] } @@ -677,11 +678,11 @@ proc ::tcl::clock::format { args } { return -options $opts $retval } } - - # Build a procedure to format the result. Cache the built procedure's name - # in the 'FormatProc' array to avoid losing its internal representation, - # which contains the name resolution. - + + # Build a procedure to format the result. Cache the built procedure's + # name in the 'FormatProc' array to avoid losing its internal + # representation, which contains the name resolution. + set procName formatproc'$format'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] if {[info exists FormatProc($procName)]} { @@ -690,8 +691,9 @@ proc ::tcl::clock::format { args } { set FormatProc($procName) \ [ParseClockFormatFormat $procName $format $locale] } - + return [$procName $clockval $timezone] + } #---------------------------------------------------------------------- @@ -710,31 +712,39 @@ proc ::tcl::clock::format { args } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { + if {[namespace which $procName] ne {}} { return $procName } # Map away the locale-dependent composite format groups - - EnterLocale $locale oldLocale + + EnterLocale $locale # Change locale if a fresh locale has been given on the command line. - try { - return [ParseClockFormatFormat2 $format $locale $procName] - } trap CLOCK {result opts} { - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + set status [catch { + + ParseClockFormatFormat2 $format $locale $procName - if { [info exists oldLocale] } { - mclocale $oldLocale + } result opts] + + # Return either the error or the proc name + + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { + return -code error $result + } else { + return -options $opts $result } + } else { + return $result } + } proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { + set didLocaleEra 0 set didLocaleNumerals 0 set preFormatCode \ @@ -749,7 +759,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set formatString {} set substituents {} set state {} - + set format [LocalizeFormat $locale $format] foreach char [split $format {}] { @@ -776,7 +786,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [lindex @DAYS_OF_WEEK_ABBREV@ \ [expr {[dict get $date dayOfWeek] \ % 7}]]}] - } + } A { # Day of week, spelt out. append formatString %s append substituents \ @@ -877,7 +887,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { k { # Hour (0-23), no leading zero append formatString %2d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 3600 % 24 }]} } @@ -898,7 +908,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { M { # Minute of the hour, leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 60 % 60 }]} } @@ -939,7 +949,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [expr {(([dict get $date localSeconds] % 86400) < 43200) ? $am : $pm}]} - + } Q { # Hi, Jeff! append formatString %s @@ -949,11 +959,11 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents { [dict get $date seconds]} } - S { # Second of the minute, with + S { # Second of the minute, with # leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] % 60 }]} } t { # A literal tab character @@ -974,7 +984,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } incr dow set UweekNumber \ - [expr { ( [dict get $date dayOfYear] + [expr { ( [dict get $date dayOfYear] - $dow + 7 ) / 7 }] } @@ -997,7 +1007,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set WweekNumber \ [expr { ( [dict get $date dayOfYear] - [dict get $date dayOfWeek] - + 7 ) + + 7 ) / 7 }] } append formatString %02d @@ -1066,7 +1076,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { percentO { # Character following %O set state {} switch -exact -- $char { - d - e { # Day of the month in alternative + d - e { # Day of the month in alternative # numerals append formatString %s append substituents \ @@ -1078,7 +1088,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 3600 % 24 }]]} } @@ -1104,7 +1114,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 60 % 60 }]]} } @@ -1113,7 +1123,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] % 60 }]]} } u { # Day of the week (Monday=1,Sunday=7) @@ -1144,9 +1154,9 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } } } - + # Clean up any improperly terminated groups - + switch -exact -- $state { percent { append formatString %% @@ -1173,14 +1183,16 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { # # clock scan -- # -# Inputs a count of seconds since the Posix Epoch as a time of day. +# Inputs a count of seconds since the Posix Epoch as a time +# of day. # -# The 'clock format' command scans times of day on input. Refer to the user -# documentation to see what it does. +# The 'clock format' command scans times of day on input. +# Refer to the user documentation to see what it does. # #---------------------------------------------------------------------- proc ::tcl::clock::scan { args } { + set format {} # Check the count of args @@ -1242,17 +1254,21 @@ proc ::tcl::clock::scan { args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($base) } } result] } { - return -code error "expected integer but got \"$base\"" + return -code error \ + "expected integer but got \"$base\"" } - if { ![string is boolean -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + if { ![string is boolean $gmt] } { + return -code error \ + "expected boolean value but got \"$gmt\"" + } else { + if { $gmt } { + set timezone :GMT + } } if { ![info exists saw(-format)] } { - # Perhaps someday we'll localize the legacy code. Right now, it's not - # localized. + # Perhaps someday we'll localize the legacy code. Right now, + # it's not localized. if { [info exists saw(-locale)] } { return -code error \ -errorcode [list CLOCK flagWithLegacyFormat] \ @@ -1264,25 +1280,27 @@ proc ::tcl::clock::scan { args } { # Change locale if a fresh locale has been given on the command line. - EnterLocale $locale oldLocale + EnterLocale $locale + + set status [catch { - try { # Map away the locale-dependent composite format groups set scanner [ParseClockScanFormat $format $locale] - return [$scanner $string $base $timezone] - } trap CLOCK {result opts} { - # Conceal location of generation of expected errors + $scanner $string $base $timezone - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + } result opts] - if { [info exists oldLocale] } { - mclocale $oldLocale + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { + return -code error $result + } else { + return -options $opts $result } + } else { + return $result } + } #---------------------------------------------------------------------- @@ -1298,50 +1316,52 @@ proc ::tcl::clock::scan { args } { # locale - (Unused) Name of the locale where the time will be scanned. # # Results: -# Returns the date and time extracted from the string in seconds from -# the epoch +# Returns the date and time extracted from the string in seconds +# from the epoch # #---------------------------------------------------------------------- proc ::tcl::clock::FreeScan { string base timezone locale } { + variable TZData # Get the data for time changes in the given zone - - try { - SetupTimeZone $timezone - } on error {retval opts} { + + if {[catch {SetupTimeZone $timezone} retval opts]} { dict unset opts -errorinfo return -options $opts $retval } - # Extract year, month and day from the base time for the parser to use as - # defaults + # Extract year, month and day from the base time for the + # parser to use as defaults - set date [GetDateFields $base $TZData($timezone) 2361222] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + set date [GetDateFields \ + $base \ + $TZData($timezone) \ + 2361222] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] - # Parse the date. The parser will return a list comprising date, time, - # time zone, relative month/day/seconds, relative weekday, ordinal month. - - try { - set scanned [Oldscan $string \ - [dict get $date year] \ - [dict get $date month] \ - [dict get $date dayOfMonth]] - lassign $scanned \ - parseDate parseTime parseZone parseRel \ - parseWeekday parseOrdinalMonth - } on error message { - return -code error \ - "unable to convert date-time string \"$string\": $message" + # Parse the date. The parser will return a list comprising + # date, time, time zone, relative month/day/seconds, relative + # weekday, ordinal month. + + set status [catch { + Oldscan $string \ + [dict get $date year] \ + [dict get $date month] \ + [dict get $date dayOfMonth] + } result] + if { $status != 0 } { + return -code error "unable to convert date-time string \"$string\": $result" } - # If the caller supplied a date in the string, update the 'date' dict with - # the value. If the caller didn't specify a time with the date, default to - # midnight. + lassign $result parseDate parseTime parseZone parseRel \ + parseWeekday parseOrdinalMonth + + # If the caller supplied a date in the string, update the 'date' dict + # with the value. If the caller didn't specify a time with the date, + # default to midnight. if { [llength $parseDate] > 0 } { lassign $parseDate y m d @@ -1361,12 +1381,12 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } } - # If the caller supplied a time zone in the string, it comes back as a - # two-element list; the first element is the number of minutes east of - # Greenwich, and the second is a Daylight Saving Time indicator (1 == yes, - # 0 == no, -1 == unknown). We make it into a time zone indicator of - # +-hhmm. - + # If the caller supplied a time zone in the string, it comes back + # as a two-element list; the first element is the number of minutes + # east of Greenwich, and the second is a Daylight Saving Time + # indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into + # a time zone indicator of +-hhmm. + if { [llength $parseZone] > 0 } { lassign $parseZone minEast dstFlag set timezone [FormatNumericTimeZone \ @@ -1380,19 +1400,18 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222] if { $parseTime ne {} } { dict set date secondOfDay $parseTime - } elseif { [llength $parseWeekday] != 0 - || [llength $parseOrdinalMonth] != 0 - || ( [llength $parseRel] != 0 + } elseif { [llength $parseWeekday] != 0 + || [llength $parseOrdinalMonth] != 0 + || ( [llength $parseRel] != 0 && ( [lindex $parseRel 0] != 0 || [lindex $parseRel 1] != 0 ) ) } { dict set date secondOfDay 0 } - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] dict set date tzName $timezone set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222] set seconds [dict get $date seconds] @@ -1404,17 +1423,18 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { set seconds [add $seconds \ $relMonth months $relDay days $relSecond seconds \ -timezone $timezone -locale $locale] - } + } # Do relative weekday - + if { [llength $parseWeekday] > 0 } { + lassign $parseWeekday dayOrdinal dayOfWeek set date2 [GetDateFields $seconds $TZData($timezone) 2361222] dict set date2 era CE - set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr { - [dict get $date2 julianDay] + 6 - }]] + set jdwkday [WeekdayOnOrBefore $dayOfWeek \ + [expr { [dict get $date2 julianDay] + + 6 }]] incr jdwkday [expr { 7 * $dayOrdinal }] if { $dayOrdinal > 0 } { incr jdwkday -7 @@ -1422,20 +1442,21 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { dict set date2 secondOfDay \ [expr { [dict get $date2 localSeconds] % 86400 }] dict set date2 julianDay $jdwkday - dict set date2 localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date2 julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date2 localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date2 julianDay]) ) + + [dict get $date secondOfDay] }] dict set date2 tzName $timezone set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \ 2361222] set seconds [dict get $date2 seconds] + } # Do relative month if { [llength $parseOrdinalMonth] > 0 } { + lassign $parseOrdinalMonth monthOrdinal monthNumber if { $monthOrdinal > 0 } { set monthDiff [expr { $monthNumber - [dict get $date month] }] @@ -1452,6 +1473,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } set seconds [add $seconds $monthOrdinal years $monthDiff months \ -timezone $timezone -locale $locale] + } return $seconds @@ -1469,27 +1491,30 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # locale - The current locale # # Results: -# Constructs and returns a procedure that accepts the string being -# scanned, the base time, and the time zone. The procedure will either -# return the scanned time or else throw an error that should be rethrown -# to the caller of [clock scan] +# Constructs and returns a procedure that accepts the +# string being scanned, the base time, and the time zone. +# The procedure will either return the scanned time or +# else throw an error that should be rethrown to the caller +# of [clock scan] # # Side effects: -# The given procedure is defined in the ::tcl::clock namespace. Scan -# procedures are not deleted once installed. -# -# Why do we parse dates by defining a procedure to parse them? The reason is -# that by doing so, we have one convenient place to cache all the information: -# the regular expressions that match the patterns (which will be compiled), -# the code that assembles the date information, everything lands in one place. -# In this way, when a given format is reused at run time, all the information +# The given procedure is defined in the ::tcl::clock +# namespace. Scan procedures are not deleted once installed. +# +# Why do we parse dates by defining a procedure to parse them? +# The reason is that by doing so, we have one convenient place to +# cache all the information: the regular expressions that match the +# patterns (which will be compiled), the code that assembles the +# date information, everything lands in one place. In this way, +# when a given format is reused at run time, all the information # of how to apply it is available in a single place. # #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockScanFormat {formatString locale} { - # Check whether the format has been parsed previously, and return the - # existing recognizer if it has. + + # Check whether the format has been parsed previously, and return + # the existing recognizer if it has. set procName scanproc'$formatString'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] @@ -1533,8 +1558,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append re {[[:space:]]+} } else { if { ! [string is alnum $c] } { - append re "\\" - } + append re \\ + } append re $c } } @@ -1651,7 +1676,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "::scan \$field" [incr captureCount] " %ld" \ "\]\n" } - m - N { # Month number + m - N { # Month number append re \\s*(\\d\\d?) dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ @@ -1694,9 +1719,10 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { \] \n } s { # Seconds from Posix Epoch - # This next case is insanely difficult, because it's - # problematic to determine whether the field is - # actually within the range of a wide integer. + # This next case is insanely difficult, + # because it's problematic to determine + # whether the field is actually within + # the range of a wide integer. append re {\s*([-+]?\d+)} dict set fieldSet seconds [incr fieldCount] append postcode {dict set date seconds } \[ \ @@ -1729,13 +1755,14 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { dict set date dayOfWeek $dow } } - U { # Week of year. The first Sunday of - # the year is the first day of week - # 01. No scan rule uses this group. + U { # Week of year. The + # first Sunday of the year is the + # first day of week 01. No scan rule + # uses this group. append re \\s*\\d\\d? } V { # Week of ISO8601 year - + append re \\s*(\\d\\d?) dict set fieldSet iso8601Week [incr fieldCount] append postcode "dict set date iso8601Week \[" \ @@ -1907,7 +1934,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "day of week is greater than 7" } dict set date dayOfWeek $dow - } + } } y { lassign [LocaleNumeralMatcher $locale] regex lookup @@ -1953,11 +1980,10 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody $postcode append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n - # Set up the time zone before doing anything with a default base date - # that might need a timezone to interpret it. + # Get time zone if needed - if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + if { ![dict exists $fieldSet seconds] + && ![dict exists $fieldSet starDate] } { if { [dict exists $fieldSet tzName] } { append procBody { set timeZone [dict get $date tzName] @@ -1976,29 +2002,24 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions] - # Assemble seconds from the Julian day and second of the day. - # Convert to local time unless epoch seconds or stardate are - # being processed - they're always absolute + # Assemble seconds, and convert local nominal time to UTC. - if { ![dict exists $fieldSet seconds] + if { ![dict exists $fieldSet seconds] && ![dict exists $fieldSet starDate] } { append procBody { if { [dict get $date julianDay] > 5373484 } { return -code error -errorcode [list CLOCK dateTooLarge] \ "requested date too large to represent" } - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] } - - # Finally, convert the date to local time - append procBody { set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ - $TZData($timeZone) $changeover] + $TZData($timeZone) \ + $changeover] } } @@ -2012,29 +2033,31 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { return $procName } - + #---------------------------------------------------------------------- # # LocaleNumeralMatcher -- # -# Composes a regexp that captures the numerals in the given locale, and -# a dictionary to map them to conventional numerals. +# Composes a regexp that captures the numerals in the given +# locale, and a dictionary to map them to conventional numerals. # # Parameters: # locale - Name of the current locale # # Results: -# Returns a two-element list comprising the regexp and the dictionary. +# Returns a two-element list comprising the regexp and the +# dictionary. # # Side effects: # Caches the result. # #---------------------------------------------------------------------- -proc ::tcl::clock::LocaleNumeralMatcher {l} { +proc ::tcl::clock::LocaleNumeralMatcher {locale} { + variable LocaleNumeralCache - if { ![dict exists $LocaleNumeralCache $l] } { + if { ![dict exists $LocaleNumeralCache $locale] } { set d {} set i 0 set sep \( @@ -2046,20 +2069,20 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { incr i } append re \) - dict set LocaleNumeralCache $l [list $re $d] + dict set LocaleNumeralCache $locale [list $re $d] } - return [dict get $LocaleNumeralCache $l] + return [dict get $LocaleNumeralCache $locale] } - + #---------------------------------------------------------------------- # # UniquePrefixRegexp -- # -# Composes a regexp that performs unique-prefix matching. The RE -# matches one of a supplied set of strings, or any unique prefix -# thereof. +# Composes a regexp that performs unique-prefix matching. The +# RE matches one of a supplied set of strings, or any unique +# prefix thereof. # # Parameters: # data - List of alternating match-strings and values. @@ -2067,10 +2090,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { # distinct. # # Results: -# Returns a two-element list. The first is a regexp that matches any -# unique prefix of any of the strings. The second is a dictionary whose -# keys are match values from the regexp and whose values are the -# corresponding values from 'data'. +# Returns a two-element list. The first is a regexp that +# matches any unique prefix of any of the strings. The second +# is a dictionary whose keys are match values from the regexp +# and whose values are the corresponding values from 'data'. # # Side effects: # None. @@ -2078,10 +2101,11 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { #---------------------------------------------------------------------- proc ::tcl::clock::UniquePrefixRegexp { data } { - # The 'successors' dictionary will contain, for each string that is a - # prefix of any key, all characters that may follow that prefix. The - # 'prefixMapping' dictionary will have keys that are prefixes of keys and - # values that correspond to the keys. + + # The 'successors' dictionary will contain, for each string that + # is a prefix of any key, all characters that may follow that + # prefix. The 'prefixMapping' dictionary will have keys that + # are prefixes of keys and values that correspond to the keys. set prefixMapping [dict create] set successors [dict create {} {}] @@ -2089,7 +2113,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # Walk the key-value pairs foreach { key value } $data { - # Construct all prefixes of the key; + + # Construct all prefixes of the key; set prefix {} foreach char [split $key {}] { @@ -2107,8 +2132,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { } } - # Identify those prefixes that designate unique values, and those that are - # the full keys + # Identify those prefixes that designate unique values, and + # those that are the full keys set uniquePrefixMapping {} dict for { key valueList } $prefixMapping { @@ -2131,8 +2156,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # # MakeUniquePrefixRegexp -- # -# Service procedure for 'UniquePrefixRegexp' that constructs a regular -# expresison that matches the unique prefixes. +# Service procedure for 'UniquePrefixRegexp' that constructs +# a regular expresison that matches the unique prefixes. # # Parameters: # successors - Dictionary whose keys are all prefixes @@ -2144,17 +2169,18 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # prefixString - Current prefix being processed. # # Results: -# Returns a constructed regular expression that matches the set of -# unique prefixes beginning with the 'prefixString'. +# Returns a constructed regular expression that matches the set +# of unique prefixes beginning with the 'prefixString'. # # Side effects: # None. # #---------------------------------------------------------------------- -proc ::tcl::clock::MakeUniquePrefixRegexp { successors +proc ::tcl::clock::MakeUniquePrefixRegexp { successors uniquePrefixMapping prefixString } { + # Get the characters that may follow the current prefix string set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]] @@ -2162,15 +2188,13 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors return {} } - # If there is more than one successor character, or if the current prefix - # is a unique prefix, surround the generated re with non-capturing + # If there is more than one successor character, or if the current + # prefix is a unique prefix, surround the generated re with non-capturing # parentheses. set re {} - if { - [dict exists $uniquePrefixMapping $prefixString] - || [llength $schars] > 1 - } then { + if { [dict exists $uniquePrefixMapping $prefixString] + || [llength $schars] > 1 } { append re "(?:" } @@ -2192,7 +2216,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors if { [dict exists $uniquePrefixMapping $prefixString] } { append re ")?" - } elseif { [llength $schars] > 1 } { + } elseif { [llength $schars] > 1 } { append re ")" } @@ -2203,8 +2227,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # # MakeParseCodeFromFields -- # -# Composes Tcl code to extract the Julian Day Number from a dictionary -# containing date fields. +# Composes Tcl code to extract the Julian Day Number from a +# dictionary containing date fields. # # Parameters: # dateFields -- Dictionary whose keys are fields of the date, @@ -2215,8 +2239,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # the list must be in ascending order by priority # # Results: -# Returns a burst of code that extracts the day number from the given -# date. +# Returns a burst of code that extracts the day number from the +# given date. # # Side effects: # None. @@ -2224,6 +2248,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors #---------------------------------------------------------------------- proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { + set currPrio 999 set currFieldPos [list] set currCodeBurst { @@ -2231,15 +2256,16 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { } foreach { fieldSet prio parseAction } $parseActions { - # If we've found an answer that's better than any that follow, quit - # now. + + # If we've found an answer that's better than any that follow, + # quit now. if { $prio > $currPrio } { break } - # Accumulate the field positions that are used in the current field - # grouping. + # Accumulate the field positions that are used in the current + # field grouping. set fieldPos [list] set ok true @@ -2262,11 +2288,9 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { if { $prio == $currPrio } { foreach currPos $currFieldPos newPos $fPos { - if { - ![string is integer $newPos] - || ![string is integer $currPos] - || $newPos > $currPos - } then { + if { ![string is integer $newPos] + || ![string is integer $currPos] + || $newPos > $currPos } { break } if { $newPos < $currPos } { @@ -2284,86 +2308,75 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { set currPrio $prio set currFieldPos $fPos set currCodeBurst $parseAction + } return $currCodeBurst + } #---------------------------------------------------------------------- # # EnterLocale -- # -# Switch [mclocale] to a given locale if necessary +# By shure given locale is loaded and set variable Locale # # Parameters: # locale -- Desired locale -# oldLocaleVar -- Name of a variable in caller's scope that -# tracks the previous locale name. # # Results: -# Returns the locale that was previously current. +# % # # Side effects: -# Does [mclocale]. If necessary, uses [mcload] to load the designated -# locale's files, and tracks that it has done so in the 'McLoaded' -# variable. +# If necessary, uses [mcloadedlocales packageadd] to load the +# designated locale's files. # #---------------------------------------------------------------------- -proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { - upvar 1 $oldLocaleVar oldLocale - - variable MsgDir - variable McLoaded +proc ::tcl::clock::EnterLocale { locale } { - set oldLocale [mclocale] if { $locale eq {system} } { + if { $::tcl_platform(platform) ne {windows} } { - # On a non-windows platform, the 'system' locale is the same as - # the 'current' locale + + # On a non-windows platform, the 'system' locale is + # the same as the 'current' locale set locale current } else { - # On a windows platform, the 'system' locale is adapted from the - # 'current' locale by applying the date and time formats from the - # Control Panel. First, load the 'current' locale if it's not yet - # loaded - - if {![dict exists $McLoaded $oldLocale] } { - mcload $MsgDir - dict set McLoaded $oldLocale {} - } - # Make a new locale string for the system locale, and get the - # Control Panel information + # On a windows platform, the 'system' locale is + # adapted from the 'current' locale by applying the + # date and time formats from the Control Panel. + # First, load the 'current' locale if it's not yet loaded - set locale ${oldLocale}_windows - if { ![dict exists $McLoaded $locale] } { + mcpackagelocale [mclocale] + + # Make a new locale string for the system locale, and + # get the Control Panel information + + # This will only load the current locale below, as it is a + # descent from _windows. + # The _windows will be remembered as current and as loaded. + set locale [mclocale]_windows + if { $locale ni [::msgcat::mcpackagelocale loaded] } { LoadWindowsDateTimeFormats $locale - dict set McLoaded $locale {} } } } if { $locale eq {current}} { - set locale $oldLocale - unset oldLocale - } elseif { $locale eq $oldLocale } { - unset oldLocale - } else { - mclocale $locale + set locale [mclocale] } - if { ![dict exists $McLoaded $locale] } { - mcload $MsgDir - dict set McLoaded $locale {} - } -} + # Eventually load the locale + mcpackagelocale set $locale +} #---------------------------------------------------------------------- # # LoadWindowsDateTimeFormats -- # -# Load the date/time formats from the Control Panel in Windows and -# convert them so that they're usable by Tcl. +# Load the date/time formats from the Control Panel in Windows +# and convert them so that they're usable by Tcl. # # Parameters: # locale - Name of the locale in whose message catalog @@ -2375,12 +2388,14 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { # Side effects: # Updates the given message catalog with the locale strings. # -# Presumes that on entry, [mclocale] is set to the current locale, so that -# default strings can be obtained if the Registry query fails. +# Presumes that on entry, [mclocale] is set to the current locale, +# so that default strings can be obtained if the Registry query +# fails. # #---------------------------------------------------------------------- proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { + # Bail out if we can't find the Registry variable NoRegistry @@ -2482,6 +2497,7 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { } return + } #---------------------------------------------------------------------- @@ -2496,8 +2512,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { # format -- Format supplied to [clock scan] or [clock format] # # Results: -# Returns the string with locale-dependent composite format groups -# substituted out. +# Returns the string with locale-dependent composite format +# groups substituted out. # # Side effects: # None. @@ -2505,18 +2521,18 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { #---------------------------------------------------------------------- proc ::tcl::clock::LocalizeFormat { locale format } { - variable McLoaded - if { [dict exists $McLoaded $locale FORMAT $format] } { - return [dict get $McLoaded $locale FORMAT $format] - } - set inFormat $format + # message catalog key to cache this format + set key FORMAT_$format + if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } { + return [mc $key] + } # Handle locale-dependent format groups by mapping them out of the format # string. Note that the order of the [string map] operations is # significant because later formats can refer to later ones; for example # %c can refer to %X, which in turn can refer to %T. - + set list { %% %% %D %m/%d/%Y @@ -2533,8 +2549,8 @@ proc ::tcl::clock::LocalizeFormat { locale format } { lappend list %c [string map $list [mc DATE_TIME_FORMAT]] lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]] set format [string map $list $format] - - dict set McLoaded $locale FORMAT $inFormat $format + + mcset $locale $key $format return $format } @@ -2556,6 +2572,7 @@ proc ::tcl::clock::LocalizeFormat { locale format } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatNumericTimeZone { z } { + if { $z < 0 } { set z [expr { - $z }] set retval - @@ -2570,6 +2587,7 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { append retval [::format %02d $z] } return $retval + } #---------------------------------------------------------------------- @@ -2594,6 +2612,7 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatStarDate { date } { + variable Roddenberry # Get day of year, zero based @@ -2644,6 +2663,7 @@ proc ::tcl::clock::FormatStarDate { date } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { + variable Roddenberry # Build a tentative date from year and fraction. @@ -2659,8 +2679,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { set lp [IsGregorianLeapYear $date] - # Reconvert the fractional year according to whether the given year is a - # leap year + # Reconvert the fractional year according to whether the given + # year is a leap year if { $lp } { dict set date dayOfYear \ @@ -2673,11 +2693,10 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { dict unset date gregorian set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] - return [expr { - 86400 * [dict get $date julianDay] - - 210866803200 - + ( 86400 / 10 ) * $fractDay - }] + return [expr { 86400 * [dict get $date julianDay] + - 210866803200 + + ( 86400 / 10 ) * $fractDay }] + } #---------------------------------------------------------------------- @@ -2690,8 +2709,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { # str - String containing a decimal wide integer # # Results: -# Returns the string as a pure wide integer. Throws an error if the -# string is misformatted or out of range. +# Returns the string as a pure wide integer. Throws an error if +# the string is misformatted or out of range. # #---------------------------------------------------------------------- @@ -2712,8 +2731,8 @@ proc ::tcl::clock::ScanWide { str } { # # InterpretTwoDigitYear -- # -# Given a date that contains only the year of the century, determines -# the target value of a two-digit year. +# Given a date that contains only the year of the century, +# determines the target value of a two-digit year. # # Parameters: # date - Dictionary containing fields of the date. @@ -2730,17 +2749,18 @@ proc ::tcl::clock::ScanWide { str } { # Side effects: # None. # -# The current rule for interpreting a two-digit year is that the year shall be -# between 1937 and 2037, thus staying within the range of a 32-bit signed -# value for time. This rule may change to a sliding window in future -# versions, so the 'baseTime' parameter (which is currently ignored) is -# provided in the procedure signature. +# The current rule for interpreting a two-digit year is that the year +# shall be between 1937 and 2037, thus staying within the range of a +# 32-bit signed value for time. This rule may change to a sliding +# window in future versions, so the 'baseTime' parameter (which is +# currently ignored) is provided in the procedure signature. # #---------------------------------------------------------------------- -proc ::tcl::clock::InterpretTwoDigitYear { date baseTime +proc ::tcl::clock::InterpretTwoDigitYear { date baseTime { twoDigitField yearOfCentury } { fourDigitField year } } { + set yr [dict get $date $twoDigitField] if { $yr <= 37 } { dict set date $fourDigitField [expr { $yr + 2000 }] @@ -2748,6 +2768,7 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime dict set date $fourDigitField [expr { $yr + 1900 }] } return $date + } #---------------------------------------------------------------------- @@ -2773,6 +2794,7 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { + variable TZData # Find the Julian Day Number corresponding to the base time, and @@ -2786,6 +2808,7 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { dict set date year [dict get $date2 year] return $date + } #---------------------------------------------------------------------- @@ -2812,6 +2835,7 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time @@ -2829,7 +2853,7 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { # # AssignBaseMonth -- # -# Places the number of the current year and month into a +# Places the number of the current year and month into a # dictionary. # # Parameters: @@ -2848,6 +2872,7 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { + variable TZData # Find the year and month corresponding to the base time @@ -2857,6 +2882,7 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { dict set date year [dict get $date2 year] dict set date month [dict get $date2 month] return $date + } #---------------------------------------------------------------------- @@ -2882,6 +2908,7 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { + variable TZData # Find the Julian Day Number corresponding to the base time @@ -2918,6 +2945,7 @@ proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { + variable TZData # Find the Julian Day Number corresponding to the base time @@ -2947,6 +2975,7 @@ proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMSP { date } { + set hr [dict get $date hourAMPM] if { $hr == 12 } { set hr 0 @@ -2956,6 +2985,7 @@ proc ::tcl::clock::InterpretHMSP { date } { } dict set date hour $hr return [InterpretHMS $date[set date {}]] + } #---------------------------------------------------------------------- @@ -2978,11 +3008,11 @@ proc ::tcl::clock::InterpretHMSP { date } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMS { date } { - return [expr { - ( [dict get $date hour] * 60 - + [dict get $date minute] ) * 60 - + [dict get $date second] - }] + + return [expr { ( [dict get $date hour] * 60 + + [dict get $date minute] ) * 60 + + [dict get $date second] }] + } #---------------------------------------------------------------------- @@ -3005,6 +3035,7 @@ proc ::tcl::clock::InterpretHMS { date } { #---------------------------------------------------------------------- proc ::tcl::clock::GetSystemTimeZone {} { + variable CachedSystemTimeZone variable TimeZoneBad @@ -3037,69 +3068,76 @@ proc ::tcl::clock::GetSystemTimeZone {} { } else { return $timezone } + } #---------------------------------------------------------------------- # # ConvertLegacyTimeZone -- # -# Given an alphanumeric time zone identifier and the system time zone, -# convert the alphanumeric identifier to an unambiguous time zone. +# Given an alphanumeric time zone identifier and the system +# time zone, convert the alphanumeric identifier to an +# unambiguous time zone. # # Parameters: # tzname - Name of the time zone to convert # # Results: -# Returns a time zone name corresponding to tzname, but in an -# unambiguous form, generally +hhmm. +# Returns a time zone name corresponding to tzname, but +# in an unambiguous form, generally +hhmm. # -# This procedure is implemented primarily to allow the parsing of RFC822 -# date/time strings. Processing a time zone name on input is not recommended -# practice, because there is considerable room for ambiguity; for instance, is -# BST Brazilian Standard Time, or British Summer Time? +# This procedure is implemented primarily to allow the parsing of +# RFC822 date/time strings. Processing a time zone name on input +# is not recommended practice, because there is considerable room +# for ambiguity; for instance, is BST Brazilian Standard Time, or +# British Summer Time? # #---------------------------------------------------------------------- proc ::tcl::clock::ConvertLegacyTimeZone { tzname } { + variable LegacyTimeZone set tzname [string tolower $tzname] if { ![dict exists $LegacyTimeZone $tzname] } { return -code error -errorcode [list CLOCK badTZName $tzname] \ "time zone \"$tzname\" not found" + } else { + return [dict get $LegacyTimeZone $tzname] } - return [dict get $LegacyTimeZone $tzname] + } #---------------------------------------------------------------------- # # SetupTimeZone -- # -# Given the name or specification of a time zone, sets up its in-memory -# data. +# Given the name or specification of a time zone, sets up +# its in-memory data. # # Parameters: # tzname - Name of a time zone # # Results: -# Unless the time zone is ':localtime', sets the TZData array to contain -# the lookup table for local<->UTC conversion. Returns an error if the -# time zone cannot be parsed. +# Unless the time zone is ':localtime', sets the TZData array +# to contain the lookup table for local<->UTC conversion. +# Returns an error if the time zone cannot be parsed. # #---------------------------------------------------------------------- proc ::tcl::clock::SetupTimeZone { timezone } { + variable TZData if {! [info exists TZData($timezone)] } { variable MINWIDE if { $timezone eq {:localtime} } { + # Nothing to do, we'll convert using the localtime function - } elseif { - [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ - -> s hh mm ss] - } then { + } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ + -> s hh mm ss] } { + # Make a fixed offset ::scan $hh %d hh @@ -3120,21 +3158,24 @@ proc ::tcl::clock::SetupTimeZone { timezone } { set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]] } elseif { [string index $timezone 0] eq {:} } { + # Convert using a time zone file - if { + if { [catch { LoadTimeZoneFile [string range $timezone 1 end] - }] && [catch { + }] + && [catch { LoadZoneinfoFile [string range $timezone 1 end] }] - } then { + } { return -code error \ -errorcode [list CLOCK badTimeZone $timezone] \ "time zone \"$timezone\" not found" } - + } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } { + # This looks like a POSIX time zone - try to process it if { [catch {ProcessPosixTimeZone $tzfields} data opts] } { @@ -3147,8 +3188,9 @@ proc ::tcl::clock::SetupTimeZone { timezone } { } } else { - # We couldn't parse this as a POSIX time zone. Try again with a - # time zone file - this time without a colon + + # We couldn't parse this as a POSIX time zone. Try + # again with a time zone file - this time without a colon if { [catch { LoadTimeZoneFile $timezone }] && [catch { LoadZoneinfoFile $timezone } - opts] } { @@ -3172,22 +3214,25 @@ proc ::tcl::clock::SetupTimeZone { timezone } { # None. # # Results: -# Returns a time zone specifier that corresponds to the system time zone -# information found in the Registry. +# Returns a time zone specifier that corresponds to the system +# time zone information found in the Registry. # # Bugs: -# Fixed dates for DST change are unimplemented at present, because no -# time zone information supplied with Windows actually uses them! +# Fixed dates for DST change are unimplemented at present, because +# no time zone information supplied with Windows actually uses +# them! # -# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is specified, -# GuessWindowsTimeZone looks in the Registry for the system time zone -# information. It then attempts to find an entry in WinZoneInfo for a time -# zone that uses the same rules. If it finds one, it returns it; otherwise, -# it constructs a Posix-style time zone string and returns that. +# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is +# specified, GuessWindowsTimeZone looks in the Registry for the +# system time zone information. It then attempts to find an entry +# in WinZoneInfo for a time zone that uses the same rules. If +# it finds one, it returns it; otherwise, it constructs a Posix-style +# time zone string and returns that. # #---------------------------------------------------------------------- proc ::tcl::clock::GuessWindowsTimeZone {} { + variable WinZoneInfo variable NoRegistry variable TimeZoneBad @@ -3218,14 +3263,16 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { lappend data $val } }] } { + # Missing values in the Registry - bail out return :localtime } - # Make up a Posix time zone specifier if we can't find one. Check here - # that the tzdata file exists, in case we're running in an environment - # (e.g. starpack) where tzdata is incomplete. (Bug 1237907) + # Make up a Posix time zone specifier if we can't find one. + # Check here that the tzdata file exists, in case we're running + # in an environment (e.g. starpack) where tzdata is incomplete. + # (Bug 1237907) if { [dict exists $WinZoneInfo $data] } { set tzname [dict get $WinZoneInfo $data] @@ -3273,11 +3320,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { if { $dstYear == 0 } { append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek } else { - # I have not been able to find any locale on which Windows - # converts time zone on a fixed day of the year, hence don't - # know how to interpret the fields. If someone can inform me, - # I'd be glad to code it up. For right now, we bail out in - # such a case. + # I have not been able to find any locale on which + # Windows converts time zone on a fixed day of the year, + # hence don't know how to interpret the fields. + # If someone can inform me, I'd be glad to code it up. + # For right now, we bail out in such a case. return :localtime } append tzname / [::format %02d $dstHour] \ @@ -3286,11 +3333,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { if { $stdYear == 0 } { append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek } else { - # I have not been able to find any locale on which Windows - # converts time zone on a fixed day of the year, hence don't - # know how to interpret the fields. If someone can inform me, - # I'd be glad to code it up. For right now, we bail out in - # such a case. + # I have not been able to find any locale on which + # Windows converts time zone on a fixed day of the year, + # hence don't know how to interpret the fields. + # If someone can inform me, I'd be glad to code it up. + # For right now, we bail out in such a case. return :localtime } append tzname / [::format %02d $stdHour] \ @@ -3298,9 +3345,10 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { : [::format %02d $stdSecond] } dict set WinZoneInfo $data $tzname - } + } return [dict get $WinZoneInfo $data] + } #---------------------------------------------------------------------- @@ -3329,18 +3377,18 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { return } - # Since an unsafe interp uses the [clock] command in the master, this code - # is security sensitive. Make sure that the path name cannot escape the - # given directory. + # Since an unsafe interp uses the [clock] command in the master, + # this code is security sensitive. Make sure that the path name + # cannot escape the given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ -errorcode [list CLOCK badTimeZone $:fileName] \ "time zone \":$fileName\" not valid" } - try { + if { [catch { source -encoding utf-8 [file join $DataDir $fileName] - } on error {} { + }] } { return -code error \ -errorcode [list CLOCK badTimeZone :$fileName] \ "time zone \":$fileName\" not found" @@ -3358,8 +3406,8 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { # fileName - Relative path name of the file to load. # # Results: -# Returns an empty result normally; returns an error if no Olson file -# was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no +# Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data @@ -3367,11 +3415,12 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { + variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, this code - # is security sensitive. Make sure that the path name cannot escape the - # given directory. + # Since an unsafe interp uses the [clock] command in the master, + # this code is security sensitive. Make sure that the path name + # cannot escape the given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ @@ -3400,14 +3449,15 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { # fname - Absolute path name of the file. # # Results: -# Returns an empty result normally; returns an error if no Olson file -# was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no +# Olson file was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data # #---------------------------------------------------------------------- + proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { variable MINWIDE variable TZData @@ -3426,8 +3476,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { set d [read $f] close $f - # The file begins with a magic number, sixteen reserved bytes, and then - # six 4-byte integers giving counts of fileds in the file. + # The file begins with a magic number, sixteen reserved bytes, + # and then six 4-byte integers giving counts of fileds in the file. binary scan $d a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar @@ -3445,19 +3495,18 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { return -code error "$fileName contains leap seconds" } - # In a version 2 file, we use the second part of the file, which contains - # 64-bit transition times. + # In a version 2 file, we use the second part of the file, which + # contains 64-bit transition times. if {$version eq "2"} { - set seek [expr { - 44 - + 5 * $nTime - + 6 * $nType - + 4 * $nLeap - + $nIsStd - + $nIsGMT - + $nChar - }] + set seek [expr {44 + + 5 * $nTime + + 6 * $nType + + 4 * $nLeap + + $nIsStd + + $nIsGMT + + $nChar + }] binary scan $d @${seek}a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar if {$magic ne {TZif}} { @@ -3481,9 +3530,9 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { } set codes [linsert $codes 0 0] - # Next come ${nType} time type descriptions, each of which has an offset - # (seconds east of GMT), a DST indicator, and an index into the - # abbreviation text. + # Next come ${nType} time type descriptions, each of which has an + # offset (seconds east of GMT), a DST indicator, and an index into + # the abbreviation text. for { set i 0 } { $i < $nType } { incr i } { binary scan $d @${seek}Icc gmtOff isDst abbrInd @@ -3491,10 +3540,10 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { incr seek 6 } - # Next come $nChar characters of time zone name abbreviations, which are - # null-terminated. - # We build them up into a dictionary indexed by character index, because - # that's what's in the indices above. + # Next come $nChar characters of time zone name abbreviations, + # which are null-terminated. + # We build them up into a dictionary indexed by character index, + # because that's what's in the indices above. binary scan $d @${seek}a${nChar} abbrs incr seek ${nChar} @@ -3524,8 +3573,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { } # In a version 2 file, there is also a POSIX-style time zone description - # at the very end of the file. To get to it, skip over nLeap leap second - # values (8 bytes each), + # at the very end of the file. To get to it, skip over + # nLeap leap second values (8 bytes each), # nIsStd standard/DST indicators and nIsGMT UTC/local indicators. if {$version eq {2}} { @@ -3558,8 +3607,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # tz Time zone specifier to be interpreted # # Results: -# Returns a dictionary whose values contain the various pieces of the -# time zone specification. +# Returns a dictionary whose values contain the various pieces of +# the time zone specification. # # Side effects: # None. @@ -3570,7 +3619,7 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # The following keys are present in the dictionary: # stdName - Name of the time zone when Daylight Saving Time # is not in effect. -# stdSignum - Sign (+, -, or empty) of the offset from Greenwich +# stdSignum - Sign (+, -, or empty) of the offset from Greenwich # to the given (non-DST) time zone. + and the empty # string denote zones west of Greenwich, - denotes east # of Greenwich; this is contrary to the ISO convention @@ -3615,13 +3664,14 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # endHours, endMinutes, endSeconds - # Specify the end of DST in the same way that the start* fields # specify the beginning of DST. -# -# This procedure serves only to break the time specifier into fields. No -# attempt is made to canonicalize the fields or supply default values. +# +# This procedure serves only to break the time specifier into fields. +# No attempt is made to canonicalize the fields or supply default values. # #---------------------------------------------------------------------- proc ::tcl::clock::ParsePosixTimeZone { tz } { + if {[regexp -expanded -nocase -- { ^ # 1 - Standard time zone name @@ -3632,8 +3682,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 4 - Standard time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 5 - Standard time zone offset, seconds : ([[:digit:]]{1,2} ) )? @@ -3649,8 +3699,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 9 - DST time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 10 - DST time zone offset, seconds : ([[:digit:]]{1,2}) )? @@ -3663,8 +3713,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 13 - Month number 14 - Week of month 15 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3685,8 +3735,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 21 - Month number 22 - Week of month 23 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3713,21 +3763,27 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { x(endJ) x(endDayOfYear) \ x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \ x(endHours) x(endMinutes) x(endSeconds)] } { + # it's a good timezone return [array get x] + + } else { + + return -code error\ + -errorcode [list CLOCK badTimeZone $tz] \ + "unable to parse time zone specification \"$tz\"" + } - return -code error\ - -errorcode [list CLOCK badTimeZone $tz] \ - "unable to parse time zone specification \"$tz\"" } #---------------------------------------------------------------------- # # ProcessPosixTimeZone -- # -# Handle a Posix time zone after it's been broken out into fields. +# Handle a Posix time zone after it's been broken out into +# fields. # # Parameters: # z - Dictionary returned from 'ParsePosixTimeZone' @@ -3741,6 +3797,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { #---------------------------------------------------------------------- proc ::tcl::clock::ProcessPosixTimeZone { z } { + variable MINWIDE variable TZData @@ -3755,20 +3812,20 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } else { set stdSignum -1 } - set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] + set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] if { [dict get $z stdMinutes] ne {} } { - set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] + set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] } else { set stdMinutes 0 } if { [dict get $z stdSeconds] ne {} } { - set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] + set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] } else { set stdSeconds 0 } - set stdOffset [expr { - (($stdHours * 60 + $stdMinutes) * 60 + $stdSeconds) * $stdSignum - }] + set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes ) + * 60 + $stdSeconds ) + * $stdSignum }] set data [list [list $MINWIDE $stdOffset 0 $stdName]] # If there's no daylight zone, we're done @@ -3791,20 +3848,20 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { if { [dict get $z dstHours] eq {} } { set dstOffset [expr { 3600 + $stdOffset }] } else { - set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] + set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] if { [dict get $z dstMinutes] ne {} } { - set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] + set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] } else { set dstMinutes 0 } if { [dict get $z dstSeconds] ne {} } { - set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] + set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] } else { set dstSeconds 0 } - set dstOffset [expr { - (($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum - }] + set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes ) + * 60 + $dstSeconds ) + * $dstSignum }] } # Fill in defaults for European or US DST rules @@ -3813,10 +3870,8 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # US end time is the first Sunday in November. # EU end time is the last Sunday in October - if { - [dict get $z startDayOfYear] eq {} - && [dict get $z startMonth] eq {} - } then { + if { [dict get $z startDayOfYear] eq {} + && [dict get $z startMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z startWeekOfMonth 5 @@ -3835,10 +3890,8 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { dict set z startMinutes 0 dict set z startSeconds 0 } - if { - [dict get $z endDayOfYear] eq {} - && [dict get $z endMonth] eq {} - } then { + if { [dict get $z endDayOfYear] eq {} + && [dict get $z endMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z endMonth 10 @@ -3878,14 +3931,15 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } return $data -} + +} #---------------------------------------------------------------------- # # DeterminePosixDSTTime -- # -# Determines the time that Daylight Saving Time starts or ends from a -# Posix time zone specification. +# Determines the time that Daylight Saving Time starts or ends +# from a Posix time zone specification. # # Parameters: # z - Time zone data returned from ParsePosixTimeZone. @@ -3895,12 +3949,13 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # y - The year for which the transition time is to be determined. # # Results: -# Returns the transition time as a count of seconds from the epoch. The -# time is relative to the wall clock, not UTC. +# Returns the transition time as a count of seconds from +# the epoch. The time is relative to the wall clock, not UTC. # #---------------------------------------------------------------------- proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { + variable FEB_28 # Determine the start or end day of DST @@ -3908,16 +3963,18 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { set date [dict create era CE year $y] set doy [dict get $z ${bound}DayOfYear] if { $doy ne {} } { + # Time was specified as a day of the year if { [dict get $z ${bound}J] ne {} - && [IsGregorianLeapYear $y] + && [IsGregorianLeapYear $y] && ( $doy > $FEB_28 ) } { incr doy } dict set date dayOfYear $doy set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222] } else { + # Time was specified as a day of the week within a month dict set date month [dict get $z ${bound}Month] @@ -3932,9 +3989,8 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set jd [dict get $date julianDay] - set seconds [expr { - wide($jd) * wide(86400) - wide(210866803200) - }] + set seconds [expr { wide($jd) * wide(86400) + - wide(210866803200) }] set h [dict get $z ${bound}Hours] if { $h eq {} } { @@ -3956,6 +4012,7 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set tod [expr { ( $h * 60 + $m ) * 60 + $s }] return [expr { $seconds + $tod }] + } #---------------------------------------------------------------------- @@ -3973,26 +4030,26 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { # for the target locale. # # Results: -# Returns the dictionary, augmented with the keys, 'localeEra' and -# 'localeYear'. +# Returns the dictionary, augmented with the keys, 'localeEra' +# and 'localeYear'. # #---------------------------------------------------------------------- proc ::tcl::clock::GetLocaleEra { date etable } { + set index [BSearch $etable [dict get $date localSeconds]] if { $index < 0} { dict set date localeEra \ [::format %02d [expr { [dict get $date year] / 100 }]] - dict set date localeYear [expr { - [dict get $date year] % 100 - }] + dict set date localeYear \ + [expr { [dict get $date year] % 100 }] } else { dict set date localeEra [lindex $etable $index 1] - dict set date localeYear [expr { - [dict get $date year] - [lindex $etable $index 2] - }] + dict set date localeYear [expr { [dict get $date year] + - [lindex $etable $index 2] }] } return $date + } #---------------------------------------------------------------------- @@ -4010,9 +4067,10 @@ proc ::tcl::clock::GetLocaleEra { date etable } { # adopted in the current locale. # # Results: -# Returns the given dictionary augmented with a 'julianDay' key whose -# value is the desired Julian Day Number, and a 'gregorian' key that -# specifies whether the calendar is Gregorian (1) or Julian (0). +# Returns the given dictionary augmented with a 'julianDay' key +# whose value is the desired Julian Day Number, and a 'gregorian' +# key that specifies whether the calendar is Gregorian (1) or +# Julian (0). # # Side effects: # None. @@ -4023,6 +4081,7 @@ proc ::tcl::clock::GetLocaleEra { date etable } { #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { + # Get absolute year number from the civil year switch -exact -- [dict get $date era] { @@ -4038,25 +4097,21 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # Try the Gregorian calendar first. dict set date gregorian 1 - set jd [expr { - 1721425 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) - }] - + set jd [expr { 1721425 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) + - ( $ym1 / 100 ) + + ( $ym1 / 400 ) }] + # If the date is before the Gregorian change, use the Julian calendar. if { $jd < $changeover } { dict set date gregorian 0 - set jd [expr { - 1721423 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - }] + set jd [expr { 1721423 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) }] } dict set date julianDay $jd @@ -4067,8 +4122,8 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # # GetJulianDayFromEraYearMonthWeekDay -- # -# Determines the Julian Day number corresponding to the nth given -# day-of-the-week in a given month. +# Determines the Julian Day number corresponding to the nth +# given day-of-the-week in a given month. # # Parameters: # date - Dictionary containing the keys, 'era', 'year', 'month' @@ -4087,9 +4142,10 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { - # Come up with a reference day; either the zeroeth day of the given month - # (dayOfWeekInMonth >= 0) or the seventh day of the following month - # (dayOfWeekInMonth < 0) + + # Come up with a reference day; either the zeroeth day of the + # given month (dayOfWeekInMonth >= 0) or the seventh day of the + # following month (dayOfWeekInMonth < 0) set date2 $date set week [dict get $date dayOfWeekInMonth] @@ -4105,6 +4161,7 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { [dict get $date2 julianDay]] dict set date julianDay [expr { $wd0 + 7 * $week }] return $date + } #---------------------------------------------------------------------- @@ -4127,8 +4184,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::IsGregorianLeapYear { date } { + switch -exact -- [dict get $date era] { - BCE { + BCE { set year [expr { 1 - [dict get $date year]}] } CE { @@ -4146,14 +4204,15 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { } else { return 1 } + } #---------------------------------------------------------------------- # # WeekdayOnOrBefore -- # -# Determine the nearest day of week (given by the 'weekday' parameter, -# Sunday==0) on or before a given Julian Day. +# Determine the nearest day of week (given by the 'weekday' +# parameter, Sunday==0) on or before a given Julian Day. # # Parameters: # weekday -- Day of the week @@ -4168,16 +4227,18 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { #---------------------------------------------------------------------- proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { + set k [expr { ( $weekday + 6 ) % 7 }] return [expr { $j - ( $j - $k ) % 7 }] + } #---------------------------------------------------------------------- # # BSearch -- # -# Service procedure that does binary search in several places inside the -# 'clock' command. +# Service procedure that does binary search in several places +# inside the 'clock' command. # # Parameters: # list - List of lists, sorted in ascending order by the @@ -4185,8 +4246,8 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { # key - Value to search for # # Results: -# Returns the index of the greatest element in $list that is less than -# or equal to $key. +# Returns the index of the greatest element in $list that is less +# than or equal to $key. # # Side effects: # None. @@ -4194,6 +4255,7 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { #---------------------------------------------------------------------- proc ::tcl::clock::BSearch { list key } { + if {[llength $list] == 0} { return -1 } @@ -4205,12 +4267,13 @@ proc ::tcl::clock::BSearch { list key } { set u [expr { [llength $list] - 1 }] while { $l < $u } { + # At this point, we know that # $k >= [lindex $list $l 0] # Either $u == [llength $list] or else $k < [lindex $list $u+1 0] # We find the midpoint of the interval {l,u} rounded UP, compare - # against it, and set l or u to maintain the invariant. Note that the - # interval shrinks at each step, guaranteeing convergence. + # against it, and set l or u to maintain the invariant. Note + # that the interval shrinks at each step, guaranteeing convergence. set m [expr { ( $l + $u + 1 ) / 2 }] if { $key >= [lindex $list $m 0] } { @@ -4254,14 +4317,15 @@ proc ::tcl::clock::BSearch { list key } { # order. # # Notes: -# It is possible that adding a number of months or years will adjust the -# day of the month as well. For instance, the time at one month after -# 31 January is either 28 or 29 February, because February has fewer -# than 31 days. +# It is possible that adding a number of months or years will adjust +# the day of the month as well. For instance, the time at +# one month after 31 January is either 28 or 29 February, because +# February has fewer than 31 days. # #---------------------------------------------------------------------- proc ::tcl::clock::add { clockval args } { + if { [llength $args] % 2 != 0 } { set cmdName "clock add" return -code error \ @@ -4280,10 +4344,15 @@ proc ::tcl::clock::add { clockval args } { set timezone [GetSystemTimeZone] foreach { a b } $args { + if { [string is integer -strict $a] } { + lappend offsets $a $b + } else { + switch -exact -- $a { + -g - -gm - -gmt { set gmt $b } @@ -4295,7 +4364,8 @@ proc ::tcl::clock::add { clockval args } { set timezone $b } default { - throw [list CLOCK badSwitch $a] \ + return -code error \ + -errorcode [list CLOCK badSwitch $a] \ "bad switch \"$a\",\ must be -gmt, -locale or -timezone" } @@ -4311,16 +4381,20 @@ proc ::tcl::clock::add { clockval args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($clockval) } } result] } { - return -code error "expected integer but got \"$clockval\"" + return -code error \ + "expected integer but got \"$clockval\"" } - if { ![string is boolean -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + if { ![string is boolean $gmt] } { + return -code error \ + "expected boolean value but got \"$gmt\"" + } else { + if { $gmt } { + set timezone :GMT + } } - EnterLocale $locale oldLocale - + EnterLocale $locale + set changeover [mc GREGORIAN_CHANGE_DATE] if {[catch {SetupTimeZone $timezone} retval opts]} { @@ -4328,25 +4402,29 @@ proc ::tcl::clock::add { clockval args } { return -options $opts $retval } - try { + set status [catch { + foreach { quantity unit } $offsets { + switch -exact -- $unit { + years - year { - set clockval [AddMonths [expr { 12 * $quantity }] \ - $clockval $timezone $changeover] + set clockval \ + [AddMonths [expr { 12 * $quantity }] \ + $clockval $timezone $changeover] } months - month { set clockval [AddMonths $quantity $clockval $timezone \ - $changeover] + $changeover] } weeks - week { set clockval [AddDays [expr { 7 * $quantity }] \ - $clockval $timezone $changeover] + $clockval $timezone $changeover] } days - day { set clockval [AddDays $quantity $clockval $timezone \ - $changeover] + $changeover] } hours - hour { @@ -4360,24 +4438,27 @@ proc ::tcl::clock::add { clockval args } { } default { - throw [list CLOCK badUnit $unit] \ - "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" + error "unknown unit \"$unit\", must be \ + years, months, weeks, days, hours, minutes or seconds" \ + "unknown unit \"$unit\", must be \ + years, months, weeks, days, hours, minutes or seconds" \ + [list CLOCK badUnit $unit] } } } - return $clockval - } trap CLOCK {result opts} { - # Conceal the innards of [clock] when it's an expected error - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + } result opts] + + # Restore the locale - if { [info exists oldLocale] } { - mclocale $oldLocale + if { $status == 1 } { + if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { + dict unset opts -errorinfo } + return -options $opts $result + } else { + return $clockval } + } #---------------------------------------------------------------------- @@ -4402,6 +4483,7 @@ proc ::tcl::clock::add { clockval args } { #---------------------------------------------------------------------- proc ::tcl::clock::AddMonths { months clockval timezone changeover } { + variable DaysInRomanMonthInCommonYear variable DaysInRomanMonthInLeapYear variable TZData @@ -4409,9 +4491,8 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # Convert the time to year, month, day, and fraction of day. set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] dict set date tzName $timezone # Add the requisite number of months @@ -4440,23 +4521,23 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { set date [GetJulianDayFromEraYearMonthDay \ $date[set date {}]\ $changeover] - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] return [dict get $date seconds] + } #---------------------------------------------------------------------- # # AddDays -- # -# Add a given number of days to a given clock value in a given time -# zone. +# Add a given number of days to a given clock value in a given +# time zone. # # Parameters: # days - Number of days to add (may be negative) @@ -4466,7 +4547,8 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # in the target locale. # # Results: -# Returns the new clock value as a number of seconds since the epoch. +# Returns the new clock value as a number of seconds since +# the epoch. # # Side effects: # None. @@ -4474,14 +4556,14 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AddDays { days clockval timezone changeover } { + variable TZData # Convert the time to Julian Day set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { - [dict get $date localSeconds] % 86400 - }] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] dict set date tzName $timezone # Add the requisite number of days @@ -4490,47 +4572,15 @@ proc ::tcl::clock::AddDays { days clockval timezone changeover } { # Reconvert to a number of seconds - dict set date localSeconds [expr { - -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] - }] + dict set date localSeconds \ + [expr { -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] return [dict get $date seconds] -} - -#---------------------------------------------------------------------- -# -# mc -- -# -# Wrapper around ::msgcat::mc that caches the result according to the -# locale. -# -# Parameters: -# Accepts the name of the message to retrieve. -# -# Results: -# Returns the message text. -# -# Side effects: -# Caches the message text. -# -# Notes: -# Only the single-argument version of [mc] is supported. -# -#---------------------------------------------------------------------- -proc ::tcl::clock::mc { name } { - variable McLoaded - set Locale [mclocale] - if { [dict exists $McLoaded $Locale $name] } { - return [dict get $McLoaded $Locale $name] - } - set val [::msgcat::mc $name] - dict set McLoaded $Locale $name $val - return $val } #---------------------------------------------------------------------- @@ -4551,9 +4601,9 @@ proc ::tcl::clock::mc { name } { #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { + variable FormatProc variable LocaleNumeralCache - variable McLoaded variable CachedSystemTimeZone variable TimeZoneBad @@ -4566,8 +4616,11 @@ proc ::tcl::clock::ClearCaches {} { catch {unset FormatProc} set LocaleNumeralCache {} - set McLoaded {} + # this removes many required keys and makes the module unusable + mcpackagelocale set "" + mcpackagelocale clear catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData + } diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index c35803f..92fb7f7 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -202,29 +202,27 @@ proc msgcat::mc {src args} { variable Msgs variable Loclist - variable PackageConfig set ns [uplevel 1 [list ::namespace current]] set loclist [PackagePreferences $ns] - while {$ns != ""} { + set nscur $ns + while {$nscur != ""} { foreach loc $loclist { - if {[dict exists $Msgs $ns $loc $src]} { - if {[llength $args] == 0} { - return [dict get $Msgs $ns $loc $src] - } else { - return [format [dict get $Msgs $ns $loc $src] {*}$args] - } + if {[dict exists $Msgs $nscur $loc $src]} { + return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\ + {*}$args] } } - set ns [namespace parent $ns] + set nscur [namespace parent $nscur] } # call package local or default unknown command set args [linsert $args 0 [lindex $loclist 0] $src] - if {[Invoke unknowncmd $args $ns result]} { - return $result + switch -exact -- [Invoke unknowncmd $args $ns result] { + 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } + 1 { return [DefaultUnknown {*}$args] } + default { return $result } } - return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } # msgcat::mcexists -- @@ -423,8 +421,8 @@ proc msgcat::mcloadedlocales {subcommand} { # Returns true, if a package locale is set # unset # Unset the package locale and activate the default locale. -# This may clear message catalog data and may load message catalog -# files +# This loads message catalog file which where missing in the package +# locale. # preferences # Return locale preference list valid for the package. # loaded @@ -518,18 +516,13 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} { if { ![dict exists $PackageConfig loclist $ns] } { return } # unset package locale - set loadedlocales [dict get $PackageConfig loadedlocales $ns] + set loadLocales [ListComplement\ + [dict get $PackageConfig loadedlocales $ns] $LoadedLocales] dict unset PackageConfig loadedlocales $ns dict unset PackageConfig loclist $ns - # Remove unwanted locales - foreach locale [dict keys [dict get $Msgs $ns]] { - if { $locale ni $LoadedLocales } { - dict unset Msgs $ns $locale - } - } # Add missing locales - Load $ns [ListComplement $loadedlocales $LoadedLocales] + Load $ns $loadLocales } default { return -code error "unknown subcommand \"$subcommand\": must be\ @@ -598,6 +591,9 @@ proc msgcat::mcforgetpackage {} { # unknowncmd # Use a package locale mcunknown procedure instead the global one. # The appended arguments are identical to mcunknown. +# A default unknown handler is used if set to the empty string. +# This consists in returning the key if no arguments are given. +# With given arguments, format is used to process the arguments. # # Arguments: # subcommand Operation on the package @@ -855,7 +851,11 @@ proc msgcat::Load {ns locales {callbackonly 0}} { # callback to. May be set to "" to discard the result. # # Results: -# Returns true if at least one command was called +# Possible values: +# - 0: no valid command registered +# - 1: registered command was the empty string +# - 2: registered command called, resultname is set +# If multiple commands are called, the maximum of all results is returned. proc msgcat::Invoke {index arglist {ns ""} {resultname ""}} { variable PackageConfig @@ -868,15 +868,19 @@ proc msgcat::Invoke {index arglist {ns ""} {resultname ""}} { } else { set packageList [list $ns] } - set called 0 + set ret 0 foreach ns $packageList { if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} { - set result [namespace inscope $ns\ - [dict get $PackageConfig $index $ns] {*}$arglist] - set called 1 + set cmd [dict get $PackageConfig $index $ns] + if {"" eq $cmd} { + if {$ret == 0} {set ret 1} + } else { + set result [namespace inscope $ns $cmd {*}$arglist] + set ret 2 + } } } - return $called + return $ret } # msgcat::mcset -- @@ -983,7 +987,8 @@ proc msgcat::mcflmset {pairs} { # msgcat::mcunknown -- # # This routine is called by msgcat::mc if a translation cannot -# be found for a string. This routine is intended to be replaced +# be found for a string and no unknowncmd is set for the current +# package. This routine is intended to be replaced # by an application specific routine for error reporting # purposes. The default behavior is to return the source string. # If additional args are specified, the format command will be used @@ -997,7 +1002,30 @@ proc msgcat::mcflmset {pairs} { # Results: # Returns the translated value. -proc msgcat::mcunknown {locale src args} { +proc msgcat::mcunknown {args} { + return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] +} + +# msgcat::DefaultUnknown -- +# +# This routine is called by msgcat::mc if a translation cannot +# be found for a string in the following circumstances: +# - Default global handler, if mcunknown is not redefined. +# - Per package handler, if the package sets unknowncmd to the empty +# string. +# It returna the source string if the argument list is empty. +# If additional args are specified, the format command will be used +# to work them into the traslated string. +# +# Arguments: +# locale (unused) The current locale. +# src The string to be translated. +# args Args to pass to the format command +# +# Results: +# Returns the translated value. + +proc msgcat::DefaultUnknown {locale src args} { if {[llength $args]} { return [format $src {*}$args] } else { -- cgit v0.12 From 8324cc91dbdb33bfd5799067e96c62769b8fb9c9 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 Nov 2012 20:40:55 +0000 Subject: Working towards a BCCed [next]. This version almost works, except for a problem with restoring the context namespace upon return (which produces very strange results!) --- generic/tclCompCmds.c | 29 +++++++++++++++++++++++++ generic/tclCompile.c | 4 ++++ generic/tclCompile.h | 5 ++++- generic/tclExecute.c | 59 +++++++++++++++++++++++++++++++++++++++++++++++++-- generic/tclInt.h | 4 ++++ generic/tclOO.c | 9 ++++---- generic/tclOOBasic.c | 12 +++++------ 7 files changed, 108 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5beb7bd..96bb9a4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5535,6 +5535,35 @@ IndexTailVarIfKnown( return localIndex; } +/* + * Compilations of commands relating to TclOO. + */ + +int +TclCompileObjectNextCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords > 255) { + return TCL_ERROR; + } + + for (i=0 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); + return TCL_OK; +} + int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee8511c..188b3f8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -484,9 +484,13 @@ InstructionDesc const tclInstructionTable[] = { * qualified version, or produces the empty string if no such command * exists. Never generates errors. * Stack: ... cmdName => ... fullCmdName */ + {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ + {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 08d59fd..e623e87 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -698,10 +698,13 @@ typedef struct ByteCode { #define INST_INFO_LEVEL_NUM 150 #define INST_INFO_LEVEL_ARGS 151 #define INST_RESOLVE_COMMAND 152 + +/* For compilation relating to TclOO */ #define INST_TCLOO_SELF 153 +#define INST_TCLOO_NEXT 154 /* The last opcode */ -#define LAST_INST_OPCODE 153 +#define LAST_INST_OPCODE 154 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1e24cb3..f6b99bf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4208,10 +4208,18 @@ TEBCresume( TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); } - case INST_TCLOO_SELF: { - CallFrame *framePtr = iPtr->varFramePtr; + + /* + * ----------------------------------------------------------------- + * Start of TclOO support instructions. + */ + + { + CallFrame *framePtr; CallContext *contextPtr; + case INST_TCLOO_SELF: + framePtr = iPtr->varFramePtr; if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE(("=> ERROR: no TclOO call context\n")); @@ -4230,9 +4238,56 @@ TEBCresume( objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + + case INST_TCLOO_NEXT: + opnd = TclGetUInt1AtPtr(pc+1); + framePtr = iPtr->varFramePtr; + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE(("%d => ERROR: no TclOO call context\n", opnd)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "next may only be called from inside a method", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + goto gotError; + } + contextPtr = framePtr->clientData; + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + + pcAdjustment = 2; + cleanup = opnd; + DECACHE_STACK_INFO(); + + /* + * BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG BUG + * + * Bug somewhere near here. The iPtr->varFramePtr must be updated as + * below, but TclOONextRestoreFrame (in tclOOBasic.c) seems to be + * unable to restore the frame upon return... + * + * If TclOONextRestoreFrame is wrong for use here (and it might be!) + * it should be copied to this file and adjusted afterwards. It is + * *correct* for its other uses. + */ + + iPtr->varFramePtr = framePtr->callerVarPtr; + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + NULL, NULL, NULL); + pc += pcAdjustment; + TEBC_YIELD(); + return TclNRObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, opnd, &OBJ_AT_DEPTH(opnd-1), 1); } /* + * End of TclOO support instructions. * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..549ada9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2804,6 +2804,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclOONextRestoreFrame; MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp, struct NRE_callback *tailcallPtr); @@ -3620,6 +3621,9 @@ MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclOO.c b/generic/tclOO.c index d6d2d6a..68ed766 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -437,10 +437,11 @@ InitFoundation( * ensemble. */ - Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, - NULL, NULL); + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", + NULL, TclOONextObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextCmd; + Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + NULL, TclOONextToObjCmd, NULL, NULL); cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 0676618..cd57063 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -25,8 +25,6 @@ static int FinalizeConstruction(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeEval(ClientData data[], Tcl_Interp *interp, int result); -static int RestoreFrame(ClientData data[], - Tcl_Interp *interp, int result); /* * ---------------------------------------------------------------------- @@ -805,7 +803,7 @@ TclOONextObjCmd( * that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, NULL,NULL,NULL); iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } @@ -874,8 +872,8 @@ TclOONextToObjCmd( * context. Note that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, - INT2PTR(contextPtr->index), NULL); + TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + contextPtr, INT2PTR(contextPtr->index), NULL); contextPtr->index = i-1; iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, @@ -904,8 +902,8 @@ TclOONextToObjCmd( return TCL_ERROR; } -static int -RestoreFrame( +int +TclOONextRestoreFrame( ClientData data[], Tcl_Interp *interp, int result) -- cgit v0.12 From 72901fb88ca266a88a78b0a34c4db3b3c386e367 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 16:50:06 +0000 Subject: Work on compilation of [string is]. Hit some problem edge cases with differences in strictness of edge cases that will force a rethink ([string is boolean] is significantly more strict than Tcl_GetBooleanFromObj). --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 190 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 + 3 files changed, 194 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index de32fce..0526325 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3306,7 +3306,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"is", StringIsCmd, NULL, NULL, NULL, 0}, + {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, NULL, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 57cb992..b9309ec 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -451,6 +451,196 @@ TclCompileStringIndexCmd( /* *---------------------------------------------------------------------- * + * TclCompileStringIsCmd -- + * + * Procedure called to compile the simplest and most common form of the + * "string is" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "string is" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringIsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int numWords = parsePtr->numWords; + enum IsType { + TypeBool, TypeBoolFalse, TypeBoolTrue, + TypeFloat, + TypeInteger, TypeNarrowInt, TypeWideInt, + TypeList /*, TypeDict */ + }; + enum IsType t; + JumpFixup jumpFixup; + int start, range; + int allowEmpty = 0; + + if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } +#define GotLiteral(tokenPtr,word) \ + ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] && \ + strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) + + if (GotLiteral(tokenPtr, "boolean")) { + t = TypeBool; + } else if (GotLiteral(tokenPtr, "double")) { + t = TypeFloat; + } else if (GotLiteral(tokenPtr, "entier")) { + t = TypeInteger; + } else if (GotLiteral(tokenPtr, "false")) { + t = TypeBoolFalse; + } else if (GotLiteral(tokenPtr, "integer")) { + t = TypeNarrowInt; + return TCL_ERROR; // Not yet implemented + } else if (GotLiteral(tokenPtr, "list")) { + t = TypeList; + } else if (GotLiteral(tokenPtr, "true")) { + t = TypeBoolTrue; + } else if (GotLiteral(tokenPtr, "wideinteger")) { + t = TypeWideInt; + return TCL_ERROR; // Not yet implemented + } else { + /* + * We don't handle character class checks in bytecode currently. + */ + + return TCL_ERROR; + } + if (numWords != 3 && numWords != 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + if (numWords == 3) { + allowEmpty = (t != TypeList); + } else { + if (!GotLiteral(tokenPtr, "-strict")) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } +#undef GotLiteral + + /* + * Push the word to check. + */ + + CompileWord(envPtr, tokenPtr, interp, numWords-1); + + /* + * Next, do the type check. First, we push a catch range; most of the + * type-check operations throw an exception on failure. + */ + + range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + start = 0; + TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + ExceptionRangeStarts(envPtr, range); + + /* + * Issue the type-check itself for the specific type. + */ + + switch (t) { + case TypeBool: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeBoolFalse: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + break; + case TypeBoolTrue: + TclEmitOpcode( INST_DUP, envPtr); + start = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + break; + case TypeFloat: + /* + * Careful! Preserve behavior of NaN which is a double (that is, true + * for the purposes of a type check) but most math ops fail on it. The + * key is that it is not == to itself (and is the only value which + * this is true for). + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_NEQ, envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 5, envPtr); + + /* + * Type check for all other double values. + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_UMINUS, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeInteger: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_BITNOT, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + case TypeNarrowInt: + Tcl_Panic("not yet implemented"); + case TypeWideInt: + Tcl_Panic("not yet implemented"); + case TypeList: + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + break; + } + + /* + * Based on whether the exception was thrown (or conditional branch taken, + * in the case of true/false checks), push the correct boolean value. This + * is also where we deal with what happens with empty values in non-strict + * mode. + */ + + ExceptionRangeEnds(envPtr, range); + TclEmitOpcode( INST_END_CATCH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "1", 1); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + ExceptionRangeTarget(envPtr, range, catchOffset); + if (start != 0) { + TclStoreInt1AtPtr(CurrentOffset(envPtr) - start, + envPtr->codeStart + start + 1); + } + TclEmitOpcode( INST_END_CATCH, envPtr); + if (allowEmpty) { + PushLiteral(envPtr, "", 0); + TclEmitOpcode( INST_STR_EQ, envPtr); + } else { + TclEmitOpcode( INST_POP, envPtr); + PushLiteral(envPtr, "0", 1); + } + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileStringMatchCmd -- * * Procedure called to compile the simplest and most common form of the diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fffa1f..e513a6e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3647,6 +3647,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From eaaed023dfb41a1d60c320fccf77c54204c4143e Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 Nov 2012 20:39:10 +0000 Subject: reorder to preserve main BC development branch sequence better --- generic/tclCompile.c | 10 +++++----- generic/tclCompile.h | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7036f6a..c390971 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -488,17 +488,17 @@ InstructionDesc const tclInstructionTable[] = { {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ - {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Push the identity of the current TclOO object (i.e., the name of - * its current public access command) on the stack. */ - {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, + {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, /* Push the class of the TclOO object named at the top of the stack * onto the stack. * Stack: ... object => ... class */ - {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, + {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, /* Push the namespace of the TclOO object named at the top of the * stack onto the stack. * Stack: ... object => ... namespace */ + {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cab517d..c860307 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -701,9 +701,9 @@ typedef struct ByteCode { /* For compilation relating to TclOO */ #define INST_TCLOO_SELF 153 -#define INST_TCLOO_NEXT 154 -#define INST_TCLOO_CLASS 155 -#define INST_TCLOO_NS 156 +#define INST_TCLOO_CLASS 154 +#define INST_TCLOO_NS 155 +#define INST_TCLOO_NEXT 156 /* The last opcode */ #define LAST_INST_OPCODE 156 -- cgit v0.12 From 2bcd186571b8f37c820add859b48f7046260d261 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2013 18:11:33 +0000 Subject: Revise TclNREvalObjv so that pre-resolution of the Command by a caller does not force suppression of exception handling. Let those be separable demands. Aim is to bring TclObjInvoke*() into the fold. --- generic/tclBasic.c | 17 ++++++++++++----- generic/tclNamesp.c | 2 +- generic/tclOOMethod.c | 2 +- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cde1cb9..22ec6b0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4188,10 +4188,6 @@ TclNREvalObjv( return result; } - if (cmdPtr) { - goto commandFound; - } - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4201,6 +4197,10 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (cmdPtr) { + goto commandFound; + } + /* * Configure evaluation context to match the requested flags. */ @@ -6620,9 +6620,11 @@ TclObjInvoke( Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } +#if 1 if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } +#endif cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6638,6 +6640,7 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); +#if 1 /* * Invoke the command function. */ @@ -6669,6 +6672,9 @@ TclObjInvoke( iPtr->flags &= ~ERR_ALREADY_LOGGED; } return result; +#else + +#endif } /* @@ -8243,7 +8249,8 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index aed623a..bdd5386 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1942,7 +1942,7 @@ InvokeImportedNRCmd( Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); - return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } static int diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..bd2744a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1429,7 +1429,7 @@ InvokeForwardMethod( contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, cmdPtr); } static int -- cgit v0.12 From 2816004e58ac0da7bde02b0159b164e54c04ab6a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 14:39:56 +0000 Subject: New internal routine TclNRInvoke() - NR-enabled path through the machinery behind invokehidden commands. --- generic/tclBasic.c | 77 +++++++++++++++++++++-------------------------------- generic/tclInt.h | 1 + generic/tclInterp.c | 7 ++++- 3 files changed, 37 insertions(+), 48 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 22ec6b0..82ce385 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -162,6 +162,7 @@ static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -6599,32 +6600,32 @@ TclObjInvoke( * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - if (interp == NULL) { return TCL_ERROR; } - if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } - if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} -#if 1 - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6640,41 +6641,23 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); -#if 1 - /* - * Invoke the command function. - */ - - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } - - /* - * If an error occurred, record information about what was being executed - * when the error occurred. - */ - - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); + + /* TODO: how to get re-resolution right */ + return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); +} - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; -#else - -#endif } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 1f939c0..70d6d02 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2739,6 +2739,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1a4297b..ac51d9d 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3052,7 +3052,12 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + if (interp == slaveInterp) { + Tcl_Release(slaveInterp); + return TclNRInvoke(NULL, slaveInterp, objc, objv); + } else { + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + } } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; -- cgit v0.12 From 87dc28ad0ec271d380acc051908672eb9a3adb43 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 19:36:37 +0000 Subject: More revisions let multi-interp test case work, but at cost of panics and segfaults. Pushing the NRE-envelope. --- generic/tclInterp.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac51d9d..e9ed790 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,6 +279,7 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); +static Tcl_NRPostProc NRPostInvokeHidden; /* *---------------------------------------------------------------------- @@ -3056,7 +3057,9 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + NULL, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } } else { Namespace *nsPtr, *dummy1, *dummy2; @@ -3076,6 +3079,19 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + + Tcl_TransferResult(slaveInterp, result, interp); + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From f54af08a171ccb68fa91d72cead431736ff19908 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 21:30:40 +0000 Subject: More progress. NR-enable [interp] and [$slave], completely with invokehidden subcommand. Test suite passes with no errors. --- generic/tclInterp.c | 51 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e9ed790..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,7 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -482,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -591,6 +597,16 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp; int index; static const char *const options[] = { @@ -2373,8 +2389,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2463,6 +2479,16 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { @@ -3053,14 +3079,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - if (interp == slaveInterp) { - Tcl_Release(slaveInterp); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } else { - Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, - NULL, NULL, NULL); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -3087,8 +3110,12 @@ NRPostInvokeHidden( int result) { Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; - Tcl_TransferResult(slaveInterp, result, interp); + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } Tcl_Release(slaveInterp); return result; } -- cgit v0.12 From 8aa1ab62e1501d779f07a7c0df073f852b5dce4d Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 11 Jun 2013 08:19:56 +0000 Subject: Move the disassembler to its own file. --- generic/tclCompile.c | 785 ---------------------------------- generic/tclCompile.h | 18 +- generic/tclDisassemble.c | 1045 ++++++++++++++++++++++++++++++++++++++++++++++ generic/tclProc.c | 258 +----------- unix/Makefile.in | 11 +- win/Makefile.in | 1 + win/makefile.bc | 5 + win/makefile.vc | 7 +- 8 files changed, 1091 insertions(+), 1039 deletions(-) create mode 100644 generic/tclDisassemble.c diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c361430..f93bbad 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -576,11 +576,6 @@ static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void StartExpanding(CompileEnv *envPtr); -static int FormatInstruction(ByteCode *codePtr, - const unsigned char *pc, Tcl_Obj *bufferObj); -static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); -static void UpdateStringOfInstName(Tcl_Obj *objPtr); /* * TIP #280: Helper for building the per-word line information of all compiled @@ -619,19 +614,6 @@ static const Tcl_ObjType substCodeType = { }; /* - * The structure below defines an instruction name Tcl object to allow - * reporting of inner contexts in errorstack without string allocation. - */ - -static const Tcl_ObjType tclInstNameType = { - "instname", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInstName, /* updateStringProc */ - NULL, /* setFromAnyProc */ -}; - -/* * Helper macros. */ @@ -4411,773 +4393,6 @@ EncodeCmdLocMap( return p; } -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * TclPrintByteCodeObj -- - * - * This procedure prints ("disassembles") the instructions of a bytecode - * object to stdout. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); - - fprintf(stdout, "\n%s", TclGetString(bufPtr)); - Tcl_DecrRefCount(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintInstruction -- - * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclPrintInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc) /* Points to first byte of instruction. */ -{ - Tcl_Obj *bufferObj; - int numBytes; - - TclNewObj(bufferObj); - numBytes = FormatInstruction(codePtr, pc, bufferObj); - fprintf(stdout, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintObject -- - * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - int length; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - Tcl_Obj *bufferObj; - - TclNewObj(bufferObj); - PrintSourceToObj(bufferObj, stringPtr, maxChars); - fprintf(outFile, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclDisassembleByteCodeObj -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object). No guarantees - * are made about the details of the contents of the result. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDisassembleByteCodeObj( - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - unsigned char *codeStart, *codeLimit, *pc; - unsigned char *codeDeltaNext, *codeLengthNext; - unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_Obj *bufferObj; - char ptrBuf1[20], ptrBuf2[20]; - - TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { - return bufferObj; /* Already freed. */ - } - - codeStart = codePtr->codeStart; - codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = codePtr->numCommands; - - /* - * Print header lines describing the ByteCode. - */ - - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); - Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, - iPtr->compileEpoch); - Tcl_AppendToObj(bufferObj, " Source ", -1); - PrintSourceToObj(bufferObj, codePtr->source, - TclMin(codePtr->numSrcBytes, 55)); - Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, - codePtr->numLitObjects, codePtr->numAuxDataItems, - codePtr->maxStackDepth, -#ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); -#endif /* TCL_COMPILE_STATS */ - - /* - * If the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. - */ - - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - - sprintf(ptrBuf1, "%p", procPtr); - Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, - numCompiledLocals); - if (numCompiledLocals > 0) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - - for (i = 0; i < numCompiledLocals; i++) { - Tcl_AppendPrintfToObj(bufferObj, - " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", - (localPtr->flags & VAR_ARRAY) ? ", array" : "", - (localPtr->flags & VAR_LINK) ? ", link" : "", - (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", - (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", - (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); - if (TclIsVarTemporary(localPtr)) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } else { - Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", - localPtr->name); - } - localPtr = localPtr->nextPtr; - } - } - } - - /* - * Print the ExceptionRange array. - */ - - if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { - ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - - Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); - break; - default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", - rangePtr->type); - } - } - } - - /* - * If there were no commands (e.g., an expression or an empty string was - * compiled), just print all instructions and return. - */ - - if (numCmds == 0) { - pc = codeStart; - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - return bufferObj; - } - - /* - * Print table showing the code offset, source offset, and source length - * for each command. These are encoded as a sequence of bytes. - */ - - Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); - codeDeltaNext = codePtr->codeDeltaStart; - codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if (numCmds > 0) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } - - /* - * Print each instruction. If the instruction corresponds to the start of - * a command, print the command's source. Note that we don't need the code - * length here. - */ - - codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - pc = codeStart; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); - PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); - Tcl_AppendToObj(bufferObj, "\n", -1); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ - - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - } - return bufferObj; -} - -/* - *---------------------------------------------------------------------- - * - * FormatInstruction -- - * - * Appends a representation of a bytecode instruction to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static int -FormatInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc, /* Points to first byte of instruction. */ - Tcl_Obj *bufferObj) /* Object to append instruction info to. */ -{ - Proc *procPtr = codePtr->procPtr; - unsigned char opCode = *pc; - register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; - unsigned char *codeStart = codePtr->codeStart; - unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; - CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[128]; /* Additional info to print after main opcode - * and immediates. */ - char *suffixSrc = NULL; - Tcl_Obj *suffixObj = NULL; - AuxData *auxPtr = NULL; - - suffixBuffer[0] = '\0'; - Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - break; - case OPERAND_AUX4: - case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { - sprintf(suffixBuffer+strlen(suffixBuffer), - ", %u cmds start here", opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; - } - break; - case OPERAND_IDX4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opnd >= -1) { - Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); - } else if (opnd == -2) { - Tcl_AppendPrintfToObj(bufferObj, "end "); - } else { - Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); - } - break; - case OPERAND_LVT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); - numBytes++; - goto printLVTindex; - case OPERAND_LVT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); - numBytes += 4; - printLVTindex: - if (localPtr != NULL) { - if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - (unsigned) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); - } else { - sprintf(suffixBuffer, "var "); - suffixSrc = localPtr->name; - } - } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); - break; - case OPERAND_NONE: - default: - break; - } - } - if (suffixObj) { - const char *bytes; - int length; - - Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); - PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); - } else if (suffixBuffer[0]) { - Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); - if (suffixSrc) { - PrintSourceToObj(bufferObj, suffixSrc, 40); - } - } - Tcl_AppendToObj(bufferObj, "\n", -1); - if (auxPtr && auxPtr->type->printProc) { - Tcl_AppendToObj(bufferObj, "\t\t[", -1); - auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, - pcOffset); - Tcl_AppendToObj(bufferObj, "]\n", -1); - } - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetInnerContext -- - * - * If possible, returns a list capturing the inner context. Otherwise - * return NULL. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclGetInnerContext( - Tcl_Interp *interp, - const unsigned char *pc, - Tcl_Obj **tosPtr) -{ - int objc = 0, off = 0; - Tcl_Obj *result; - Interp *iPtr = (Interp *) interp; - - switch (*pc) { - case INST_STR_LEN: - case INST_LNOT: - case INST_BITNOT: - case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - case INST_EXPAND_STKTOP: - case INST_EXPR_STK: - objc = 1; - break; - - case INST_LIST_IN: - case INST_LIST_NOT_IN: /* Basic list containment operators. */ - case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - case INST_STR_INDEX: - case INST_STR_MATCH: - case INST_REGEXP: - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_GT: - case INST_LE: - case INST_GE: - case INST_MOD: - case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - objc = 2; - break; - - case INST_RETURN_STK: - /* early pop. TODO: dig out opt dict too :/ */ - objc = 1; - break; - - case INST_SYNTAX: - case INST_RETURN_IMM: - objc = 2; - break; - - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); - break; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - break; - } - - result = iPtr->innerContext; - if (Tcl_IsShared(result)) { - Tcl_DecrRefCount(result); - iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); - Tcl_IncrRefCount(result); - } else { - int len; - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjLength(interp, result, &len); - Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); - } - Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); - - for (; objc>0 ; objc--) { - Tcl_Obj *objPtr; - - objPtr = tosPtr[1 - objc + off]; - if (!objPtr) { - Tcl_Panic("InnerContext: bad tos -- appending null object"); - } - if ((objPtr->refCount<=0) -#ifdef TCL_MEM_DEBUG - || (objPtr->refCount==0x61616161) -#endif - ) { - Tcl_Panic("InnerContext: bad tos -- appending freed object %p", - objPtr); - } - Tcl_ListObjAppendElement(NULL, result, objPtr); - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewInstNameObj -- - * - * Creates a new InstName Tcl_Obj based on the given instruction - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNewInstNameObj( - unsigned char inst) -{ - Tcl_Obj *objPtr = Tcl_NewObj(); - - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; - objPtr->bytes = NULL; - - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfInstName -- - * - * Update the string representation for an instruction name object. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfInstName( - Tcl_Obj *objPtr) -{ - int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; - - if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; - } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; - } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * - * PrintSourceToObj -- - * - * Appends a quoted representation of a string to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static void -PrintSourceToObj( - Tcl_Obj *appendObj, /* The object to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - register const char *p; - register int i = 0; - - if (stringPtr == NULL) { - Tcl_AppendToObj(appendObj, "\"\"", -1); - return; - } - - Tcl_AppendToObj(appendObj, "\"", -1); - p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { - case '"': - Tcl_AppendToObj(appendObj, "\\\"", -1); - continue; - case '\f': - Tcl_AppendToObj(appendObj, "\\f", -1); - continue; - case '\n': - Tcl_AppendToObj(appendObj, "\\n", -1); - continue; - case '\r': - Tcl_AppendToObj(appendObj, "\\r", -1); - continue; - case '\t': - Tcl_AppendToObj(appendObj, "\\t", -1); - continue; - case '\v': - Tcl_AppendToObj(appendObj, "\\v", -1); - continue; - default: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); - continue; - } - } - Tcl_AppendToObj(appendObj, "\"", -1); -} - #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..f28403d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -48,6 +48,13 @@ MODULE_SCOPE int tclTraceCompile; MODULE_SCOPE int tclTraceExec; #endif + +/* + * The type of lambda expressions. Note that every lambda will *always* have a + * string representation. + */ + +MODULE_SCOPE const Tcl_ObjType tclLambdaType; /* *------------------------------------------------------------------------ @@ -1099,12 +1106,15 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, - const char *script, - const char *command, int length, - const unsigned char *pc, Tcl_Obj **tosPtr); + const char *script, const char *command, + int length, const unsigned char *pc, + Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj **tosPtr); + const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); +MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, + register Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int isLambda); /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c new file mode 100644 index 0000000..bc84763 --- /dev/null +++ b/generic/tclDisassemble.c @@ -0,0 +1,1045 @@ +/* + * tclDisassemble.c -- + * + * This file contains procedures that disassemble bytecode into either + * human-readable or Tcl-processable forms. + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2013 Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include "tclOOInt.h" +#include + +/* + * Prototypes for procedures defined later in this file: + */ + +static int FormatInstruction(ByteCode *codePtr, + const unsigned char *pc, Tcl_Obj *bufferObj); +static void PrintSourceToObj(Tcl_Obj *appendObj, + const char *stringPtr, int maxChars); +static void UpdateStringOfInstName(Tcl_Obj *objPtr); + +/* + * The structure below defines an instruction name Tcl object to allow + * reporting of inner contexts in errorstack without string allocation. + */ + +static const Tcl_ObjType tclInstNameType = { + "instname", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInstName, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a bytecode + * object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj( + Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); + + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc) /* Points to first byte of instruction. */ +{ + Tcl_Obj *bufferObj; + int numBytes; + + TclNewObj(bufferObj); + numBytes = FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject( + FILE *outFile, /* The file to print the source to. */ + Tcl_Obj *objPtr, /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars) /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource( + FILE *outFile, /* The file to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + Tcl_Obj *bufferObj; + + TclNewObj(bufferObj); + PrintSourceToObj(bufferObj, stringPtr, maxChars); + fprintf(outFile, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclDisassembleByteCodeObj -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object). No guarantees + * are made about the details of the contents of the result. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDisassembleByteCodeObj( + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_Obj *bufferObj; + char ptrBuf1[20], ptrBuf2[20]; + + TclNewObj(bufferObj); + if (codePtr->refCount <= 0) { + return bufferObj; /* Already freed. */ + } + + codeStart = codePtr->codeStart; + codeLimit = codeStart + codePtr->numCodeBytes; + numCmds = codePtr->numCommands; + + /* + * Print header lines describing the ByteCode. + */ + + sprintf(ptrBuf1, "%p", codePtr); + sprintf(ptrBuf2, "%p", iPtr); + Tcl_AppendPrintfToObj(bufferObj, + "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", + ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + iPtr->compileEpoch); + Tcl_AppendToObj(bufferObj, " Source ", -1); + PrintSourceToObj(bufferObj, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + Tcl_AppendPrintfToObj(bufferObj, + "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->maxStackDepth, +#ifdef TCL_COMPILE_STATS + codePtr->numSrcBytes? + codePtr->structureSize/(float)codePtr->numSrcBytes : +#endif + 0.0); + +#ifdef TCL_COMPILE_STATS + Tcl_AppendPrintfToObj(bufferObj, + " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned long) codePtr->structureSize, + (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + codePtr->numCodeBytes, + (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), + (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); +#endif /* TCL_COMPILE_STATS */ + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + + sprintf(ptrBuf1, "%p", procPtr); + Tcl_AppendPrintfToObj(bufferObj, + " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", + ptrBuf1, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + + for (i = 0; i < numCompiledLocals; i++) { + Tcl_AppendPrintfToObj(bufferObj, + " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", + (localPtr->flags & VAR_ARRAY) ? ", array" : "", + (localPtr->flags & VAR_LINK) ? ", link" : "", + (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", + (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", + (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); + if (TclIsVarTemporary(localPtr)) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } else { + Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", + localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExceptRanges > 0) { + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + Tcl_AppendPrintfToObj(bufferObj, + " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + rangePtr->catchOffset); + break; + default: + Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string was + * compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + return bufferObj; + } + + /* + * Print table showing the code offset, source offset, and source length + * for each command. These are encoded as a sequence of bytes. + */ + + Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if (numCmds > 0) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } + + /* + * Print each instruction. If the instruction corresponds to the start of + * a command, print the command's source. Note that we don't need the code + * length here. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + + Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + Tcl_AppendToObj(bufferObj, "\n", -1); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + } + return bufferObj; +} + +/* + *---------------------------------------------------------------------- + * + * FormatInstruction -- + * + * Appends a representation of a bytecode instruction to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static int +FormatInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc, /* Points to first byte of instruction. */ + Tcl_Obj *bufferObj) /* Object to append instruction info to. */ +{ + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned pcOffset = pc - codeStart; + int opnd = 0, i, j, numBytes = 1; + int localCt = procPtr ? procPtr->numCompiledLocals : 0; + CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; + char suffixBuffer[128]; /* Additional info to print after main opcode + * and immediates. */ + char *suffixSrc = NULL; + Tcl_Obj *suffixObj = NULL; + AuxData *auxPtr = NULL; + + suffixBuffer[0] = '\0'; + Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 + || opCode == INST_JUMP_FALSE1) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 + || opCode == INST_JUMP_FALSE4) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } else if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + if (opCode == INST_PUSH1) { + suffixObj = codePtr->objArrayPtr[opnd]; + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_AUX4: + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_PUSH4) { + suffixObj = codePtr->objArrayPtr[opnd]; + } else if (opCode == INST_START_CMD && opnd != 1) { + sprintf(suffixBuffer+strlen(suffixBuffer), + ", %u cmds start here", opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + if (instDesc->opTypes[i] == OPERAND_AUX4) { + auxPtr = &codePtr->auxDataArrayPtr[opnd]; + } + break; + case OPERAND_IDX4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opnd >= -1) { + Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); + } else if (opnd == -2) { + Tcl_AppendPrintfToObj(bufferObj, "end "); + } else { + Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); + } + break; + case OPERAND_LVT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + goto printLVTindex; + case OPERAND_LVT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; + printLVTindex: + if (localPtr != NULL) { + if (opnd >= localCt) { + Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", + (unsigned) opnd, localCt); + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); + } else { + sprintf(suffixBuffer, "var "); + suffixSrc = localPtr->name; + } + } + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); + break; + case OPERAND_NONE: + default: + break; + } + } + if (suffixObj) { + const char *bytes; + int length; + + Tcl_AppendToObj(bufferObj, "\t# ", -1); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); + } else if (suffixBuffer[0]) { + Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); + if (suffixSrc) { + PrintSourceToObj(bufferObj, suffixSrc, 40); + } + } + Tcl_AppendToObj(bufferObj, "\n", -1); + if (auxPtr && auxPtr->type->printProc) { + Tcl_AppendToObj(bufferObj, "\t\t[", -1); + auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, + pcOffset); + Tcl_AppendToObj(bufferObj, "]\n", -1); + } + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInnerContext -- + * + * If possible, returns a list capturing the inner context. Otherwise + * return NULL. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetInnerContext( + Tcl_Interp *interp, + const unsigned char *pc, + Tcl_Obj **tosPtr) +{ + int objc = 0, off = 0; + Tcl_Obj *result; + Interp *iPtr = (Interp *) interp; + + switch (*pc) { + case INST_STR_LEN: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + case INST_EXPAND_STKTOP: + case INST_EXPR_STK: + objc = 1; + break; + + case INST_LIST_IN: + case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_STR_EQ: + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + case INST_STR_INDEX: + case INST_STR_MATCH: + case INST_REGEXP: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + objc = 2; + break; + + case INST_RETURN_STK: + /* early pop. TODO: dig out opt dict too :/ */ + objc = 1; + break; + + case INST_SYNTAX: + case INST_RETURN_IMM: + objc = 2; + break; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + break; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + break; + } + + result = iPtr->innerContext; + if (Tcl_IsShared(result)) { + Tcl_DecrRefCount(result); + iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); + Tcl_IncrRefCount(result); + } else { + int len; + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjLength(interp, result, &len); + Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); + } + Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); + + for (; objc>0 ; objc--) { + Tcl_Obj *objPtr; + + objPtr = tosPtr[1 - objc + off]; + if (!objPtr) { + Tcl_Panic("InnerContext: bad tos -- appending null object"); + } + if ((objPtr->refCount<=0) +#ifdef TCL_MEM_DEBUG + || (objPtr->refCount==0x61616161) +#endif + ) { + Tcl_Panic("InnerContext: bad tos -- appending freed object %p", + objPtr); + } + Tcl_ListObjAppendElement(NULL, result, objPtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewInstNameObj -- + * + * Creates a new InstName Tcl_Obj based on the given instruction + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewInstNameObj( + unsigned char inst) +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.longValue = (long) inst; + objPtr->bytes = NULL; + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInstName -- + * + * Update the string representation for an instruction name object. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInstName( + Tcl_Obj *objPtr) +{ + int inst = objPtr->internalRep.longValue; + char *s, buf[20]; + int len; + + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { + sprintf(buf, "inst_%d", inst); + s = buf; + } else { + s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + } + len = strlen(s); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, s, len + 1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * PrintSourceToObj -- + * + * Appends a quoted representation of a string to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static void +PrintSourceToObj( + Tcl_Obj *appendObj, /* The object to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + register const char *p; + register int i = 0; + + if (stringPtr == NULL) { + Tcl_AppendToObj(appendObj, "\"\"", -1); + return; + } + + Tcl_AppendToObj(appendObj, "\"", -1); + p = stringPtr; + for (; (*p != '\0') && (i < maxChars); p++, i++) { + switch (*p) { + case '"': + Tcl_AppendToObj(appendObj, "\\\"", -1); + continue; + case '\f': + Tcl_AppendToObj(appendObj, "\\f", -1); + continue; + case '\n': + Tcl_AppendToObj(appendObj, "\\n", -1); + continue; + case '\r': + Tcl_AppendToObj(appendObj, "\\r", -1); + continue; + case '\t': + Tcl_AppendToObj(appendObj, "\\t", -1); + continue; + case '\v': + Tcl_AppendToObj(appendObj, "\\v", -1); + continue; + default: + Tcl_AppendPrintfToObj(appendObj, "%c", *p); + continue; + } + } + Tcl_AppendToObj(appendObj, "\"", -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DisassembleObjCmd -- + * + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DisassembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const types[] = { + "lambda", "method", "objmethod", "proc", "script", NULL + }; + enum Types { + DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, + DISAS_SCRIPT + }; + int idx, result; + Tcl_Obj *codeObjPtr = NULL; + Proc *procPtr = NULL; + Tcl_HashEntry *hPtr; + Object *oPtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "type ..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); + return TCL_ERROR; + } + if (objv[2]->typePtr == &tclLambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = tclLambdaType.setFromAnyProc(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + } + case DISAS_PROC: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procName"); + return TCL_ERROR; + } + + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = TclPushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script"); + return TCL_ERROR; + } + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; + } + codeObjPtr = objv[2]; + break; + + case DISAS_CLASS_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of a class method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) objv[3]); + goto methodBody; + case DISAS_OBJECT_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of an instance method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->methodsPtr == NULL) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + + /* + * Compile (if necessary) and disassemble a method body. + */ + + methodBody: + if (hPtr == NULL) { + unknownMethod: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of method", + TclGetString(objv[3])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + default: + CLANG_ASSERT(0); + } + + /* + * Do the actual disassembly. + */ + + if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags + & TCL_BYTECODE_PRECOMPILED) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 18985a1..23d8e70 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,7 +15,6 @@ #include "tclInt.h" #include "tclCompile.h" -#include "tclOOInt.h" /* * Variables that are part of the [apply] command implementation and which @@ -41,9 +40,6 @@ static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); -static int PushProcCallFrame(ClientData clientData, - register Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int isLambda); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); @@ -95,7 +91,7 @@ static const Tcl_ObjType levelReferenceType = { * will execute within. */ -static const Tcl_ObjType lambdaType = { +const Tcl_ObjType tclLambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ @@ -221,7 +217,7 @@ Tcl_ProcObjCmd( * * This code is nearly identical to the #280 code in SetLambdaFromAny, see * this file. The differences are the different index of the body in the - * line array of the context, and the lamdba code requires some special + * line array of the context, and the lambda code requires some special * processing. Find a way to factor the common elements into a single * function. */ @@ -1571,7 +1567,7 @@ InitArgsAndLocals( /* *---------------------------------------------------------------------- * - * PushProcCallFrame -- + * TclPushProcCallFrame -- * * Compiles a proc body if necessary, then pushes a CallFrame suitable * for executing it. @@ -1586,8 +1582,8 @@ InitArgsAndLocals( *---------------------------------------------------------------------- */ -static int -PushProcCallFrame( +int +TclPushProcCallFrame( ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was @@ -1708,7 +1704,7 @@ TclNRInterpProc( * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { - int result = PushProcCallFrame(clientData, interp, objc, objv, + int result = TclPushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); if (result != TCL_OK) { @@ -2451,7 +2447,7 @@ DupLambdaInternalRep( procPtr->refCount++; Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &lambdaType; + copyPtr->typePtr = &tclLambdaType; } static void @@ -2488,7 +2484,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to lambdaType. + * length is not 2, then it cannot be converted to tclLambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2634,14 +2630,14 @@ SetLambdaFromAny( /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to lambdaType. + * conversion to tclLambdaType. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &lambdaType; + objPtr->typePtr = &tclLambdaType; return TCL_OK; } @@ -2692,12 +2688,12 @@ TclNRApplyObjCmd( } /* - * Set lambdaPtr, convert it to lambdaType in the current interp if + * Set lambdaPtr, convert it to tclLambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &lambdaType) { + if (lambdaPtr->typePtr == &tclLambdaType) { procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } @@ -2775,7 +2771,7 @@ TclNRApplyObjCmd( } extraPtr->isRootEnsemble = isRootEnsemble; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); @@ -2835,234 +2831,6 @@ MakeLambdaError( } /* - *---------------------------------------------------------------------- - * - * Tcl_DisassembleObjCmd -- - * - * Implementation of the "::tcl::unsupported::disassemble" command. This - * command is not documented, but will disassemble procedures, lambda - * terms and general scripts. Note that will compile terms if necessary - * in order to disassemble them. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const types[] = { - "lambda", "method", "objmethod", "proc", "script", NULL - }; - enum Types { - DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, - DISAS_SCRIPT - }; - int idx, result; - Tcl_Obj *codeObjPtr = NULL; - Proc *procPtr = NULL; - Tcl_HashEntry *hPtr; - Object *oPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "type ..."); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ - return TCL_ERROR; - } - - switch ((enum Types) idx) { - case DISAS_LAMBDA: { - Command cmd; - Tcl_Obj *nsObjPtr; - Tcl_Namespace *nsPtr; - - /* - * Compile (if uncompiled) and disassemble a lambda term. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); - return TCL_ERROR; - } - if (objv[2]->typePtr == &lambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = SetLambdaFromAny(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - - memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - cmd.nsPtr = (Namespace *) nsPtr; - procPtr->cmdPtr = &cmd; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - } - case DISAS_PROC: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procName"); - return TCL_ERROR; - } - - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - /* - * Compile (if uncompiled) and disassemble a procedure. - */ - - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - case DISAS_SCRIPT: - /* - * Compile and disassemble a script. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script"); - return TCL_ERROR; - } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { - return TCL_ERROR; - } - codeObjPtr = objv[2]; - break; - - case DISAS_CLASS_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of a class method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); - goto methodBody; - case DISAS_OBJECT_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of an instance method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->methodsPtr == NULL) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); - - /* - * Compile (if necessary) and disassemble a method body. - */ - - methodBody: - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - default: - CLANG_ASSERT(0); - } - - /* - * Do the actual disassembly. - */ - - if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not disassemble prebuilt bytecode", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/unix/Makefile.in b/unix/Makefile.in index 3e4a6f6..ab351ca 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -294,7 +294,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ - tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ + tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ tclEncoding.o tclEnsemble.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ @@ -402,6 +402,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclConfig.c \ $(GENERIC_DIR)/tclDate.c \ $(GENERIC_DIR)/tclDictObj.c \ + $(GENERIC_DIR)/tclDisassemble.c \ $(GENERIC_DIR)/tclEncoding.c \ $(GENERIC_DIR)/tclEnsemble.c \ $(GENERIC_DIR)/tclEnv.c \ @@ -1097,6 +1098,9 @@ tclConfig.o: $(GENERIC_DIR)/tclConfig.c tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDictObj.c +tclDisassemble.o: $(GENERIC_DIR)/tclDisassemble.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDisassemble.c + tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c @@ -1562,10 +1566,9 @@ tclUnixThrd.o: $(UNIX_DIR)/tclUnixThrd.c tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c +TCL_LOCATIONS=-DTCL_LIBRARY="\"${TCL_LIBRARY}\"" -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh - $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ - -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ - $(UNIX_DIR)/tclUnixInit.c + $(CC) -c $(CC_SWITCHES) $(TCL_LOCATIONS) $(UNIX_DIR)/tclUnixInit.c tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c diff --git a/win/Makefile.in b/win/Makefile.in index 18993fe..dc54d59 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -232,6 +232,7 @@ GENERIC_OBJS = \ tclConfig.$(OBJEXT) \ tclDate.$(OBJEXT) \ tclDictObj.$(OBJEXT) \ + tclDisassemble.$(OBJEXT) \ tclEncoding.$(OBJEXT) \ tclEnsemble.$(OBJEXT) \ tclEnv.$(OBJEXT) \ diff --git a/win/makefile.bc b/win/makefile.bc index 0b17cea..31a927e 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -207,6 +207,7 @@ TCLOBJS = \ $(TMPDIR)\tclConfig.obj \ $(TMPDIR)\tclDate.obj \ $(TMPDIR)\tclDictObj.obj \ + $(TMPDIR)\tclDisassemble.obj \ $(TMPDIR)\tclEncoding.obj \ $(TMPDIR)\tclEnsemble.obj \ $(TMPDIR)\tclEnv.obj \ @@ -587,3 +588,7 @@ clean: -@$(RM) $(TMPDIR)\*.exe -@$(RMDIR) $(OUTDIR) -@$(RMDIR) $(TMPDIR) + +# Local Variables: +# mode: makefile +# End: diff --git a/win/makefile.vc b/win/makefile.vc index cddb253..09a1135 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -1,4 +1,4 @@ -#------------------------------------------------------------- -*- makefile -*- +#------------------------------------------------------------- # makefile.vc -- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) @@ -281,6 +281,7 @@ COREOBJS = \ $(TMP_DIR)\tclConfig.obj \ $(TMP_DIR)\tclDate.obj \ $(TMP_DIR)\tclDictObj.obj \ + $(TMP_DIR)\tclDisassemble.obj \ $(TMP_DIR)\tclEncoding.obj \ $(TMP_DIR)\tclEnsemble.obj \ $(TMP_DIR)\tclEnv.obj \ @@ -1221,3 +1222,7 @@ realclean: hose hose: @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) + +# Local Variables: +# mode: makefile +# End: -- cgit v0.12 From 6d413075c9b687f662acd3d1f4fcef7e34f386e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 11 Jun 2013 21:33:33 +0000 Subject: Code-readable disassembler: tcl::unsupported::getbytecode --- generic/tclBasic.c | 4 +- generic/tclDisassemble.c | 231 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 232 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..f805a94 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -837,7 +837,9 @@ Tcl_CreateInterp(void) */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, NULL, NULL); + Tcl_DisassembleObjCmd, INT2PTR(0), NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode", + Tcl_DisassembleObjCmd, INT2PTR(1), NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index bc84763..2404b99 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -810,6 +810,229 @@ PrintSourceToObj( /* *---------------------------------------------------------------------- * + * DisassembleByteCodeAsDicts -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object) in a dictionary. + * No guarantees are made about the details of the contents of the + * result, but it is intended to be more readable than the old output + * format. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +DisassembleByteCodeAsDicts( + Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *description, *literals, *variables, *instructions, *inst; + Tcl_Obj *aux, *exn; + unsigned char *pc, *opnd; + int i, val; + + /* + * Get the literals from the bytecode. + */ + + literals = Tcl_NewObj(); + for (i=0 ; inumLitObjects ; i++) { + Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); + } + + /* + * Get the variables from the bytecode. + */ + + variables = Tcl_NewObj(); + if (codePtr->procPtr) { + int localCount = codePtr->procPtr->numCompiledLocals; + CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; + + for (i=0 ; inextPtr) { + Tcl_Obj *descriptor[2]; + + descriptor[0] = Tcl_NewObj(); + if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("scalar", -1)); + } + if (localPtr->flags & VAR_ARRAY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("array", -1)); + } + if (localPtr->flags & VAR_LINK) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("link", -1)); + } + if (localPtr->flags & VAR_ARGUMENT) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("arg", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("temp", -1)); + } + if (localPtr->flags & VAR_RESOLVED) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("resolved", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(1, descriptor)); + } else { + descriptor[1] = Tcl_NewStringObj(localPtr->name, -1); + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(2, descriptor)); + } + } + } + + /* + * Get the instructions from the bytecode. + */ + + instructions = Tcl_NewObj(); + for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ + const InstructionDesc *instDesc = &tclInstructionTable[*pc]; + + inst = Tcl_NewIntObj(pc - codePtr->codeStart); + Tcl_ListObjAppendElement(NULL, inst, + Tcl_NewStringObj(instDesc->name, -1)); + opnd = pc + 1; + for (i=0 ; inumOperands ; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + if (*pc == INST_JUMP1 || *pc == INST_JUMP_TRUE1 + || *pc == INST_JUMP_FALSE1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d (%d)", pc+val-codePtr->codeStart, val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } + break; + case OPERAND_INT4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + if (*pc == INST_JUMP4 || *pc == INST_JUMP_TRUE4 + || *pc == INST_JUMP_FALSE4 || *pc == INST_START_CMD) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d (%d)", pc+val-codePtr->codeStart, val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } + break; + case OPERAND_UINT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + case OPERAND_UINT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + case OPERAND_IDX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + if (val >= -1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } else if (val == -2) { + Tcl_ListObjAppendElement(NULL, inst, + Tcl_NewStringObj("end", -1)); + } else { + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("end-%d", -2-val)); + } + break; + case OPERAND_LVT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("%%%d", val)); + break; + case OPERAND_LVT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("%%%d", val)); + break; + case OPERAND_AUX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + case OPERAND_NONE: + Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); + } + } + Tcl_ListObjAppendElement(NULL, instructions, inst); + pc += instDesc->numBytes; + } + + /* + * Get the auxiliary data from the bytecode. + */ + + aux = Tcl_NewObj(); + for (i=0 ; inumAuxDataItems ; i++) { + AuxData *auxData = &codePtr->auxDataArrayPtr[i]; + Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); + + if (auxData->type->printProc) { + Tcl_AppendToObj(auxDesc, " ", -1); + auxData->type->printProc(auxData->clientData, auxDesc, codePtr,0); + } + Tcl_ListObjAppendElement(NULL, aux, auxDesc); + } + + /* + * Get the exception ranges from the bytecode. + */ + + exn = Tcl_NewObj(); + for (i=0 ; inumExceptRanges ; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d break %d continue %d", + "loop", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->breakOffset, rangePtr->continueOffset)); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d catch %d", + "catch", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->catchOffset)); + break; + } + } + + /* + * Build the overall result. + */ + + description = Tcl_NewObj(); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), + literals); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), + variables); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), + instructions); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); + return description; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DisassembleObjCmd -- * * Implementation of the "::tcl::unsupported::disassemble" command. This @@ -822,7 +1045,7 @@ PrintSourceToObj( int Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ + ClientData clientData, /* What type of operation. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1031,7 +1254,11 @@ Tcl_DisassembleObjCmd( "BYTECODE", NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + if (PTR2INT(clientData)) { + Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr)); + } else { + Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); + } return TCL_OK; } -- cgit v0.12 From c2d32899a05265e34d4c88dc6035c01f866dbfb0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 12 Jun 2013 08:55:15 +0000 Subject: Extract more of the info from the bytecode. --- generic/tclDisassemble.c | 65 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 60 insertions(+), 5 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 2404b99..0d2b844 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -827,8 +827,9 @@ DisassembleByteCodeAsDicts( { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *description, *literals, *variables, *instructions, *inst; - Tcl_Obj *aux, *exn; - unsigned char *pc, *opnd; + Tcl_Obj *aux, *exn, *commands; + unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; + int codeOffset, codeLength, sourceOffset, sourceLength; int i, val; /* @@ -896,7 +897,7 @@ DisassembleByteCodeAsDicts( for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ const InstructionDesc *instDesc = &tclInstructionTable[*pc]; - inst = Tcl_NewIntObj(pc - codePtr->codeStart); + inst = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj(instDesc->name, -1)); opnd = pc + 1; @@ -962,13 +963,15 @@ DisassembleByteCodeAsDicts( case OPERAND_AUX4: val = TclGetInt4AtPtr(opnd); opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + Tcl_ListObjAppendElement(NULL, inst, + Tcl_ObjPrintf("?%d", val)); break; case OPERAND_NONE: Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); } } - Tcl_ListObjAppendElement(NULL, instructions, inst); + Tcl_DictObjPut(NULL, instructions, + Tcl_NewIntObj(pc - codePtr->codeStart), inst); pc += instDesc->numBytes; } @@ -1015,6 +1018,48 @@ DisassembleByteCodeAsDicts( } /* + * Get the command information from the bytecode. + */ + + commands = Tcl_NewObj(); + codeOffPtr = codePtr->codeDeltaStart; + codeLenPtr = codePtr->codeLengthStart; + srcOffPtr = codePtr->srcDeltaStart; + srcLenPtr = codePtr->srcLengthStart; + codeOffset = sourceOffset = 0; +#define Decode(ptr) \ + ((TclGetUInt1AtPtr(ptr) == 0xFF) \ + ? ((ptr)+=5,TclGetInt4AtPtr((ptr)-4)) \ + : ((ptr)+=1,TclGetInt1AtPtr((ptr)-1))) + for (i=0 ; inumCommands ; i++) { + Tcl_Obj *cmd; + + codeOffset += Decode(codeOffPtr); + codeLength = Decode(codeLenPtr); + sourceOffset += Decode(srcOffPtr); + sourceLength = Decode(srcLenPtr); + cmd = Tcl_NewObj(); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), + Tcl_NewIntObj(codeOffset)); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), + Tcl_NewIntObj(codeOffset + codeLength - 1)); + /* + * Convert byte offsets to character offsets; important if multibyte + * characters are present in the source! + */ + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset + sourceLength - 1))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); + Tcl_ListObjAppendElement(NULL, commands, cmd); + } +#undef Decode + + /* * Build the overall result. */ @@ -1027,6 +1072,16 @@ DisassembleByteCodeAsDicts( Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), instructions); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), + commands); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), + Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), + Tcl_NewIntObj(codePtr->maxStackDepth)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), + Tcl_NewIntObj(codePtr->maxExceptDepth)); return description; } -- cgit v0.12 From 5318e02134708884c49c74419b36f34da125b85f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 13 Jun 2013 21:21:22 +0000 Subject: Improved rendering of some opcode arguments and auxdata. --- generic/tclCompCmds.c | 86 +++++++++++++++++++++++++++++++++++++++++++++--- generic/tclCompCmdsSZ.c | 32 +++++++++++++++++- generic/tclCompile.h | 10 ++++++ generic/tclDisassemble.c | 36 +++++++++++++++----- 4 files changed, 150 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..0740490 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -26,11 +26,17 @@ static void FreeDictUpdateInfo(ClientData clientData); static void PrintDictUpdateInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleDictUpdateInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static ClientData DupForeachInfo(ClientData clientData); static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleForeachInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -46,14 +52,16 @@ const AuxDataType tclForeachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ - PrintForeachInfo /* printProc */ + PrintForeachInfo, /* printProc */ + DisassembleForeachInfo /* disassembleProc */ }; const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo /* printProc */ + PrintDictUpdateInfo, /* printProc */ + DisassembleDictUpdateInfo /* disassembleProc */ }; /* @@ -2065,11 +2073,13 @@ TclCompileDictWithCmd( * DupDictUpdateInfo: a copy of the auxiliary data * FreeDictUpdateInfo: none * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * * Side effects: * DupDictUpdateInfo: allocates memory * FreeDictUpdateInfo: releases memory * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * *---------------------------------------------------------------------- */ @@ -2112,6 +2122,25 @@ PrintDictUpdateInfo( Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); } } + +static void +DisassembleDictUpdateInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + DictUpdateInfo *duiPtr = clientData; + int i; + Tcl_Obj *variables = Tcl_NewObj(); + + for (i=0 ; ilength ; i++) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewIntObj(duiPtr->varIndices[i])); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), + variables); +} /* *---------------------------------------------------------------------- @@ -2856,10 +2885,10 @@ FreeForeachInfo( /* *---------------------------------------------------------------------- * - * PrintForeachInfo -- + * PrintForeachInfo, DisassembleForeachInfo -- * - * Function to write a human-readable representation of a ForeachInfo - * structure to stdout for debugging. + * Functions to write a human-readable or script-readablerepresentation + * of a ForeachInfo structure to a Tcl_Obj for debugging. * * Results: * None. @@ -2909,6 +2938,53 @@ PrintForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +static void +DisassembleForeachInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + Tcl_Obj *objPtr, *innerPtr; + + /* + * Data stores. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; inumLists ; i++) { + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(infoPtr->firstValueTemp + i)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); + + /* + * Loop counter. + */ + + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), + Tcl_NewIntObj(infoPtr->loopCtTemp)); + + /* + * Assignment targets. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; inumLists ; i++) { + innerPtr = Tcl_NewObj(); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; jnumVars ; j++) { + Tcl_ListObjAppendElement(NULL, innerPtr, + Tcl_NewIntObj(varsPtr->varIndexes[j])); + } + Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..3639032 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -27,6 +27,9 @@ static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleJumptableInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -74,7 +77,8 @@ const AuxDataType tclJumptableInfoType = { "JumptableInfo", /* name */ DupJumptableInfo, /* dupProc */ FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo /* printProc */ + PrintJumptableInfo, /* printProc */ + DisassembleJumptableInfo /* disassembleProc */ }; /* @@ -1784,11 +1788,13 @@ IssueSwitchJumpTable( * DupJumptableInfo: a copy of the jump-table * FreeJumptableInfo: none * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * * Side effects: * DupJumptableInfo: allocates memory * FreeJumptableInfo: releases memory * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * *---------------------------------------------------------------------- */ @@ -1851,6 +1857,30 @@ PrintJumptableInfo( keyPtr, pcOffset + offset); } } + +static void +DisassembleJumptableInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register JumptableInfo *jtPtr = clientData; + Tcl_Obj *mapping = Tcl_NewObj(); + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + const char *keyPtr; + int offset; + + hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); + offset = PTR2INT(Tcl_GetHashValue(hPtr)); + Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), + Tcl_NewIntObj(offset)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f28403d..cf7b563 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -252,6 +252,16 @@ typedef struct AuxDataType { AuxDataPrintProc *printProc;/* Callback function to invoke when printing * the aux data as part of debugging. NULL * means that the data can't be printed. */ + AuxDataPrintProc *disassembleProc; + /* Callback function to invoke when doing a + * disassembly of the aux data (like the + * printProc, except that the output is + * intended to be script-readable). The + * appendObj argument should be filled in with + * a descriptive dictionary; it will start out + * with "name" mapped to the content of the + * name field. NULL means that the printProc + * should be used instead. */ } AuxDataType; /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 0d2b844..fa99eaf 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -928,24 +928,35 @@ DisassembleByteCodeAsDicts( case OPERAND_UINT1: val = TclGetUInt1AtPtr(opnd); opnd += 1; - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + if (*pc == INST_PUSH1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } break; case OPERAND_UINT4: val = TclGetUInt4AtPtr(opnd); opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + if (*pc == INST_PUSH4) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + } break; case OPERAND_IDX4: val = TclGetInt4AtPtr(opnd); opnd += 4; if (val >= -1) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".%d", val)); } else if (val == -2) { Tcl_ListObjAppendElement(NULL, inst, - Tcl_NewStringObj("end", -1)); + Tcl_NewStringObj(".end", -1)); } else { Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("end-%d", -2-val)); + Tcl_ObjPrintf(".end-%d", -2-val)); } break; case OPERAND_LVT1: @@ -984,9 +995,18 @@ DisassembleByteCodeAsDicts( AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); - if (auxData->type->printProc) { - Tcl_AppendToObj(auxDesc, " ", -1); - auxData->type->printProc(auxData->clientData, auxDesc, codePtr,0); + if (auxData->type->disassembleProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); + auxDesc = desc; + auxData->type->disassembleProc(auxData->clientData, auxDesc, + codePtr, 0); + } else if (auxData->type->printProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + auxData->type->printProc(auxData->clientData, desc, codePtr, 0); + Tcl_ListObjAppendElement(NULL, auxDesc, desc); } Tcl_ListObjAppendElement(NULL, aux, auxDesc); } -- cgit v0.12 From 60c48207275926d160a50ab91108f28ae7475040 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 17 Jun 2013 14:04:28 +0000 Subject: Remove extra scribblings not normally needed. Thanks to jdc for suggestion. --- generic/tclDisassemble.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index fa99eaf..7f0b11a 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -909,7 +909,7 @@ DisassembleByteCodeAsDicts( if (*pc == INST_JUMP1 || *pc == INST_JUMP_TRUE1 || *pc == INST_JUMP_FALSE1) { Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d (%d)", pc+val-codePtr->codeStart, val)); + "pc %d", pc+val-codePtr->codeStart)); } else { Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); } @@ -920,7 +920,7 @@ DisassembleByteCodeAsDicts( if (*pc == INST_JUMP4 || *pc == INST_JUMP_TRUE4 || *pc == INST_JUMP_FALSE4 || *pc == INST_START_CMD) { Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d (%d)", pc+val-codePtr->codeStart, val)); + "pc %d", pc+val-codePtr->codeStart)); } else { Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); } -- cgit v0.12 From 2859532759626d4782896f4c151bf58a668da85b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 20 Jun 2013 11:05:20 +0000 Subject: Properly encode more operand types to reduce the number of special cases in the disassembler. --- generic/tclCompile.c | 18 +++--- generic/tclCompile.h | 8 ++- generic/tclDisassemble.c | 164 ++++++++++++++++++++++++++--------------------- 3 files changed, 106 insertions(+), 84 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 65fc218..aee711c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -55,9 +55,9 @@ InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_UINT1}}, + {"push1", 2, +1, 1, {OPERAND_LIT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_UINT4}}, + {"push4", 5, +1, 1, {OPERAND_LIT4}}, /* Push object at ByteCode objArray[op4] */ {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ @@ -125,17 +125,17 @@ InstructionDesc const tclInstructionTable[] = { {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 0, 1, {OPERAND_INT1}}, + {"jump1", 2, 0, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_INT4}}, + {"jump4", 5, 0, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"lor", 1, -1, 0, {OPERAND_NONE}}, @@ -298,7 +298,7 @@ InstructionDesc const tclInstructionTable[] = { /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, + {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}}, /* Start of bytecoded command: op is the length of the cmd's code, op2 * is number of commands here */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cf7b563..1f42b05 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -822,8 +822,14 @@ typedef enum InstOperandType { * variable table. */ OPERAND_LVT4, /* Four byte unsigned index into the local * variable table. */ - OPERAND_AUX4 /* Four byte unsigned index into the aux data + OPERAND_AUX4, /* Four byte unsigned index into the aux data * table. */ + OPERAND_OFFSET1, /* One byte signed jump offset. */ + OPERAND_OFFSET4, /* Four byte signed jump offset. */ + OPERAND_LIT1, /* One byte unsigned index into table of + * literals. */ + OPERAND_LIT4 /* Four byte unsigned index into table of + * literals. */ } InstOperandType; typedef struct InstructionDesc { diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 7f0b11a..c7072ee 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -482,42 +482,52 @@ FormatInstruction( switch (instDesc->opTypes[i]) { case OPERAND_INT1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; - } Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; - case OPERAND_AUX4: case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { + if (opCode == INST_START_CMD) { sprintf(suffixBuffer+strlen(suffixBuffer), ", %u cmds start here", opnd); } Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; + break; + case OPERAND_OFFSET1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_OFFSET4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } else { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_LIT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_LIT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_AUX4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + auxPtr = &codePtr->auxDataArrayPtr[opnd]; break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; @@ -896,54 +906,67 @@ DisassembleByteCodeAsDicts( instructions = Tcl_NewObj(); for (pc=codePtr->codeStart; pccodeStart+codePtr->numCodeBytes;){ const InstructionDesc *instDesc = &tclInstructionTable[*pc]; + int address = pc - codePtr->codeStart; inst = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, inst, - Tcl_NewStringObj(instDesc->name, -1)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + instDesc->name, -1)); opnd = pc + 1; for (i=0 ; inumOperands ; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: val = TclGetInt1AtPtr(opnd); opnd += 1; - if (*pc == INST_JUMP1 || *pc == INST_JUMP_TRUE1 - || *pc == INST_JUMP_FALSE1) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d", pc+val-codePtr->codeStart)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } - break; + goto formatNumber; + case OPERAND_UINT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatNumber; case OPERAND_INT4: val = TclGetInt4AtPtr(opnd); opnd += 4; - if (*pc == INST_JUMP4 || *pc == INST_JUMP_TRUE4 - || *pc == INST_JUMP_FALSE4 || *pc == INST_START_CMD) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "pc %d", pc+val-codePtr->codeStart)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } + goto formatNumber; + case OPERAND_UINT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatNumber: + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); break; - case OPERAND_UINT1: + + case OPERAND_OFFSET1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + goto formatAddress; + case OPERAND_OFFSET4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + formatAddress: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d", address + val)); + break; + + case OPERAND_LIT1: val = TclGetUInt1AtPtr(opnd); opnd += 1; - if (*pc == INST_PUSH1) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "@%d", val)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } + goto formatLiteral; + case OPERAND_LIT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatLiteral: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); break; - case OPERAND_UINT4: + + case OPERAND_LVT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatVariable; + case OPERAND_LVT4: val = TclGetUInt4AtPtr(opnd); opnd += 4; - if (*pc == INST_PUSH4) { - Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( - "@%d", val)); - } else { - Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); - } + formatVariable: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "%%%d", val)); break; case OPERAND_IDX4: val = TclGetInt4AtPtr(opnd); @@ -952,37 +975,24 @@ DisassembleByteCodeAsDicts( Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( ".%d", val)); } else if (val == -2) { - Tcl_ListObjAppendElement(NULL, inst, - Tcl_NewStringObj(".end", -1)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + ".end", -1)); } else { - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf(".end-%d", -2-val)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".end-%d", -2-val)); } break; - case OPERAND_LVT1: - val = TclGetUInt1AtPtr(opnd); - opnd += 1; - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("%%%d", val)); - break; - case OPERAND_LVT4: - val = TclGetUInt4AtPtr(opnd); - opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("%%%d", val)); - break; case OPERAND_AUX4: val = TclGetInt4AtPtr(opnd); opnd += 4; - Tcl_ListObjAppendElement(NULL, inst, - Tcl_ObjPrintf("?%d", val)); + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "?%d", val)); break; case OPERAND_NONE: Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); } } - Tcl_DictObjPut(NULL, instructions, - Tcl_NewIntObj(pc - codePtr->codeStart), inst); + Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst); pc += instDesc->numBytes; } @@ -1039,18 +1049,23 @@ DisassembleByteCodeAsDicts( /* * Get the command information from the bytecode. + * + * The way these are encoded in the bytecode is non-trivial; the Decode + * macro (which updates its argument and returns the next decoded value) + * handles this so that the rest of the code does not. */ +#define Decode(ptr) \ + ((TclGetUInt1AtPtr(ptr) == 0xFF) \ + ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ + : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) + commands = Tcl_NewObj(); codeOffPtr = codePtr->codeDeltaStart; codeLenPtr = codePtr->codeLengthStart; srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; -#define Decode(ptr) \ - ((TclGetUInt1AtPtr(ptr) == 0xFF) \ - ? ((ptr)+=5,TclGetInt4AtPtr((ptr)-4)) \ - : ((ptr)+=1,TclGetInt1AtPtr((ptr)-1))) for (i=0 ; inumCommands ; i++) { Tcl_Obj *cmd; @@ -1077,6 +1092,7 @@ DisassembleByteCodeAsDicts( Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); Tcl_ListObjAppendElement(NULL, commands, cmd); } + #undef Decode /* -- cgit v0.12 From 654dc20b4af9b37825f7faffaa0e714dad02ce92 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 19:09:59 +0000 Subject: Possible improvement in light of [86ceb4e2b6]. --- library/tm.tcl | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/library/tm.tcl b/library/tm.tcl index d2af4f5..955e84d 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,6 +238,15 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } + if {[string length [package ifneeded $pkgname $pkgversion]]} { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + continue + } + # We have found a candidate, generate a "provide script" # for it, and remember it. Note that we are using ::list # to do this; locally [list] means something else without -- cgit v0.12 From 4837b605c2c1f2aa65ba75d080a2cb5076303abd Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 19 Aug 2013 16:34:10 +0000 Subject: Revise execution trace handling to take account of the new reality in Tcl 8.6 that callers can pre-resolve a cmdPtr for us. In that case a re-resolution in the form of another command name lookup isn't the right thing. --- generic/tclBasic.c | 51 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 37 insertions(+), 14 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 64563ee..8ac5781 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -148,7 +148,8 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Tcl_Obj *const objv[], Namespace *lookupNsPtr, + int weLookUp); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4098,6 +4099,7 @@ TclNREvalObjv( Namespace *lookupNsPtr = iPtr->lookupNsPtr; Command **cmdPtrPtr; NRE_callback *callbackPtr; + int weLookUp = (cmdPtr == NULL); iPtr->lookupNsPtr = NULL; @@ -4136,7 +4138,7 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (cmdPtr) { + if (!weLookUp) { goto commandFound; } @@ -4188,12 +4190,16 @@ TclNREvalObjv( result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr); + objc, objv), objc, objv, lookupNsPtr, weLookUp); if (result != TCL_OK) { return result; } - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + if (weLookUp) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + /* Is this right??? */ + return TCL_OK; } } @@ -4605,7 +4611,8 @@ TEOV_RunEnterTraces( Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Namespace *lookupNsPtr, + int weLookUp) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; @@ -4613,7 +4620,7 @@ TEOV_RunEnterTraces( int cmdEpoch = cmdPtr->cmdEpoch; int newEpoch; const char *command; - int length; + int length, deleted; Tcl_IncrRefCount(commandPtr); command = Tcl_GetStringFromObj(commandPtr, &length); @@ -4635,16 +4642,32 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } *cmdPtrPtr = cmdPtr; } -- cgit v0.12 From 7ef78ec33dcd4cf57d272e36d542a1c3c088495a Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 Aug 2013 09:35:50 +0000 Subject: define tests for this bug; no fix yet --- tests/oo.test | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index e0e0791..054bc46 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1839,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar a b"} +test oo-15.10 {variable binding must not bleed through oo::copy} -setup { + oo::class create FooClass + set result {} +} -body { + set obj1 [FooClass new] + oo::objdefine $obj1 { + variable var + method m {} { + set var foo + } + method get {} { + return $var + } + export eval + } + + $obj1 m + lappend result [$obj1 get] + set obj2 [oo::copy $obj1] + $obj2 eval { + set var bar + } + lappend result [$obj2 get] + $obj1 eval { + set var grill + } + lappend result [$obj1 get] [$obj2 get] +} -cleanup { + FooClass destroy +} -result {foo bar grill bar} test oo-16.1 {OO: object introspection} -body { info object -- cgit v0.12 From ff681132dc338549a4dc9fc52cdb33e2ea1ce37f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 Aug 2013 08:07:33 +0000 Subject: Correction to documentation --- doc/Method.3 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/Method.3 b/doc/Method.3 index 43b3609..2537d5e 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -172,8 +172,9 @@ typedef struct { .PP The \fIversion\fR field allows for future expansion of the structure, and should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The -\fIname\fR field provides a human-readable name for the type, and is reserved -for debugging. +\fIname\fR field provides a human-readable name for the type, and is the value +that is exposed via the \fBinfo class methodtype\fR and +\fBinfo object methodtype\fR Tcl commands. .PP The \fIcallProc\fR field gives a function that is called when the method is invoked; it must never be NULL. -- cgit v0.12 From 6bdb21a3a0573fcd1a3750d8f163f624d4e07a69 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 13:01:31 +0000 Subject: More coroutine tests. --- tests/coroutine.test | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index faa5a42..8a7fdf3 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -618,6 +618,21 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { coroutine demo lsort -command foo {a b} } -result {b a} +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} + +test coroutine-7.6 {Early yield crashes} { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} +} {} + # cleanup unset lambda -- cgit v0.12 From f8dfc60a3d144141a5b93a3b9326e162cbf5cdef Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 16:13:29 +0000 Subject: Remove assertion that is not true in some circumstances (--enable-dtrace). --- generic/tclExecute.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d066476..96004e2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8798,8 +8798,7 @@ TclGetSrcInfoForPc( &cfPtr->len, NULL, NULL); } - assert(cfPtr->cmd != NULL); - { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. -- cgit v0.12 From f12764701b58ae91225b1ce8311378ef722b7a00 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:21:15 +0000 Subject: Make Dispatch() the single point for calling a Tcl_ObjCmdProc, and attach the DTRACE machinery there (one place, not two). --- generic/tclBasic.c | 91 +++++++++++++++++++----------------------------------- 1 file changed, 32 insertions(+), 59 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c1032f9..5371f31 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4196,6 +4196,31 @@ TclNREvalObjv( } } + /* + * Fix the original callback to point to the now known cmdPtr. Insure that + * the Command struct lives until the command returns. + */ + + *cmdPtrPtr = cmdPtr; + cmdPtr->refCount++; + + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4216,41 +4241,17 @@ TclNREvalObjv( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } - if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) { + if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) + && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } #endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - - TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); - return TCL_OK; -} - -static int -Dispatch( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Command *cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - if (cmdPtr->nreProc) { - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + return objProc(clientData, interp, objc, objv); } int @@ -7981,39 +7982,11 @@ Tcl_NRCallObjProc( int objc, Tcl_Obj *const objv[]) { - int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; - - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr); + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* -- cgit v0.12 From b3792d779d73852a163fd142bbb96acc46c98153 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:34:30 +0000 Subject: compiler warning --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5371f31..fc449cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4220,9 +4220,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; +#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; -#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; -- cgit v0.12 From c3b526dd8620621345e9c5ff0f72234cff838715 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 05:59:48 +0000 Subject: Remove complications that no longer server any required purpose. --- generic/tclBasic.c | 20 +------------------- 1 file changed, 1 insertion(+), 19 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fc449cc..4d56f3a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4095,8 +4095,6 @@ TclNREvalObjv( Interp *iPtr = (Interp *) interp; int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - NRE_callback *callbackPtr; iPtr->lookupNsPtr = NULL; @@ -4111,13 +4109,10 @@ TclNREvalObjv( */ if (iPtr->deferredCallbacks) { - callbackPtr = iPtr->deferredCallbacks; iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - callbackPtr = TOP_CB(interp); } - cmdPtrPtr = (Command **) &(callbackPtr->data[0]); iPtr->numLevels++; result = TclInterpReady(interp); @@ -4196,14 +4191,6 @@ TclNREvalObjv( } } - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - TclNRAddCallback(interp, Dispatch, cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, cmdPtr->objClientData, INT2PTR(objc), objv); @@ -4297,13 +4284,8 @@ NRCommand( int result) { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); - } - ((Interp *)interp)->numLevels--; + iPtr->numLevels--; /* * If there is a tailcall, schedule it -- cgit v0.12 From 19fa970aea5f91d40bff7847090106710637151e Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 23 Aug 2013 13:08:15 +0000 Subject: fix NRE docs --- doc/NRE.3 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index 7ebeb39..a27a359 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,7 +8,8 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, +Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR @@ -207,7 +208,7 @@ is something like: .PP .CS int -\fITheCmdObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -225,7 +226,7 @@ int return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, clientData, TheCmdDeleteProc); + \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP To enable a command like this one for trampoline-based evaluation, @@ -255,8 +256,8 @@ int int objc, Tcl_Obj *const objv[]) { - return \fBTcl_NRCallObjProc\fR(interp, name, - \fITheCmdNRObjProc\fR, clientData, objc, objv); + return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, + clientData, objc, objv); } .CE .PP @@ -317,7 +318,7 @@ and the second is for use when there is already a trampoline in place. .PP .CS \fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData, + \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, TheCmdDeleteProc); .CE .SH "SEE ALSO" -- cgit v0.12 From 0ae283a82593a1994e6ed6e5c7577603fa7f72bb Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 16:23:47 +0000 Subject: Make sure all Tcl_NR*Eval*() routines do a schedule only. No errors raised. --- generic/tclBasic.c | 49 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4d56f3a..96d74c4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -157,6 +157,7 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; @@ -4093,16 +4094,8 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - - iPtr->lookupNsPtr = NULL; /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * * data[1] stores a marker for use by tailcalls; it will be set to 1 by * command redirectors (imports, alias, ensembles) so that tailcalls * finishes the source command and not just the target. @@ -4115,12 +4108,38 @@ TclNREvalObjv( } iPtr->numLevels++; - result = TclInterpReady(interp); + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} - if ((result != TCL_OK) || (objc == 0)) { - return result; +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; } + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + + iPtr->lookupNsPtr = NULL; + if (cmdPtr) { goto commandFound; } @@ -4164,11 +4183,6 @@ TclNREvalObjv( return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; - } - /* * Found a command! The real work begins now ... */ @@ -4207,9 +4221,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; -#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; @@ -4238,6 +4252,7 @@ Dispatch( } #endif /* USE_DTRACE */ + iPtr->cmdCount++; return objProc(clientData, interp, objc, objv); } -- cgit v0.12 From 8463ceabbba1e8736e395eda5a6f37428dc9c12c Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 24 Aug 2013 09:42:43 +0000 Subject: Unbreak doc; the apropos index entry *must* be one line. (This is an external constraint forced by the requirement to fit into the standard Unix manual system.) --- doc/NRE.3 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index a27a359..ce609e6 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,8 +8,7 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, -Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR -- cgit v0.12 From 9150a7225d0e28174587948bb96b6a11f70493dc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 18:11:53 +0000 Subject: Add test for Bug 2486550. --- tests/coroutine.test | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8a7fdf3..03c63ad 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -633,6 +633,15 @@ test coroutine-7.6 {Early yield crashes} { rename foo {} } {} +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok + # cleanup unset lambda -- cgit v0.12 From f300f251bd0a7b4aeb3ee2ad971c5b766629ed04 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:03:57 +0000 Subject: Inline TEOV_RunEnterTraces() so its interface can be redesigned. --- generic/tclBasic.c | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 71 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 82aa833..8407edb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,9 +4197,77 @@ EvalObjvCore( * necessary. */ - result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr, weLookUp); + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; + + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); + + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the traces + * so that the structure doesn't go away underneath our feet. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); + + if (cmdEpoch != newEpoch) { + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } + } + + if (cmdPtr && (traceCode == TCL_OK)) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } + result = traceCode; + if (result != TCL_OK) { return result; } -- cgit v0.12 From 7ddfa6aeb8f6eb66f66f4ae36b5ee59cc56524f6 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:06:08 +0000 Subject: Exceptions raised from enter traces take priority over re-resolution games. --- generic/tclBasic.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8407edb..172c698 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4230,6 +4230,11 @@ EvalObjvCore( deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } + if (cmdEpoch != newEpoch) { /* @@ -4255,7 +4260,7 @@ EvalObjvCore( } } - if (cmdPtr && (traceCode == TCL_OK)) { + if (cmdPtr) { /* * Command was found: push a record to schedule the leave traces. */ @@ -4266,11 +4271,6 @@ EvalObjvCore( } else { Tcl_DecrRefCount(commandPtr); } - result = traceCode; - - if (result != TCL_OK) { - return result; - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 9ba19b667f4232117cc4abd68576dead47e19c10 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:25:15 +0000 Subject: Tidy up indenting for clarity in refactoring. --- generic/tclBasic.c | 123 +++++++++++++++++++++++++++-------------------------- 1 file changed, 62 insertions(+), 61 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 172c698..3f579d1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,80 +4197,81 @@ EvalObjvCore( * necessary. */ - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; - Tcl_Obj *commandPtr = TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv); + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. - */ + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. + */ - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { + if (cmdEpoch != newEpoch) { /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. */ - if (deleted) { - cmdPtr = NULL; + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } } } - } - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ + if (cmdPtr) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 3aa655bce1d9e291450cc8bdfe5890058dcf1700 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 02:44:50 +0000 Subject: Clarfy and prettify influence of flag settings and command lookups. --- generic/tclBasic.c | 77 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 40 insertions(+), 37 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3f579d1..af747cd 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4121,13 +4121,21 @@ EvalObjvCore( Tcl_Interp *interp, int result) { - Command *cmdPtr = data[0]; + Command *cmdPtr = NULL, *preCmdPtr = data[0]; int flags = PTR2INT(data[1]); int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + */ + Namespace *lookupNsPtr = iPtr->lookupNsPtr; - int weLookUp = (cmdPtr == NULL); + iPtr->lookupNsPtr = NULL; if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; @@ -4141,8 +4149,6 @@ EvalObjvCore( return TCL_ERROR; } - iPtr->lookupNsPtr = NULL; - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4152,45 +4158,43 @@ EvalObjvCore( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (!weLookUp) { - goto commandFound; - } - - /* - * Configure evaluation context to match the requested flags. - */ - - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (preCmdPtr) { + cmdPtr = preCmdPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules + * Configure evaluation context to match the requested flags. */ - iPtr->ensembleRewrite.sourceObjs = NULL; - } + if (lookupNsPtr) { + /* + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - /* - * Lookup the command - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } + iPtr->ensembleRewrite.sourceObjs = NULL; - /* - * Found a command! The real work begins now ... - */ + if (flags & TCL_EVAL_GLOBAL) { + /* TODO: Check we do this whenever needed. */ + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } + } + + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + + } - commandFound: if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { /* * Call enter traces. They will schedule a call to the leave traces if @@ -4244,7 +4248,7 @@ EvalObjvCore( * If we got the trace command by looking up a command name, we * should just look it up again. */ - if (weLookUp) { + if (preCmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); } else { @@ -4273,7 +4277,7 @@ EvalObjvCore( } if (cmdPtr == NULL) { - if (weLookUp) { + if (preCmdPtr == NULL) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } /* Is this right??? */ @@ -4798,7 +4802,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; -- cgit v0.12 From 09922916778d4f09686dbdb94e6e4716ab9b8f59 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 18:05:07 +0000 Subject: Rework the re-resolution after enter traces machinery with cleaner separations and neater interfaces. --- generic/tclBasic.c | 214 +++++++++++++++++------------------------------------ 1 file changed, 69 insertions(+), 145 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index af747cd..bafb4c2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -147,8 +147,7 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr, - int weLookUp); + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4126,6 +4125,7 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + int enterTracesDone = 0; /* * Capture the namespace we should do command name resolution in, as @@ -4152,137 +4152,100 @@ EvalObjvCore( /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). + * TODO: Consider moving this up. */ if (!(flags & TCL_EVAL_NOERR)) { TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (preCmdPtr) { - cmdPtr = preCmdPtr; - } else { + /* + * Configure evaluation context to match the requested flags. + */ + if (lookupNsPtr) { /* - * Configure evaluation context to match the requested flags. + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * TODO: Is that a bug? */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - if (lookupNsPtr) { - /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. - */ - } else if (flags & TCL_EVAL_INVOKE) { - lookupNsPtr = iPtr->globalNsPtr; - } else { - - /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.sourceObjs = NULL; - if (flags & TCL_EVAL_GLOBAL) { - /* TODO: Check we do this whenever needed. */ - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; } + } + reresolve: + if (preCmdPtr) { + if (preCmdPtr->flags & CMD_IS_DELETED) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } + cmdPtr = preCmdPtr; + } else { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - } - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ - - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the - * traces so that the structure doesn't go away underneath our feet. - */ + if (!enterTracesDone) { - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); - - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } - - if (cmdEpoch != newEpoch) { + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. + * Send any exception from enter traces back as an exception + * raised by the traced command. */ - if (preCmdPtr == NULL) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; } - } - if (cmdPtr) { /* - * Command was found: push a record to schedule the leave traces. + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. */ - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } - - if (cmdPtr == NULL) { - if (preCmdPtr == NULL) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; } - /* Is this right??? */ - return TCL_OK; } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } TclNRAddCallback(interp, Dispatch, @@ -4672,26 +4635,19 @@ TEOV_RunEnterTraces( Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr, - int weLookUp) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; - - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4704,47 +4660,15 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } - } - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + return traceCode; } - - if (cmdPtr && (traceCode == TCL_OK)) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int -- cgit v0.12 From 012f63b012e81a2c53f6fef7a69cf7672d630a94 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Aug 2013 17:59:36 +0000 Subject: New internal eval flag value so that all TclNREvalObjv() callers that pre-resolve command names can choose whether or not TclNREvalObjv() should attempt to re-do the resolution from objv[0] when something goes wrong. --- generic/tclBasic.c | 75 ++++++++++++++++++++++++++++++++++-------------------- generic/tclInt.h | 1 + 2 files changed, 49 insertions(+), 27 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bafb4c2..884b5cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4125,18 +4125,18 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; - + /* - * Capture the namespace we should do command name resolution in, as - * instructed by our caller sneaking it in to us in a private interp - * field. Clear that field right away so we cannot possibly have its - * use leak where it should not. The sneaky message pass is done. + * Push records for task to be done on return, in INVERSE order. First, if + * needed, the exception handlers (as they should happen last). */ - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - iPtr->lookupNsPtr = NULL; - + if (!(flags & TCL_EVAL_NOERR)) { + TEOV_PushExceptionHandlers(interp, objc, objv, flags); + } + if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; } @@ -4150,25 +4150,23 @@ EvalObjvCore( } /* - * Push records for task to be done on return, in INVERSE order. First, if - * needed, the exception handlers (as they should happen last). - * TODO: Consider moving this up. - */ - - if (!(flags & TCL_EVAL_NOERR)) { - TEOV_PushExceptionHandlers(interp, objc, objv, flags); - } - - /* * Configure evaluation context to match the requested flags. */ - if (lookupNsPtr) { + if (iPtr->lookupNsPtr) { + /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. * TODO: Is that a bug? */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; } else if (flags & TCL_EVAL_INVOKE) { lookupNsPtr = iPtr->globalNsPtr; } else { @@ -4185,16 +4183,29 @@ EvalObjvCore( } } + /* + * Lookup the Command to dispatch. + */ + reresolve: + assert(cmdPtr == NULL); if (preCmdPtr) { - if (preCmdPtr->flags & CMD_IS_DELETED) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); return TCL_ERROR; } - cmdPtr = preCmdPtr; - } else { + } + if (cmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); @@ -4217,6 +4228,11 @@ EvalObjvCore( /* * Send any exception from enter traces back as an exception * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) */ if (code != TCL_OK) { @@ -6524,9 +6540,14 @@ TclNRInvoke( /* Avoid the exception-handling brain damage when numLevels == 0 . */ iPtr->numLevels++; Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); - - /* TODO: how to get re-resolution right */ - return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); + + /* + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). + */ + + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); } static int diff --git a/generic/tclInt.h b/generic/tclInt.h index e0e694f..380284f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2201,6 +2201,7 @@ typedef struct Interp { #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 +#define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: -- cgit v0.12 From 4874c0a0af9a15df8fc4b0994370a5d44fda5e44 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Aug 2013 20:08:04 +0000 Subject: Bump to 8.5.15 for release. --- ChangeLog | 13 +++++++++++++ README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- tools/tcl.wse.in | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 10 files changed, 23 insertions(+), 10 deletions(-) diff --git a/ChangeLog b/ChangeLog index 02472fe..032bfc7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2013-04-03 Don Porter + + * generic/tcl.h: Bump to 8.5.15 for release. + * library/init.tcl: + * tools/tcl.wse.in: + * unix/configure.in: + * unix/tcl.spec: + * win/configure.in: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-08-01 Harald Oehlmann * tclUnixNotify.c Tcl_InitNotifier: Bug [a0bc856dcd] diff --git a/README b/README index 0b3cf05..2ad171f 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.5.14 source distribution. + This is the Tcl 8.5.15 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index be5e697..eeff36e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -58,10 +58,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 5 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 14 +#define TCL_RELEASE_SERIAL 15 #define TCL_VERSION "8.5" -#define TCL_PATCH_LEVEL "8.5.14" +#define TCL_PATCH_LEVEL "8.5.15" /* * The following definitions set up the proper options for Windows compilers. diff --git a/library/init.tcl b/library/init.tcl index 071e6df..6b49fdf 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.5.14 +package require -exact Tcl 8.5.15 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index aac4413..e22b74a 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.5.14 + Disk Label=tcl8.5.15 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 diff --git a/unix/configure b/unix/configure index 217e5d4..d7bd53b 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 37de8be..b5a09dd 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index f7705fd..b61f4bf 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.5.14 +Version: 8.5.15 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index a1c0f6d..a0be0c4 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 diff --git a/win/configure.in b/win/configure.in index 33bf784..ea25843 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".14" +TCL_PATCH_LEVEL=".15" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 -- cgit v0.12 From d3fcbfab11472daf6c82fb0ecdecfa136a310cbe Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 14:16:05 +0000 Subject: changes --- changes | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 78ade0e..2221400 100644 --- a/changes +++ b/changes @@ -7735,6 +7735,49 @@ Many revisions to better support a Cygwin environment (nijtmans) --- Released 8.5.14, April 3, 2013 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2013-04-03 (bug fix)[3205320] outsmart gcc on powerpc detect stack direction + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.7.12 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-16 (bug fix)[3610404] crash in enter traces (found with TclOO) (porter) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-01 (bug fix)[2901998] inconsistent I/O buffering (ferrieux) + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-17 [string is space \u180e] => 1 (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +--- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- -- cgit v0.12 From f9d0c02e5020b9f06c1ba46c1e5820b35fe2ff8b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 14:31:06 +0000 Subject: fix date --- ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 032bfc7..fca182b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,4 @@ -2013-04-03 Don Porter +2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. * library/init.tcl: -- cgit v0.12 From 1d512f82013b5c80636c8522357aabe3b429f143 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 21:57:26 +0000 Subject: Bump to tcltest 2.3.6 to account for changes since Tcl 8.6.0 release. --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 4b0a9bc..60a9485 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d6e6487..c30d2e4 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.5 + variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 443e70d..505f7e0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -850,8 +850,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 47f3fdd..5109e7a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -650,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From a1f0dd74ffe8b407f725f089784f2dd51c2ab548 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 22:04:12 +0000 Subject: Bump version number to 8.6.1. --- ChangeLog | 12 ++++++++++++ README | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 9 files changed, 21 insertions(+), 9 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..13fd83b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2013-08-30 Don Porter + + * generic/tcl.h: Bump version number to 8.6.1. + * library/init.tcl: + * unix/configure.in: + * win/configure.in: + * unix/tcl.spec: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/README b/README index 8ecd7a9..7004bc5 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.0 source distribution. + This is the Tcl 8.6.1 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index a833218..1b120fb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 1 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.0" +#define TCL_PATCH_LEVEL "8.6.1" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index bedc06e..1ca6413 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.0 +package require -exact Tcl 8.6.1 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index 9b3c298..06ff7a4 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 1a9bb31..61ad30f 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index 27f7189..678222c 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.0 +Version: 8.6.1 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index fc453f8..e7c1329 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 373cfcc..6e1af50 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From 0576e11ae0dee27fb806110d84024c8aff28f941 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 1 Sep 2013 20:08:50 +0000 Subject: [b98fa55285]: Fix handling of whitespace at end of hex strings to decode. --- ChangeLog | 6 ++++++ generic/tclBinary.c | 43 +++++++++++++++++++++++-------------------- tests/binary.test | 28 ++++++++++++++++++++++++++++ 3 files changed, 57 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..e0b623b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2013-09-01 Donal Fellows + + * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that + whitespace at the end of a string don't cause the decoder to drop the + last decoded byte. + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 901237b..7625d39 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2386,29 +2386,32 @@ BinaryDecodeHex( while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { - if (data < dataend) { - c = *data++; - - if (!isxdigit((int) c)) { - if (strict || !isspace(c)) { - goto badChar; - } - i--; - continue; - } + if (data >= dataend) { value <<= 4; - c -= '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); + break; + } + + c = *data++; + if (!isxdigit((int) c)) { + if (strict || !isspace(c)) { + goto badChar; } - value |= (c & 0xf); - } else { - value <<= 4; - cut++; + i--; + continue; } + + value <<= 4; + c -= '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + } + if (i < 2) { + cut++; } *cursor++ = UCHAR(value); value = 0; diff --git a/tests/binary.test b/tests/binary.test index 4393245..d424837 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 -- cgit v0.12 From 5441277b9a31d73e4d91383584882c9303e5c758 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 2 Sep 2013 14:01:00 +0000 Subject: typo --- tests/zlib.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/zlib.test b/tests/zlib.test index c469eea..2ea185f 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict @@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { @@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict @@ -284,7 +284,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { @@ -300,7 +300,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -317,7 +317,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -334,7 +334,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -350,7 +350,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { -- cgit v0.12 From a01e0439ec88f4f83820d36da9ed018cc3b9ff00 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 17:59:42 +0000 Subject: [010f4162ef] First step of fix on stammering errorstack. errorstack fixed. errorinfo revision still under consideration. --- generic/tclBasic.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 884b5cc..e909a1a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4679,6 +4679,9 @@ TEOV_RunEnterTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } if (cmdEpoch != newEpoch) { @@ -4725,6 +4728,9 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } return result; -- cgit v0.12 From bfee748b41a556c2c213d22b99ce12b156acb1d8 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 18:47:07 +0000 Subject: Add test and improve errorInfo. --- generic/tclBasic.c | 22 ++++++++++++++++------ tests/error.test | 10 ++++++++++ 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e909a1a..a10a11a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4680,6 +4680,12 @@ TEOV_RunEnterTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } return traceCode; @@ -4702,12 +4708,10 @@ TEOV_RunLeaveTraces( Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; - + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); @@ -4717,7 +4721,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4729,10 +4732,17 @@ TEOV_RunLeaveTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } - return traceCode; + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } diff --git a/tests/error.test b/tests/error.test index 06f8eca..0de644c 100644 --- a/tests/error.test +++ b/tests/error.test @@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself -- cgit v0.12 From 9ff2704ae65ba49830398d9835492af591a7a0f3 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:04:06 +0000 Subject: some missed changes --- changes | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 2221400..ba7ce74 100644 --- a/changes +++ b/changes @@ -7768,7 +7768,9 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) -2013-06-27 (bug fix)[32afa6] corrected dirent64 check (griffin) +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) 2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) @@ -7778,6 +7780,8 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + 2013-08-15 Errors from execution traces become errors of the command (porter) --- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 05fa6e93c1f1952c259e23fca85fe2cae122ad47 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:04:30 +0000 Subject: update changes --- changes | 128 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 127 insertions(+), 1 deletion(-) diff --git a/changes b/changes index d3bbb43..0339919 100644 --- a/changes +++ b/changes @@ -8164,6 +8164,132 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- -2013-05-08 (bug fix)[3036566] Honor language packs on Vista+ to get initial locale (oehlmann) +2012-12-22 (bug fix)[3598150] DString to Tcl_Obj memleak (afredd) + +2012-12-27 (bug fix)[3598580] Tcl_ListObjReplace() refcount fix (nijtmans) + +2013-01-04 (bug fix) memleak in [format] compiler (fellows) + +2013-01-08 (bug fix)[3092089,3587096] [file normalize] on junction points + +2013-01-09 (bug fix)[3599395] status line processing (nijtmans) +2013-01-23 (bug fix)[2911139] repair async connection management (fellows) +=> http 2.8.6 + +2013-01-26 (bug fix)[3601804] Darwin segfault platformCPUID (nijtmans) + +2013-01-28 (enhancement) improve ensemble bytecode (fellows) + +2013-01-30 (enhancement) selected script code improvements (fradin) +=> tcltest 2.3.6 + +2013-01-30 (bug fix)[3599098] update to handle glibc banner changes (kupries) +=> platform 1.0.11 + +2013-01-31 (bug fix)[3598282] make install DESTDIR support (cassoff) + +2013-02-05 (bug fix)[3603434] [file normalize a:/] flaw in VFS (porter,griffin) + +2013-02-09 (bug fix)[3603695] $obj varname resolution rules (venable,fellows) + +2013-02-11 (bug fix)[3603553] zlib flushing errors (vampiera,fellows) + +2013-02-14 (bug fix)[3604576] msgcat use of Windows registry (oehlmann,nijtmans) +=> msgcat 1.5.1 + +2013-02-19 (bug fix)[2438181] report errors in trace handlers (yorick) + +2013-02-21 (bug fix)[3605447] unbreak [namespace export -clear] (porter) + +2013-02-23 (bug fix)[3599194] fallback IPv6 routines (afredd,max) + +2013-02-27 (bug fix)[3606139] stop crash in [regexp] (lane) + +2013-03-03 (bug fix)[3606258] major serial port update (english) + +2013-03-06 (bug fix)[3606683] [regexp (((((a)*)*)*)*)* {}] hangs +(grathwohl,lane,porter) + +2013-03-12 (enhancement) better build support for Debian arch (shadura) + +2013-03-19 (bug fix)[2893771] [file stat] on locked files (thoyts,nijtmans) + +2013-03-21 (bug fix)[2102614] [auto_mkindex] ensemble support (griffin) + +2013-03-27 Tcl_Zlib*() routines tolerate NULL interps (porter + +2013-04-04 (bug fix) Support URLs with query but no path (max) +=> http 2.8.7 + +2013-04-08 (bug fix)[3610026] regexp crash on color overflow (linnakangas) + +2013-04-29 (enhancement) [array set] compile improvement (fellows) + +2013-04-30 (enhancement) broaden glibc version detection (kupries) +=> platform 1.0.12 + +2013-05-06 (platform support) Cygwin64 (nijtmans) + +2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) + +2013-05-16 (platform support) mingw-4.0 (nijtmans) + +2013-05-19 (platform support) FreeBSD updates (cerutti) + +2013-05-20 (bug fix)[3613567] access error temp file creation (keene) + +2013-05-20 (bug fix)[3613569] temp file open fail can crash [load] (keene) + +2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) + +2013-05-28 (bug fix)[3036566] Use language packs (Vista+) locale (oehlmann) => msgcat 1.5.2 +2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter) + +2013-06-03 Restored lost performance appending to long strings (elby,porter) + +2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows) + +2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1f (nijtmans) + +2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans) + +2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang) + +2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin) + +2013-07-06 tzdata updated to Olson's tzdata2013d (kenny) + +2013-07-10 (bug fix)[86fb5e] [info frame] in compiled ensembles (porter) + +2013-07-18 (bug fix)[1c17fb] revisd syntax errorinfo that shows error (porter) + +2013-07-26 (bug fix)[6585b2] regexp {(\w).*?\1} abb (lane) + +2013-07-29 [string is space \u202f] => 1 (nijtmans) + +2013-08-01 [a0bc85] Limited support for fork with threads (for Rivet) (nijtmans) + +2013-08-01 (bug fix)[1905562] RE recursion limit increased to support +reported usage of large expressions (porter) + +2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows)2013-08-02 (bug fix)[9d6162] superclass slot empty crash (vdgoot,fellows) + +2013-08-03 (enhancement)[3611643] [auto_mkindex] support TclOO (fellows) + +2013-08-14 (bug fix)[a16752] Missing command delete callbacks (porter) + +2013-08-15 (bug fix)[3610404] reresolve traced forwards (porter) + +2013-08-15 Errors from execution traces become errors of the command (porter) + +2013-08-23 (bug fix)[8ff0cb9] Tcl_NR*Eval*() schedule only, as doc'd (porter) + +2013-08-29 (bug fix)[2486550] enable [interp invokehidden {} yield] (porter) + +2013-09-01 (bug fix)[b98fa55] [binary decode] fail on whitespace (reche,fellows) + +Many optmizations, improvements, and tightened stack management in bytecode. + +--- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- -- cgit v0.12 From 89d7d04dbc30e04aabc39806f925f51a835889fd Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:45:56 +0000 Subject: Favor timeline over ChangeLog --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index ba7ce74..c51ff93 100644 --- a/changes +++ b/changes @@ -7784,4 +7784,4 @@ Many revisions to better support a Cygwin environment (nijtmans) 2013-08-15 Errors from execution traces become errors of the command (porter) ---- Released 8.5.15, September 16, 2013 --- See ChangeLog for details --- +--- Released 8.5.15, September 16, 2013 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From 8bc4ab1c8756c1abaefa435e76d7a4ab6458bdb9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 16:47:50 +0000 Subject: Favor timeline over ChangeLog --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 0339919..5428c3e 100644 --- a/changes +++ b/changes @@ -8292,4 +8292,4 @@ reported usage of large expressions (porter) Many optmizations, improvements, and tightened stack management in bytecode. ---- Released 8.6.1, Septemer 18, 2013 --- See ChangeLog for details --- +--- Released 8.6.1, Septemer 18, 2013 --- http://core.tcl.tk/tcl/ for details -- cgit v0.12 From da0f4e22533c85ac4c70e6a45cb88cd87176cb66 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:07:41 +0000 Subject: typo --- pkgs/README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkgs/README b/pkgs/README index 01c6f43..868bd4f 100644 --- a/pkgs/README +++ b/pkgs/README @@ -39,7 +39,7 @@ needs to conform to the following conventions. distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. - Must respect the DIST_ROOT variable determing where to + Must respect the DIST_ROOT variable determining where to write the generated directory. Packages that are written to make use of the Tcl Extension Architecture (TEA) -- cgit v0.12 From a7ced6a9fdfa214f263e10b93d9d93b4f22d739d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 17:39:34 +0000 Subject: make dist --- unix/tclConfig.h.in | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 23d6026..e55dcd0 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -115,6 +115,9 @@ /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R +/* Compiler support for module scope symbols */ +#undef HAVE_HIDDEN + /* Do we have the intptr_t type? */ #undef HAVE_INTPTR_T @@ -343,9 +346,6 @@ /* Do we have ? */ #undef NO_VALUES_H -/* Compiler support for module scope symbols */ -#undef HAVE_HIDDEN - /* Do we have wait3() */ #undef NO_WAIT3 -- cgit v0.12 From ee5dada68d84581a9b0c3ac970c11b862f0eb186 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 3 Sep 2013 18:50:08 +0000 Subject: doc fix exposed by `make html` --- doc/file.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/file.n b/doc/file.n index 0b0ee9d..c117ee1 100644 --- a/doc/file.n +++ b/doc/file.n @@ -484,7 +484,7 @@ not the effective ones. .TP \fBWindows\fR\0\0\0\0 . -The \fbfile owned\fR subcommand currently always reports that the current user +The \fBfile owned\fR subcommand currently always reports that the current user is the owner of the file, without regard for what the operating system believes to be true, making an ownership test useless. This issue (#3613671) may be fixed in a future release of Tcl. -- cgit v0.12 From 5e237c28521e9a2146369913d30a10b2712b9fc2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Sep 2013 07:22:45 +0000 Subject: Fix 3 trivial (possible) errors, discovered by covertity.com --- generic/tclUtil.c | 3 +-- unix/tclUnixFCmd.c | 4 ++-- unix/tclUnixSock.c | 2 ++ 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e2474..b089132 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; - register int len; + register int len = 3; memcpy(buffer, "end", 4); - len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e27f78f..e270b6a 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -462,10 +462,10 @@ DoCopyFile( switch ((int) (statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { - char linkBuf[MAXPATHLEN]; + char linkBuf[MAXPATHLEN+1]; int length; - length = readlink(src, linkBuf, sizeof(linkBuf)); + length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 9c3d7eb..a6360c2 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1358,6 +1358,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (port == 0 && chosenport == 0) { @@ -1380,6 +1381,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (statePtr == NULL) { -- cgit v0.12 From f16149f5a641a30843d2bb4e3dd2734e50ecbe14 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 4 Sep 2013 09:36:22 +0000 Subject: [98c8b3ec12] Make test fail in less catastrophic manner. --- tests/zlib.test | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/zlib.test b/tests/zlib.test index 2ea185f..0712929 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -276,7 +276,10 @@ test zlib-8.10 {transformation and fconfigure} -setup { puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] - catch {zlib inflate $compressed} err opt + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] -- cgit v0.12 From 0a973a55fed4b9cba1558fc7c93d412665f7063c Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 4 Sep 2013 12:45:51 +0000 Subject: Cleaned up test command trying to make valgrind happy. --- generic/tclTest.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 96973d7..f121d0d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4408,8 +4408,26 @@ TestseterrorcodeCmd( Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } -- cgit v0.12 From 133768540d48de8f9bf0638fd9983178588bd18a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 12:45:11 +0000 Subject: Error in order of #include lines broke some windows builds. --- generic/tclParse.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index c5cb1d1..ee0d4c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -13,9 +13,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" #include "tclParse.h" +#include /* * The following table provides parsing information about each possible 8-bit -- cgit v0.12 From 4bba36ca59c3760f9e2a593e8135aa6f8352919e Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 15:47:29 +0000 Subject: Use ne instead of [string length] for less shimmer risk. --- library/tm.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/tm.tcl b/library/tm.tcl index 955e84d..55efda6 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,7 +238,7 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[string length [package ifneeded $pkgname $pkgversion]]} { + if {[package ifneeded $pkgname $pkgversion] ne {}} { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same -- cgit v0.12 From 76023565adb6e64816efbf4cae39b1c5d2ab725a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 17:21:41 +0000 Subject: Partial revert of [a16752c252] bug fix to stop crashes in buggy tclcompiler. --- generic/tclBasic.c | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 314b5fc..c3ab871 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1967,7 +1967,8 @@ Tcl_CreateCommand( * * Side effects: * If a command named "cmdName" already exists for interp, it is - * first deleted. Then the new command is created from the arguments. + * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2034,8 +2035,27 @@ Tcl_CreateObjCommand( if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); + /* Command already exists. */ + + /* + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + return (Tcl_Command) cmdPtr; + } + /* - * Command already exists; delete it. Be careful to preserve any + * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. -- cgit v0.12 From 991ddbd26c7c24de6598ff9fe61a1d9f13186548 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Sep 2013 10:21:37 +0000 Subject: [3611643] Stop polluting the global namespace. Refactor the index entry generation so it is done right, once. Handle more of [namespace ensemble create]'s behavior. --- library/auto.tcl | 69 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 43 insertions(+), 26 deletions(-) diff --git a/library/auto.tcl b/library/auto.tcl index 78c219e..02edcc4 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -513,6 +513,32 @@ proc auto_mkindex_parser::fullname {name} { return [string map [list \0 \$] $name] } +# auto_mkindex_parser::indexEntry -- +# +# Used by commands like "proc" within the auto_mkindex parser to add a +# correctly-quoted entry to the index. This is shared code so it is done +# *right*, in one place. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::indexEntry {name} { + variable index + variable scriptFile + + # We convert all metacharacters to their backslashed form, and pre-split + # the file name that we know about (which will be a proper list, and so + # correctly quoted). + + set name [string range [list \}[fullname $name]] 2 end] + set filenameParts [file split $scriptFile] + + append index [format \ + {set auto_index(%s) [list source [file join $dir %s]]%s} \ + $name $filenameParts \n] + return +} + if {[llength $::auto_mkindex_parser::initCommands]} { return } @@ -524,15 +550,7 @@ if {[llength $::auto_mkindex_parser::initCommands]} { # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { - variable index - variable scriptFile - # Do some fancy reformatting on the "source" call to handle platform - # differences with respect to pathnames. Use format just so that the - # command is a little easier to read (otherwise it'd be full of - # backslashed dollar signs, etc. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } # Conditionally add support for Tcl byte code files. There are some tricky @@ -559,14 +577,7 @@ auto_mkindex_parser::hook { # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { - variable index - variable scriptFile - # Do some nice reformatting of the "source" call, to get around - # path differences on different platforms. We use the format - # command just so that the code is a little easier to read. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } } } @@ -610,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} { variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] + catch { + set name [dict get [lrange $args 1 end] -command] + if {![string match ::* $name]} { + set name ::[join [lreverse $contextStack] ::]$name + } + regsub -all ::+ $name :: name + } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } @@ -619,15 +637,14 @@ auto_mkindex_parser::command namespace {op args} { # AUTO MKINDEX: oo::class create name ?definition? # Adds an entry to the auto index list for the given class name. -foreach cmd {oo::class class} { - auto_mkindex_parser::command $cmd {ecmd name {body ""}} { - if {$cmd eq "create"} { - variable index - variable scriptFile - append index [format "set %s \[list source \[%s]]\n" \ - [list auto_index([fullname $name])] \ - [list file join $dir {*}[file split $scriptFile]]] - } +auto_mkindex_parser::command oo::class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} +auto_mkindex_parser::command class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name } } -- cgit v0.12 From 6652de82ba5502a042b2be29a5cf7e04b73fca4b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 9 Sep 2013 13:34:06 +0000 Subject: [3609693] Must strip the internal representation of procedure-like methods in order to ensure that any bound references to instance variables are removed. --- generic/tclOOMethod.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 48 insertions(+), 2 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 81293c7..61215de 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1290,11 +1290,57 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr; + Tcl_Obj *bodyObj, *argsObj; + CompiledLocal *localPtr; + /* + * Copy the argument list. + */ + + argsObj = Tcl_NewObj(); + for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj = Tcl_NewObj(); + + Tcl_ListObjAppendElement(NULL, argObj, + Tcl_NewStringObj(localPtr->name, -1)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argsObj, argObj); + } + } + + /* + * Must strip the internal representation in order to ensure that any + * bound references to instance variables are removed. [Bug 3609693] + */ + + bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + TclFreeIntRep(bodyObj); + + /* + * Create the actual copy of the method record, manufacturing a new proc + * record. + */ + + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; - pm2Ptr->procPtr->refCount++; + Tcl_IncrRefCount(argsObj); + Tcl_IncrRefCount(bodyObj); + if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, + &pm2Ptr->procPtr) != TCL_OK) { + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + ckfree(pm2Ptr); + return TCL_ERROR; + } + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } -- cgit v0.12 From 28bb618586416fbb3c1c9a710cf88e5f8d924025 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 02:32:04 +0000 Subject: Stop the save and restore of currStackDepth. Just manage it correctly so it doesn't need correcting. --- generic/tclCompExpr.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 2a48117..c2b5a1a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int depth; /* Remember the currStackDepth of the - * CompileEnv here. */ int offset; /* Data used to compute jump lengths to pass * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether @@ -2269,7 +2267,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; convert = 1; break; case AND: @@ -2283,7 +2280,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2323,7 +2319,7 @@ CompileExprTree( CLANG_ASSERT(jumpPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); - envPtr->currStackDepth = jumpPtr->depth; + TclAdjustStackDepth(-1, envPtr); jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; @@ -2383,7 +2379,6 @@ CompileExprTree( TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->offset - jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2411,7 +2406,6 @@ CompileExprTree( TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, 127); convert = 0; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 7eabd2838a8210a30da24672179294fd7d8b1b0a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 04:49:08 +0000 Subject: Make use of the existing JumpFixup fields. Eliminate extra storage field 'offset' in JumpList that we don't require. --- generic/tclCompExpr.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index c2b5a1a..0021323 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,8 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int offset; /* Data used to compute jump lengths to pass - * to TclFixupForwardJump() */ int convert; /* Temporary storage used to compute whether * numeric conversion will be needed following * the operator we're compiling. */ @@ -2320,7 +2318,6 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); jumpPtr->convert = convert; convert = 1; break; @@ -2374,10 +2371,10 @@ CompileExprTree( if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->offset += 3; + jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->offset - jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; -- cgit v0.12 From 23bb5a2c20bd07e4b66ad4293fb927128e9e975b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 11 Sep 2013 05:07:52 +0000 Subject: Eliminate another surplus storage field. Make a(n ab)use of the existing JumpFixup fields instead. --- generic/tclCompExpr.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0021323..4afb069 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,9 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int convert; /* Temporary storage used to compute whether - * numeric conversion will be needed following - * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; @@ -2318,7 +2315,9 @@ CompileExprTree( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->next->jump); TclAdjustStackDepth(-1, envPtr); - jumpPtr->convert = convert; + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } convert = 1; break; case AND: @@ -2368,6 +2367,10 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + convert = 1; + } if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, (envPtr->codeNext - envPtr->codeStart) - jumpPtr->next->jump.codeOffset, 127)) { @@ -2375,7 +2378,6 @@ CompileExprTree( } TclFixupForwardJump(envPtr, &jumpPtr->jump, jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); - convert |= jumpPtr->convert; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From 3e3fe2606ae5233ae213b95fd91d7d05d2987659 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 17:42:36 +0000 Subject: Stop allocating JumpFixups for jumps that can never need any fixing up. --- generic/tclCompExpr.c | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 4afb069..7684c70 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2269,12 +2269,6 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; break; } } else if (nodePtr->mark == MARK_RIGHT) { @@ -2328,6 +2322,8 @@ CompileExprTree( break; } } else { + int pc1, pc2; + switch (nodePtr->lexeme) { case START: case QUESTION: @@ -2377,7 +2373,9 @@ CompileExprTree( jumpPtr->next->jump.codeOffset += 3; } TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 -jumpPtr->jump.codeOffset, 127); + jumpPtr->next->jump.codeOffset + 2 + - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2388,32 +2386,27 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &jumpPtr->next->jump); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->next->jump); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - jumpPtr->next->next->jump.codeOffset += 3; + pc2 += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, - 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); break; default: TclEmitOpcode(instruction[nodePtr->lexeme], envPtr); -- cgit v0.12 From c12159563db8f0ecce0a00351e1cb0caed2a7acc Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:21:20 +0000 Subject: Swap the two fixups used when compiling the ternary operator. Push them on the stack only when needed, and pop as soon as possible. --- generic/tclCompExpr.c | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 7684c70..106855a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2256,12 +2256,6 @@ CompileExprTree( switch (nodePtr->lexeme) { case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; convert = 1; break; case AND: @@ -2302,12 +2296,17 @@ CompileExprTree( break; } case QUESTION: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: - CLANG_ASSERT(jumpPtr); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->jump); + &jumpPtr->jump); TclAdjustStackDepth(-1, envPtr); if (convert) { jumpPtr->jump.jumpType = TCL_TRUE_JUMP; @@ -2322,7 +2321,7 @@ CompileExprTree( break; } } else { - int pc1, pc2; + int pc1, pc2, target; switch (nodePtr->lexeme) { case START: @@ -2364,21 +2363,21 @@ CompileExprTree( case COLON: CLANG_ASSERT(jumpPtr); if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { - jumpPtr->jump.jumpType = TCL_FALSE_JUMP; + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } - if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJump(envPtr, &jumpPtr->jump, (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->next->jump.codeOffset += 3; + - jumpPtr->jump.codeOffset, 127)) { + target += 3; } - TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->next->jump.codeOffset + 2 - - jumpPtr->jump.codeOffset, 127); - freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); -- cgit v0.12 From c34e729136c3608344a630fc086235da2a4092e4 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Sep 2013 19:27:48 +0000 Subject: Push fixup on the stack only when needed. --- generic/tclCompExpr.c | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 106855a..fce870b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2254,16 +2254,8 @@ CompileExprTree( if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - switch (nodePtr->lexeme) { - case QUESTION: + if (nodePtr->lexeme == QUESTION) { convert = 1; - break; - case AND: - case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; @@ -2314,10 +2306,12 @@ CompileExprTree( convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); - break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { -- cgit v0.12 From 6fef99593ff6cf1e4f504ca2a9ddabbd0d17c04b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Sep 2013 03:33:43 +0000 Subject: More macro use. --- generic/tclCompCmds.c | 8 ++------ generic/tclCompExpr.c | 4 +--- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8edb2d9..fdc8ec1 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2228,7 +2228,7 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ @@ -2309,13 +2309,9 @@ TclCompileForCmd( * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; - testCodeOffset += 3; } SetLineInformation(2); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fce870b..d8e4d9f 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2361,9 +2361,7 @@ CompileExprTree( convert = 1; } target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJump(envPtr, &jumpPtr->jump, - (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->jump.codeOffset, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { target += 3; } freePtr = jumpPtr; -- cgit v0.12 From 878be345c1b4a3fbf9756a06985a1b2ce306bd57 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 Sep 2013 10:53:32 +0000 Subject: Suggested fix for [bdd91c7e43]: tclsh crashes in [interp delete] --- generic/tclExecute.c | 1 + unix/configure | 0 2 files changed, 1 insertion(+) mode change 100755 => 100644 unix/configure diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8fb8e63..e657828 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2311,6 +2311,7 @@ TclExecuteByteCode( initCatchTop += moved; catchTop += moved; + bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); initTosPtr += moved; tosPtr += moved; esPtr = iPtr->execEnvPtr->execStackPtr; diff --git a/unix/configure b/unix/configure old mode 100755 new mode 100644 -- cgit v0.12 From 55f663e53f501bf7c9748ad6a70d148b41a83b2b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Sep 2013 16:02:11 +0000 Subject: Added note to ChangeLog pointing to the fossil timeline for better logging. --- ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/ChangeLog b/ChangeLog index fca182b..fd8c7c7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +A NOTE ON THE CHANGELOG: +Starting in early 2011, Tcl source code has been under the management of +fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline" +view of changes made that is superior in every way to a hand edited log file. +Because of this, many Tcl developers are now out of the habit of maintaining +this log file. You may still find useful things in it, but the Timeline is +a better first place to look now. +============================================================================ + 2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. -- cgit v0.12 From 92eea63a7df5071fddef9b89b9122a5761670908 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 07:07:03 +0000 Subject: [2152292] Corrected implementation of uuencoding. --- doc/binary.n | 17 +++---- generic/tclBinary.c | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++-- tests/binary.test | 43 ++++++++++++------ 3 files changed, 158 insertions(+), 27 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index a40afe6..95be36e 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -96,25 +96,22 @@ largely superseded by the \fBbase64\fR binary encoding. .RS .PP During encoding, the following options are supported: -'\" This is wrong! The uuencode format had more complexity than this! .TP \fB\-maxlen \fIlength\fR . Indicates that the output should be split into lines of no more than -\fIlength\fR characters. By default, lines are not split. -.TP -\fB\-wrapchar \fIcharacter\fR -. -Indicates that, when lines are split because of the \fB\-maxlen\fR option, -\fIcharacter\fR should be used to separate lines. By default, this is a -newline character, -.QW \en . +\fIlength\fR characters. By default, lines are split every 61 characters, and +this must be in the range 3 to 85 due to limitations in the encoding. .PP During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them. +Instructs the decoder to throw an error if it encounters whitespace +characters. Otherwise it ignores them. +.PP +Note that neither the encoder nor the decoder handle the header and footer of +the uuencode format. .RE .VE 8.6 .SH "BINARY FORMAT" diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 7625d39..71da309 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData, static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, +static int BinaryDecode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, +static int BinaryEncodeUu(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -140,7 +143,7 @@ static const EnsembleImplMap binaryMap[] = { }; static const EnsembleImplMap encodeMap[] = { { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, + { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; @@ -2439,7 +2442,7 @@ BinaryDecodeHex( * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement - * base64 and uuencode binary encodings. + * base64 binary encodings. * * Results: * Interp result set to an encoded byte array object @@ -2498,6 +2501,12 @@ BinaryEncode64( if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } + if (maxlen < 0) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); @@ -2550,6 +2559,114 @@ BinaryEncode64( /* *---------------------------------------------------------------------- * + * BinaryEncodeUu -- + * + * This implements the uuencode binary encoding. Input is broken into 6 + * bit chunks and a lookup table is used to turn these values into output + * characters. This differs from the generic code above in that line + * lengths are also encoded. + * + * Results: + * Interp result set to an encoded byte array object + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +BinaryEncodeUu( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *resultObj; + unsigned char *data, *start, *cursor; + int offset, count, rawLength, n, i, bits, index; + int lineLength = 61; + enum {OPT_MAXLEN}; + static const char *const optStrings[] = { "-maxlen", NULL }; + + if (objc < 2 || objc%2 != 0) { + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + return TCL_ERROR; + } + for (i = 1; i < objc-1; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case OPT_MAXLEN: + if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) { + return TCL_ERROR; + } + if (lineLength < 3 || lineLength > 85) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } + break; + } + } + + /* + * Allocate the buffer. This is a little bit too long, but is "good + * enough". + */ + + resultObj = Tcl_NewObj(); + offset = 0; + data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + rawLength = (lineLength - 1) * 3 / 4; + start = cursor = Tcl_SetByteArrayLength(resultObj, + (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + n = bits = 0; + + /* + * Encode the data. Each output line first has the length of raw data + * encoded by the output line described in it by one encoded byte, then + * the encoded data follows (encoding each 6 bits as one character). + * Encoded lines are always terminated by a newline. + */ + + while (offset < count) { + int lineLen = count - offset; + + if (lineLen > rawLength) { + lineLen = rawLength; + } + *cursor++ = UueDigits[lineLen]; + for (i=0 ; i 6 ; bits -= 6) { + *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f]; + } + } + if (bits > 0) { + n <<= 8; + *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; + bits = 0; + } + *cursor++ = '\n'; + } + + /* + * Fix the length of the output bytearray. + */ + + Tcl_SetByteArrayLength(resultObj, cursor-start); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * BinaryDecodeUu -- * * Decode a uuencoded string. diff --git a/tests/binary.test b/tests/binary.test index d424837..4b71b77 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2705,34 +2705,51 @@ test binary-74.1 {binary encode uuencode} -body { } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc -} -result {86)C} +} -result {#86)C +} test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] -} -result [string repeat 86)C 20] +} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 -} -result {````} +} -result {!`` +} test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 -} -result {````} +} -result "\"``` +" test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 -} -result {````} +} -result {#```` +} test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 -} -result {````````} -test binary-74.10 {binary encode uuencode} -body { - binary encode uuencode -maxlen 0 -wrapchar | abcabcabc -} -result {86)C86)C86)C} -test binary-74.11 {binary encode uuencode} -body { - binary encode uuencode -maxlen 1 -wrapchar | abcabcabc -} -result {8|6|)|C|8|6|)|C|8|6|)|C} +} -result {$`````` +} +test binary-74.10 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 30 -wrapchar | abcabcabc +} -result {bad option "-wrapchar": must be -maxlen} +test binary-74.11 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 1 abcabcabc +} -result {line length out of range} +test binary-74.12 {binary encode uuencode} -body { + binary encode uuencode -maxlen 3 abcabcabc +} -result {!80 +!8@ +!8P +!80 +!8@ +!8P +!80 +!8@ +!8P +} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode -- cgit v0.12 From b1264cd184de3c9ba370ae1e9cb9bb029b12872b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 14 Sep 2013 08:51:23 +0000 Subject: Add back -wrapchar option to "binary encode uuencode". --- doc/binary.n | 9 ++++++++- generic/tclBinary.c | 25 +++++++++++++++++++------ tests/binary.test | 17 ++++------------- 3 files changed, 31 insertions(+), 20 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..9f22fb1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -64,7 +64,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character, +newline character. .QW \en . .PP During decoding, the following options are supported: @@ -102,6 +102,13 @@ During encoding, the following options are supported: Indicates that the output should be split into lines of no more than \fIlength\fR characters. By default, lines are split every 61 characters, and this must be in the range 3 to 85 due to limitations in the encoding. +.TP +\fB\-wrapchar \fIcharacter\fR +. +Indicates that, when lines are split because of the \fB\-maxlen\fR option, +\fIcharacter\fR should be used to separate lines. By default, this is a +newline character. +.QW \en . .PP During decoding, the following options are supported: .TP diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..98a4d31 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2584,13 +2584,15 @@ BinaryEncodeUu( { Tcl_Obj *resultObj; unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, bits, index; + int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - enum {OPT_MAXLEN}; - static const char *const optStrings[] = { "-maxlen", NULL }; + const char *wrapchar = "\n"; + int wrapcharlen = 1; + enum {OPT_MAXLEN, OPT_WRAPCHAR }; + static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2610,6 +2612,15 @@ BinaryEncodeUu( return TCL_ERROR; } break; + case OPT_WRAPCHAR: + wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + if (wrapcharlen < 0 || wrapcharlen > 2) { + Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "WRAP_CHAR", NULL); + return TCL_ERROR; + } + break; } } @@ -2623,7 +2634,7 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + 1) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2652,7 +2663,9 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - *cursor++ = '\n'; + for (j=0; j Date: Sat, 14 Sep 2013 08:59:41 +0000 Subject: Hm, this check doesn't really add anything. --- generic/tclBinary.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 98a4d31..69f5baf 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2614,12 +2614,6 @@ BinaryEncodeUu( break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); - if (wrapcharlen < 0 || wrapcharlen > 2) { - Tcl_SetResult(interp, "wrap char out of range", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "WRAP_CHAR", NULL); - return TCL_ERROR; - } break; } } -- cgit v0.12 From 0f1f636a50239c2409172a34da5fa1b1f45bf9c4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 Sep 2013 18:25:45 +0000 Subject: And the decoder too. --- doc/binary.n | 2 +- generic/tclBinary.c | 104 +++++++++++++++++++++++++++++++++++++++++++--------- tests/binary.test | 41 +++++++++++---------- 3 files changed, 109 insertions(+), 38 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 95be36e..b301f4d 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -107,7 +107,7 @@ During decoding, the following options are supported: .TP \fB\-strict\fR . -Instructs the decoder to throw an error if it encounters whitespace +Instructs the decoder to throw an error if it encounters unexpected whitespace characters. Otherwise it ignores them. .PP Note that neither the encoder nor the decoder handle the header and footer of diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 71da309..c0dd926 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2690,8 +2690,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, count = 0, cut = 0, strict = 0; - char c; + int i, index, size, count = 0, strict = 0, lineLen; + unsigned char c; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2717,44 +2717,112 @@ BinaryDecodeUu( dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); + lineLen = -1; + + /* + * The decoding loop. First, we get the length of line (strictly, the + * number of data bytes we expect to generate from the line) we're + * processing this time round if it is not already known (i.e., when the + * lineLen variable is set to the magic value, -1). + */ + while (data < dataend) { char d[4] = {0, 0, 0, 0}; + if (lineLen < 0) { + c = *data++; + if (c < 32 || c > 96) { + if (strict || !isspace(c)) { + goto badUu; + } + i--; + continue; + } + lineLen = (c - 32) & 0x3f; + } + + /* + * Now we read a four-character grouping. + */ + for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; - if (c < 33 || c > 96) { - if (strict || !isspace(UCHAR(c))) { - goto badUu; + if (c < 32 || c > 96) { + if (strict) { + if (!isspace(c)) { + goto badUu; + } else if (c == '\n') { + goto shortUu; + } } i--; continue; } - } else { - cut++; } } - if (cut > 3) { - cut = 3; + + /* + * Translate that grouping into (up to) three binary bytes output. + */ + + if (lineLen > 0) { + *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) + | (((d[1] - 0x20) & 0x3f) >> 4); + if (--lineLen > 0) { + *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) + | (((d[2] - 0x20) & 0x3f) >> 2); + if (--lineLen > 0) { + *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) + | (((d[3] - 0x20) & 0x3f)); + lineLen--; + } + } + } + + /* + * If we've reached the end of the line, skip until we process a + * newline. + */ + + if (lineLen == 0 && data < dataend) { + lineLen = -1; + do { + c = *data++; + if (c == '\n') { + break; + } else if (c >= 32 && c <= 96) { + data--; + break; + } else if (strict || !isspace(c)) { + goto badUu; + } + } while (data < dataend); } - *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) - | (((d[1] - 0x20) & 0x3f) >> 4); - *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) - | (((d[2] - 0x20) & 0x3f) >> 2); - *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) - | (((d[3] - 0x20) & 0x3f)); } - if (cut > size) { - cut = size; + + /* + * Sanity check, clean up and finish. + */ + + if (lineLen > 0 && strict) { + goto shortUu; } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); + Tcl_SetByteArrayLength(resultObj, cursor - begin); Tcl_SetObjResult(interp, resultObj); return TCL_OK; + shortUu: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + TclDecrRefCount(resultObj); + return TCL_ERROR; + badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", c, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/tests/binary.test b/tests/binary.test index 4b71b77..607a070 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2755,72 +2755,75 @@ test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { - binary decode uuencode 86)C + binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} +test binary-75.3.1 {binary decode uuencode} -body { + binary decode uuencode `\n +} -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { - string length [binary decode uuencode {`}] + string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { - string length [binary decode uuencode {``}] + string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { - string length [binary decode uuencode {```}] + string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { - string length [binary decode uuencode {````}] + string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]|[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40} +} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} test binary-75.14 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { - set r [binary decode uuencode 8] + set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { - set r [binary decode uuencode 86] + set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { - set r [binary decode uuencode 86)] + set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { - set r [binary decode uuencode 86)C] + set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} +} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 -- cgit v0.12 From 826a355cc84e880287a692ccc1c3c48c915f5f4a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 16 Sep 2013 08:52:12 +0000 Subject: Be careful: separator needs to be bytes, not internal-encoded. --- generic/tclBinary.c | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 2053319..114984f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2586,13 +2586,15 @@ BinaryEncodeUu( unsigned char *data, *start, *cursor; int offset, count, rawLength, n, i, j, bits, index; int lineLength = 61; - const char *wrapchar = "\n"; - int wrapcharlen = 1; - enum {OPT_MAXLEN, OPT_WRAPCHAR }; + const unsigned char SingleNewline[] = { (unsigned char) '\n' }; + const unsigned char *wrapchar = SingleNewline; + int wrapcharlen = sizeof(SingleNewline); + enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; if (objc < 2 || objc%2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); + Tcl_WrongNumArgs(interp, 1, objv, + "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { @@ -2613,7 +2615,7 @@ BinaryEncodeUu( } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); break; } } @@ -2628,7 +2630,8 @@ BinaryEncodeUu( data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + wrapcharlen) * ((count + (rawLength - 1)) / rawLength)); + (lineLength + wrapcharlen) * + ((count + (rawLength - 1)) / rawLength)); n = bits = 0; /* @@ -2657,7 +2660,7 @@ BinaryEncodeUu( *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; bits = 0; } - for (j=0; j Date: Mon, 16 Sep 2013 09:03:50 +0000 Subject: Refactor to remove unused flexibility. --- generic/tclBinary.c | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 114984f..58583f4 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -142,9 +142,9 @@ static const EnsembleImplMap binaryMap[] = { { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, + { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, + { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { @@ -2315,7 +2315,6 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - const char *digits = clientData; int offset = 0, count = 0; if (objc != 2) { @@ -2327,8 +2326,8 @@ BinaryEncodeHex( data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { - *cursor++ = digits[((data[offset] >> 4) & 0x0f)]; - *cursor++ = digits[(data[offset] & 0x0f)]; + *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; + *cursor++ = HexDigits[(data[offset] & 0x0f)]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2478,7 +2477,6 @@ BinaryEncode64( { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; - const char *digits = clientData; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; @@ -2537,17 +2535,17 @@ BinaryEncode64( for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } - OUTPUT(digits[d[0] >> 2]); - OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); + OUTPUT(B64Digits[d[0] >> 2]); + OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset+1 < count) { - OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); + OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } if (offset+2 < count) { - OUTPUT(digits[d[2] & 0x3f]); + OUTPUT(B64Digits[d[2] & 0x3f]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } } } -- cgit v0.12 From e1a2deb52347de47b6357eb9662c56ee98a4d81e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 16 Sep 2013 23:18:54 +0000 Subject: [7b32d8d13b] Insert missing field initialization. --- generic/tclAssembly.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 100e9ef..946c729 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2617,6 +2617,7 @@ AllocBB( bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; + bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; -- cgit v0.12 From 081808cdabb46c7e3f387d766ca6e58cc5c9af8f Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:13:40 +0000 Subject: small improvements to the documentation --- doc/binary.n | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/doc/binary.n b/doc/binary.n index 0cdf465..cbbebd1 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -36,6 +36,13 @@ The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). .VE 8.6 +.PP +Note that other operations on binary data, such as taking a subsequence of it, +getting its length, or reinterpreting it as a string in some encoding, are +done by other Tcl commands (respectively \fBstring range\fR, +\fBstring length\fR and \fBencoding convertfrom\fR in the example cases). A +binary string in Tcl is merely one where all the characters it contains are in +the range \eu0000\-\eu00FF. .SH "BINARY ENCODE AND DECODE" .VS 8.6 .PP @@ -64,7 +71,7 @@ Indicates that the output should be split into lines of no more than . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -95,7 +102,8 @@ between Unix systems and on USENET, but is less common these days, having been largely superseded by the \fBbase64\fR binary encoding. .RS .PP -During encoding, the following options are supported: +During encoding, the following options are supported (though changing them may +produce files that other implementations of decoders cannot process): .TP \fB\-maxlen \fIlength\fR . @@ -107,7 +115,7 @@ this must be in the range 3 to 85 due to limitations in the encoding. . Indicates that, when lines are split because of the \fB\-maxlen\fR option, \fIcharacter\fR should be used to separate lines. By default, this is a -newline character. +newline character, .QW \en . .PP During decoding, the following options are supported: @@ -859,6 +867,7 @@ architectures, use their textual representation (as produced by .PP This is a procedure to write a Tcl string to a binary-encoded channel as UTF-8 data preceded by a length word: +.PP .CS proc \fIwriteString\fR {channel string} { set data [encoding convertto utf-8 $string] @@ -869,6 +878,7 @@ proc \fIwriteString\fR {channel string} { .PP This procedure reads a string from a channel that was written by the previously presented \fIwriteString\fR procedure: +.PP .CS proc \fIreadString\fR {channel} { if {![\fBbinary scan\fR [read $channel 4] I length]} { @@ -881,6 +891,7 @@ proc \fIreadString\fR {channel} { .PP This converts the contents of a file (named in the variable \fIfilename\fR) to base64 and prints them: +.PP .CS set f [open $filename rb] set data [read $f] @@ -888,9 +899,10 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tcl_platform(n) +encoding(n), format(n), scan(n), string(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: '\" mode: nroff +'\" fill-column: 78 '\" End: -- cgit v0.12 From 485b7e865a78e8d32056d25dc181e4b19e07be0c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 17 Sep 2013 09:20:58 +0000 Subject: ChangeLog entry --- ChangeLog | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/ChangeLog b/ChangeLog index 8e1a8b9..eaa5fc8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2013-09-17 Donal Fellows + + * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: + Corrected implementation of the core of uuencode handling so that the + line length processing is correctly applied. + ***POTENTIAL INCOMPATIBILITY*** + Existing code that was using the old versions and working around the + limitations will now need to do far less. The -maxlen option now has + strict limits on the range of supported lengths; this is a limitation + of the format itself. + 2013-09-09 Donal Fellows * generic/tclOOMethod.c (CloneProcedureMethod): [Bug 3609693]: Strip -- cgit v0.12 From 868b8031fd65e9786ac1484f3fe1261c176ad5c0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 18 Sep 2013 12:32:26 +0000 Subject: Bump TclOO version to 1.0.1 --- ChangeLog | 25 +++++++++++++++---------- generic/tclOO.h | 2 +- generic/tclOOBasic.c | 2 +- generic/tclOODefineCmds.c | 2 +- tests/oo.test | 4 ++-- tests/ooNext2.test | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 8 files changed, 23 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index eaa5fc8..3dc8c5e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ -2013-09-17 Donal Fellows +2013-09-18 Donal Fellows + + Bump TclOO version to 1.0.1 for release. + +2013-09-17 Donal Fellows * generic/tclBinary.c (BinaryEncodeUu, BinaryDecodeUu): [Bug 2152292]: Corrected implementation of the core of uuencode handling so that the @@ -59,12 +63,13 @@ 2013-06-27 Jan Nijtmans - * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized - * generic/tclMain.c: encodings. + * generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs + * generic/tclMain.c: initialized encodings. 2013-06-18 Jan Nijtmans - * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue. + * generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread + issue. 2013-06-17 Jan Nijtmans @@ -176,10 +181,10 @@ * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit * generic/tclDecls.h: "long" type. Binary compatibility with win64 - requires that all stub entries use 32-bit long's, therefore the - need for various wrapper functions/macros. For Tcl 9 a better - solution is needed, but that cannot be done without introducing - binary incompatibility. + requires that all stub entries use 32-bit long's, therefore the need + for various wrapper functions/macros. For Tcl 9 a better solution is + needed, but that cannot be done without introducing binary + incompatibility. 2013-04-30 Andreas Kupries @@ -197,8 +202,8 @@ * generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj and Tcl_SetBooleanObj as macros using Tcl_NewIntObj, Tcl_DbNewLongObj - and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, - it only eliminates code duplication. + and Tcl_SetIntObj. Starting with Tcl 8.5, this is exactly the same, it + only eliminates code duplication. * generic/tclInt.h: Eliminate use of NO_WIDE_TYPE everywhere: It's exactly the same as TCL_WIDE_INT_IS_LONG diff --git a/generic/tclOO.h b/generic/tclOO.h index cf253b1..d5ab8a0 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -39,7 +39,7 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0" +#define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index aba06a5..853e2ec 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f0983cc..5a6c0ad 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2012 by Donal K. Fellows + * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/oo.test b/tests/oo.test index 054bc46..37bbadb 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2012 Donal K. Fellows +# Copyright (c) 2006-2013 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 TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index d77e8d1..a47aa91 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 721825b..08cc4c5 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=1.0 +TCLOO_VERSION=1.0.1 -- cgit v0.12 From a57f75c197b1d3371c96802a894b9a85d84f2632 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:03:57 +0000 Subject: [3487626] Backport fix for knownBug test dict-23.2. --- generic/tclCompCmds.c | 7 +++++++ tests/dict.test | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b6e9527..f96470d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -6149,6 +6149,7 @@ TclCompileEnsemble( Tcl_Parse synthetic; int len, numBytes, result, flags = 0, i; const char *word; + DefineLineInformation; if (parsePtr->numWords < 2) { return TCL_ERROR; @@ -6388,8 +6389,14 @@ TclCompileEnsemble( * Hand off compilation to the subcommand compiler. At last! */ + mapPtr->loc[eclIndex].line++; + mapPtr->loc[eclIndex].next++; + result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + mapPtr->loc[eclIndex].line--; + mapPtr->loc[eclIndex].next--; + /* * Clean up if necessary. */ diff --git a/tests/dict.test b/tests/dict.test index b92893e..a673957 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1212,7 +1212,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber] } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are -- cgit v0.12 From 5260904a408218366fe2ef7a780eea2dc5922c9b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:11:01 +0000 Subject: [3487626] knownBug tests dict-23.2 and dist-24.21 already fixed on trunk. --- tests/dict.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/dict.test b/tests/dict.test index 02c9050..e898637 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1604,7 +1604,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber]}} } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are @@ -1838,7 +1838,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { } }} [linenumber]}} } 5 -test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { apply {{} {apply {n { set e {} set k {} -- cgit v0.12 From 6ad8909af3c178fac395992cd972c98270bf2e3c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 04:20:53 +0000 Subject: Stop segfault due to OBOE in CompileWord() calls in [dict lappend] compiler. --- generic/tclCompCmds.c | 4 ++-- tests/dict.test | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f96470d..fa4762d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1313,8 +1313,8 @@ TclCompileDictLappendCmd( return TCL_ERROR; } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, procPtr); - CompileWord(envPtr, keyTokenPtr, interp, 3); - CompileWord(envPtr, valueTokenPtr, interp, 4); + CompileWord(envPtr, keyTokenPtr, interp, 2); + CompileWord(envPtr, valueTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index a673957..6271779 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1243,6 +1243,12 @@ j } }} [linenumber] } 5 +test dict-23.3 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::lappend foo bar \ + [format baz]}} +} {bar baz} + rename linenumber {} # cleanup -- cgit v0.12 From 9c7cec89a95143fb90c190c5c0f6d01424ea1431 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 12:20:13 +0000 Subject: Line numbers wrong in compiled foreach body. --- generic/tclCompCmds.c | 6 ++---- tests/foreach.test | 11 +++++++++++ 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fa4762d..2013568 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1628,7 +1628,7 @@ TclCompileForeachCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; + int jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ @@ -1669,8 +1669,6 @@ TclCompileForeachCmd( return TCL_ERROR; } - bodyIndex = i-1; - /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -1837,7 +1835,7 @@ TclCompileForeachCmd( * Inline compile the loop body. */ - SetLineInformation (bodyIndex); + SetLineInformation (numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/tests/foreach.test b/tests/foreach.test index 7df7481..ac7a279 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -254,6 +254,17 @@ test foreach-9.1 {compiled empty var list} { list [catch { foo } msg] $msg } {1 {foreach varlist is empty}} +test foreach-9.2 {line numbers} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + foreach x y {*}{ + } {return [incr n -[linenumber]]} + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + test foreach-10.1 {foreach: [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} -- cgit v0.12 From 3abcbb2542b51d5fd6df940805672cba4660c3ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 Sep 2013 12:37:13 +0000 Subject: consistant use of capitals. --- win/Makefile.in | 8 ++++---- win/makefile.bc | 28 ++++++++++++++-------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/win/Makefile.in b/win/Makefile.in index 235313f..6748f1b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -586,23 +586,23 @@ install-binaries: binaries fi; \ done @if [ -f $(DDE_DLL_FILE) ]; then \ - echo installing $(DDE_DLL_FILE); \ + echo Installing $(DDE_DLL_FILE); \ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(DDE_LIB_FILE) ]; then \ - echo installing $(DDE_LIB_FILE); \ + echo Installing $(DDE_LIB_FILE); \ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(REG_DLL_FILE) ]; then \ - echo installing $(REG_DLL_FILE); \ + echo Installing $(REG_DLL_FILE); \ $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi @if [ -f $(REG_LIB_FILE) ]; then \ - echo installing $(REG_LIB_FILE); \ + echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi diff --git a/win/makefile.bc b/win/makefile.bc index 07b2333..3310b01 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -402,57 +402,57 @@ $(CAT32): $(WINDIR)\cat.c install-binaries: $(TCLSH) $(MKDIR) "$(BIN_INSTALL_DIR)" $(MKDIR) "$(LIB_INSTALL_DIR)" - @echo installing $(TCLDLLNAME) + @echo Installing $(TCLDLLNAME) @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)" @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)" - @echo installing "$(TCLSH)" + @echo Installing "$(TCLSH)" @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLPIPEDLLNAME) + @echo Installing $(TCLPIPEDLLNAME) @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)" - @echo installing $(TCLSTUBLIBNAME) + @echo Installing $(TCLSTUBLIBNAME) @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)" install-libraries: -@$(MKDIR) "$(LIB_INSTALL_DIR)" -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)" -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @echo installing http1.0 + @echo Installing http1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" - @echo installing http2.7 + @echo Installing http2.7 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.7" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7" - @echo installing opt0.4 + @echo Installing opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" - @echo installing msgcat1.5 + @echo Installing msgcat1.5 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" - @echo installing tcltest2.3 + @echo Installing tcltest2.3 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" - @echo installing platform1.0 + @echo Installing platform1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\shell.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" - @echo installing $(TCLDDEDLLNAME) + @echo Installing $(TCLDDEDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.3" -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3" - @echo installing $(TCLREGDLLNAME) + @echo Installing $(TCLREGDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2" - @echo installing encoding files + @echo Installing encoding files -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding" -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding" - @echo installing library files + @echo Installing library files -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)" -- cgit v0.12 From 635d8c961aa06ec17403483a0ff3c0a3d524f3d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 13:06:06 +0000 Subject: Line numbers wrong in compiled [dict set]. --- generic/tclCompCmds.c | 8 +++----- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 2013568..260bd28 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -683,11 +683,10 @@ TclCompileDictSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; Proc *procPtr = envPtr->procPtr; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int dictVarIndex, nameChars; + int i, dictVarIndex, nameChars; const char *name; /* @@ -720,8 +719,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - numWords = parsePtr->numWords-1; - for (i=1 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -730,7 +728,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index 6271779..83f1ca7 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1248,6 +1248,12 @@ test dict-23.3 {CompileWord OBOE} { apply {{} {tcl::dict::lappend foo bar \ [format baz]}} } {bar baz} +test dict-23.4 {CompileWord OBOE} { + apply {n { + dict set foo {*}{ + } [return [incr n -[linenumber]]] val + }} [linenumber] +} 1 rename linenumber {} -- cgit v0.12 From 0467fcff78969cf483da62fc1c7b7cb9309cf16b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 13:39:40 +0000 Subject: [31661d2135] Plug memory leak. --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..4d7bdd5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4327,7 +4327,7 @@ TEBCresume( if (listPtr->refCount == 1) { TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; indexelemCount = toIdx+1; -- cgit v0.12 From 071c731c5e45080a89c03c7ae74ec6acf4df59c2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:06:46 +0000 Subject: Stop segfault due to OBOE in CompileWord() calls in [dict incr] compiler. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 260bd28..3445c09 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -806,7 +806,7 @@ TclCompileDictIncrCmd( * Emit the key and the code to actually do the increment. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); + CompileWord(envPtr, keyTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; diff --git a/tests/dict.test b/tests/dict.test index 83f1ca7..fec000d 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1254,6 +1254,11 @@ test dict-23.4 {CompileWord OBOE} { } [return [incr n -[linenumber]]] val }} [linenumber] } 1 +test dict-23.5 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::incr foo \ + [format bar]}} +} {bar 1} rename linenumber {} -- cgit v0.12 From b9d177cec41c6ca4abcb019b38e7da7739ded8e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 14:21:21 +0000 Subject: [3606943]: Corrected description of method search order. --- ChangeLog | 5 +++++ doc/next.n | 11 +++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3dc8c5e..b144110 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2013-09-19 Donal Fellows + + * doc/next.n (METHOD SEARCH ORDER): Bug [3606943]: Corrected + description of method search order. + 2013-09-18 Donal Fellows Bump TclOO version to 1.0.1 for release. diff --git a/doc/next.n b/doc/next.n index 0ad752a..fe7bddf 100644 --- a/doc/next.n +++ b/doc/next.n @@ -62,14 +62,14 @@ The method chain is cached for future use. When constructing the method chain, method implementations are searched for in the following order: .IP [1] -In the object. -.IP [2] In the classes mixed into the object, in class traversal order. The list of mixins is checked in natural order. -.IP [3] +.IP [2] In the classes mixed into the classes of the object, with sources of mixing in being searched in class traversal order. Within each class, the list of mixins is processed in natural order. +.IP [3] +In the object itself. .IP [4] In the object's class. .IP [5] @@ -77,7 +77,10 @@ In the superclasses of the class, following each superclass in a depth-first fashion in the natural order of the superclass list. .PP Any particular method implementation always comes as \fIlate\fR in the -resulting list of implementations as possible. +resulting list of implementations as possible; this means that if some class, +A, is both mixed into a class, B, and is also a superclass of B, the instances +of B will always treat A as a superclass from the perspective of inheritance. +This is true even when the multiple inheritance is processed indirectly. .SS FILTERS .PP When an object has a list of filter names set upon it, or is an instance of a -- cgit v0.12 From 08f3edbacbd40f9f76fb9e002b49516a5ffc3c62 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:48:02 +0000 Subject: Line numbers wrong in compiled [dict get]. --- generic/tclCompCmds.c | 7 +++---- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3445c09..efb7ff2 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -822,7 +822,7 @@ TclCompileDictGetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -834,17 +834,16 @@ TclCompileDictGetCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Only compile this because we need INST_DICT_GET anyway. */ - for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index fec000d..149599b 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1259,6 +1259,12 @@ test dict-23.5 {CompileWord OBOE} { apply {{} {tcl::dict::incr foo \ [format bar]}} } {bar 1} +test dict-23.6 {CompileWord OBOE} { + apply {n { + dict get {a b} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 rename linenumber {} -- cgit v0.12 From 58c74e141ff1c65580defe7237e86826b15afea2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 14:55:05 +0000 Subject: Line numbers wrong in compiled [dict for]. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index efb7ff2..348910c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -934,7 +934,7 @@ TclCompileDictForCmd( * errors at this point. */ - CompileWord(envPtr, dictTokenPtr, interp, 3); + CompileWord(envPtr, dictTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); emptyTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); diff --git a/tests/dict.test b/tests/dict.test index 149599b..bd7b920 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1265,6 +1265,12 @@ test dict-23.6 {CompileWord OBOE} { } [return [incr n -[linenumber]]] }} [linenumber] } 1 +test dict-23.7 {CompileWord OBOE} { + apply {n { + dict for {a b} [return [incr n -[linenumber]]] {*}{ + } {} + }} [linenumber] +} 2 rename linenumber {} -- cgit v0.12 From 68feed9f4e09c3677ca335a790e197df2bdc5cf5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 15:04:47 +0000 Subject: Line numbers wrong in compiled [dict update]. --- generic/tclCompCmds.c | 2 +- tests/dict.test | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 348910c..51a566e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1159,7 +1159,7 @@ TclCompileDictUpdateCmd( infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i Date: Thu, 19 Sep 2013 15:44:21 +0000 Subject: Line numbers wrong in compiled [upvar]. --- generic/tclCompCmds.c | 16 ++++++++-------- tests/upvar.test | 11 +++++++++++ 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 51a566e..6189b29 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5781,16 +5781,14 @@ TclCompileUpvarCmd( Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int simpleVarName, isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords < 3) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -5798,6 +5796,7 @@ TclCompileUpvarCmd( * Push the frame index if it is known at compile time */ + objPtr = Tcl_NewObj(); tokenPtr = TokenAfter(parsePtr->tokenPtr); if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; @@ -5816,16 +5815,17 @@ TclCompileUpvarCmd( if(numWords%2) { return TCL_ERROR; } + /* TODO: Push the known value instead? */ CompileWord(envPtr, tokenPtr, interp, 1); otherTokenPtr = TokenAfter(tokenPtr); - i = 4; + i = 2; } else { if(!(numWords%2)) { return TCL_ERROR; } PushLiteral(envPtr, "1", 1); otherTokenPtr = tokenPtr; - i = 3; + i = 1; } } else { Tcl_DecrRefCount(objPtr); @@ -5838,12 +5838,12 @@ TclCompileUpvarCmd( * be called at runtime. */ - for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + for(; i Date: Thu, 19 Sep 2013 16:04:48 +0000 Subject: Line numbers wrong in compiled [namespace upvar]. --- generic/tclCompCmds.c | 8 ++++---- tests/upvar.test | 21 +++++++++++++++++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6189b29..8e26a30 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5920,7 +5920,7 @@ TclCompileNamespaceCmd( */ tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + CompileWord(envPtr, tokenPtr, interp, 2); /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a @@ -5929,13 +5929,13 @@ TclCompileNamespaceCmd( */ localTokenPtr = tokenPtr; - for(i=4; i<=numWords; i+=2) { + for(i=3; i Date: Thu, 19 Sep 2013 16:06:53 +0000 Subject: renumber tests for branch merge --- tests/upvar.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/upvar.test b/tests/upvar.test index df7f551..f90abef 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -553,7 +553,7 @@ test upvar-NS-1.9 {nsupvar links to correct variable} \ -returnCodes error \ -cleanup {namespace delete test_ns_1} -test upvar-NS-2.1 {CompileWord OBOE} -setup { +test upvar-NS-3.1 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { @@ -563,7 +563,7 @@ test upvar-NS-2.1 {CompileWord OBOE} -setup { } -cleanup { rename linenumber {} } -result 1 -test upvar-NS-2.2 {CompileWord OBOE} -setup { +test upvar-NS-3.2 {CompileWord OBOE} -setup { proc linenumber {} {dict get [info frame -1] line} } -body { apply {n { -- cgit v0.12 From 44d124101c6297b356f7de3917c4d0666b8a0e31 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 16:33:36 +0000 Subject: Line numbers wrong in compiled [global] and [variable]. --- generic/tclCompCmds.c | 18 ++++++++++++------ tests/upvar.test | 10 ++++++++++ 2 files changed, 22 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8e26a30..809a6c6 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -6007,14 +6007,17 @@ TclCompileGlobalCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for(i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + for(i=1; itokenPtr; - for(i=2; i<=numWords; i+=2) { + for(i=1; i Date: Thu, 19 Sep 2013 17:01:58 +0000 Subject: Line numbers wrong in compiled [dict exists]. --- generic/tclCompCmds.c | 7 +++---- tests/dict.test | 6 ++++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9829b9c..64c110d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1002,7 +1002,7 @@ TclCompileDictExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -1015,17 +1015,16 @@ TclCompileDictExistsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Now we do the code generation. */ - for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } diff --git a/tests/dict.test b/tests/dict.test index 797ab46..6c254eb 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1899,6 +1899,12 @@ test dict-23.8 {CompileWord OBOE} { } [return [incr n -[linenumber]]] x {} }} [linenumber] } 1 +test dict-23.9 {CompileWord OBOE} { + apply {n { + dict exists {} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From 91ec52b16e7cd903ca196560e5ddb1d5ca1c60a9 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 17:21:41 +0000 Subject: Line numbers wrong in compiled [dict with]. --- generic/tclCompCmds.c | 10 +++++----- tests/dict.test | 30 ++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 64c110d..7e6b6da 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1875,7 +1875,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1902,7 +1902,7 @@ TclCompileDictWithCmd( tokenPtr = varTokenPtr; for (i=1 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1916,7 +1916,7 @@ TclCompileDictWithCmd( * Case: Direct dict in non-simple var with empty body. */ - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); PushStringLiteral(envPtr, ""); @@ -1951,13 +1951,13 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; inumWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); diff --git a/tests/dict.test b/tests/dict.test index 6c254eb..a583de8 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1905,6 +1905,36 @@ test dict-23.9 {CompileWord OBOE} { } [return [incr n -[linenumber]]] }} [linenumber] } 1 +test dict-23.10 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.11 {CompileWord OBOE} { + apply {n { + dict with ::foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.12 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.13 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 +test dict-23.14 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { -- cgit v0.12 From 7b3702821be88e66474de1c1b1aa84c381276668 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 18:53:01 +0000 Subject: Line numbers wrong in compiled [unset]. --- generic/tclCompCmdsGR.c | 1 + generic/tclCompCmdsSZ.c | 14 +++++++------- tests/var.test | 13 +++++++++++++ 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 4e4a3af..43ea3d3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -587,6 +587,7 @@ TclCompileInfoCommandsCmd( * that the result needs to be list-ified. */ + /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d1eb9db..6c55e2e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2814,26 +2814,26 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, numWords, flags, i; + int isScalar, localIndex, flags, i; Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords-1; flags = 1; + i = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); leadingWord = Tcl_NewObj(); - if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { int len; const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } else if (len == 2 && !strncmp("--", bytes, 2)) { varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + i++; } } else { /* @@ -2846,7 +2846,7 @@ TclCompileUnsetCmd( } TclDecrRefCount(leadingWord); - for (i=0 ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -2856,7 +2856,7 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. diff --git a/tests/var.test b/tests/var.test index 5939100..6d4be26 100644 --- a/tests/var.test +++ b/tests/var.test @@ -862,6 +862,19 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 + +test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + set foo bar + unset foo {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + catch {namespace delete ns} catch {unset arr} -- cgit v0.12 From f19c90364c590451e85ba125933b3aa1fd9acd20 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 19 Sep 2013 19:02:42 +0000 Subject: comment --- generic/tclCompCmdsSZ.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6c55e2e..468c1c0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1864,6 +1864,7 @@ TclCompileTailcallCmd( } /* make room for the nsObjPtr */ + /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); -- cgit v0.12 From cadf55303e72b696eedb9b29a469156b27fffa47 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 19:37:05 +0000 Subject: [3970f54c4e]: Corrected regression in argument order processing in [unset]. --- generic/tclCompCmdsSZ.c | 40 +++++++++++++++++++++++++--------------- tests/var.test | 3 +++ 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 468c1c0..b90bff8 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,19 +2815,37 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags, i; - Tcl_Obj *leadingWord; + int isScalar, localIndex, flags = 1, i; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - flags = 1; - i = 1; + + /* + * Verify that all words are known at compile time so that we can handle + * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + */ + + for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + return TCL_ERROR; + } + } + + /* + * Check for options; if they're present we'll know for sure because we + * know we're all constant arguments. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (parsePtr->numWords > 1 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + i = 1; + if (parsePtr->numWords > 1) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + const char *bytes; int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); + (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); + bytes = Tcl_GetStringFromObj(leadingWord, &len); if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; varTokenPtr = TokenAfter(varTokenPtr); @@ -2836,16 +2854,8 @@ TclCompileUnsetCmd( varTokenPtr = TokenAfter(varTokenPtr); i++; } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ - TclDecrRefCount(leadingWord); - return TCL_ERROR; } - TclDecrRefCount(leadingWord); for ( ; inumWords ; i++) { /* diff --git a/tests/var.test b/tests/var.test index 6d4be26..208b361 100644 --- a/tests/var.test +++ b/tests/var.test @@ -748,6 +748,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} +test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { + apply {{} {unset foo [return ok]}} +} ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" -- cgit v0.12 From 2139c0e39e6fb83eb76edc0088de73b9caa7cdb3 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Sep 2013 22:37:06 +0000 Subject: [3970f54c4e]: Improved fix that is more tolerant of a single variable varname. --- generic/tclCompCmdsSZ.c | 82 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 57 insertions(+), 25 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index b90bff8..44cb66e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2815,49 +2815,81 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags = 1, i; + int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ /* - * Verify that all words are known at compile time so that we can handle - * them without needing to do a nasty push/rotate. [Bug 3970f54c4e] + * Verify that all words - except the first non-option one - are known at + * compile time so that we can handle them without needing to do a nasty + * push/rotate. [Bug 3970f54c4e] */ for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + varTokenPtr = TokenAfter(varTokenPtr); - if (!TclWordKnownAtCompileTime(varTokenPtr, NULL)) { + if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + TclDecrRefCount(leadingWord); + + /* + * We can tolerate non-trivial substitutions in the first variable + * to be unset. If a '--' or '-nocomplain' was present, anything + * goes in that one place! (All subsequent variable names must be + * constants since we don't want to have to push them all first.) + */ + + if (varCount == 0) { + if (haveFlags) { + continue; + } + + /* + * In fact, we're OK as long as we're the first argument *and* + * we provably don't start with a '-'. If that is true, then + * even if everything else is varying, we still can't be a + * flag. Otherwise we'll spill to runtime to place a limit on + * the trickiness. + */ + + if (varTokenPtr->type == TCL_TOKEN_WORD + && varTokenPtr[1].type == TCL_TOKEN_TEXT + && varTokenPtr[1].size > 0 + && varTokenPtr[1].start[0] != '-') { + continue; + } + } return TCL_ERROR; } + if (i == 1) { + const char *bytes; + int len; + + bytes = Tcl_GetStringFromObj(leadingWord, &len); + if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { + flags = 0; + haveFlags = 1; + } else if (len == 2 && !strncmp("--", bytes, 2)) { + haveFlags = 1; + } else { + varCount++; + } + } else { + varCount++; + } + TclDecrRefCount(leadingWord); } /* - * Check for options; if they're present we'll know for sure because we - * know we're all constant arguments. + * Issue instructions to unset each of the named variables. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - i = 1; - if (parsePtr->numWords > 1) { - Tcl_Obj *leadingWord = Tcl_NewObj(); - const char *bytes; - int len; - - (void) TclWordKnownAtCompileTime(varTokenPtr, leadingWord); - bytes = Tcl_GetStringFromObj(leadingWord, &len); - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - i++; - } - TclDecrRefCount(leadingWord); + if (haveFlags) { + varTokenPtr = TokenAfter(varTokenPtr); } - - for ( ; inumWords ; i++) { + for (i=1+haveFlags ; inumWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a -- cgit v0.12 From c4175e0434a242a24610b0c3a70214885b897006 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 20 Sep 2013 09:11:51 +0000 Subject: Make sure that panic's during finalization are handled by the custom panicproc not by the default panicproc, because stderr might not be available. When the default panicproc is in use, this doesn't make any difference. --- generic/tclEvent.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 686b80d..941d566 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1171,8 +1171,6 @@ Tcl_Finalize(void) TclFinalizeEncodingSubsystem(); - Tcl_SetPanicProc(NULL); - /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series -- cgit v0.12 From 5d9b0d315794199313c41559a91710addd1d4630 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 23 Sep 2013 11:12:12 +0000 Subject: workaround for mingw bug [http://comments.gmane.org/gmane.comp.gnu.mingw.user/41724] --- win/configure | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- win/tcl.m4 | 21 +++++++++++++++--- 2 files changed, 84 insertions(+), 6 deletions(-) diff --git a/win/configure b/win/configure index a0be0c4..0a293ca 100755 --- a/win/configure +++ b/win/configure @@ -3437,6 +3437,8 @@ echo "${ECHO_T}yes" >&6 # set various compiler flags depending on whether we are using gcc or cl if test "${GCC}" = "yes" ; then + extra_cflags="-pipe" + extra_ldflags="-pipe" echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 if test "${ac_cv_win32+set}" = set; then @@ -3500,6 +3502,70 @@ echo "${ECHO_T}$ac_cv_win32" >&6 echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} { (exit 1); exit 1; }; } fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 +echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6 +if test "${ac_cv_municode+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + + #include + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_municode=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_municode=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $ac_cv_municode" >&5 +echo "${ECHO_T}$ac_cv_municode" >&6 + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "no" ; then + extra_ldflags="$extra_ldflags -static-libgcc" + fi fi echo "$as_me:$LINENO: checking compiler flags" >&5 @@ -3521,9 +3587,6 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" - extra_cflags="-pipe" - extra_ldflags="-pipe" - if test "${SHARED_BUILD}" = "0" ; then # static echo "$as_me:$LINENO: result: using static flags" >&5 diff --git a/win/tcl.m4 b/win/tcl.m4 index 5696366..589a8c0 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -632,6 +632,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # set various compiler flags depending on whether we are using gcc or cl if test "${GCC}" = "yes" ; then + extra_cflags="-pipe" + extra_ldflags="-pipe" AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ @@ -645,6 +647,22 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + AC_CACHE_CHECK(for working -municode linker flag, + ac_cv_municode, + AC_TRY_LINK([ + #include + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + ], + [], + ac_cv_municode=yes, + ac_cv_municode=no) + ) + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "no" ; then + extra_ldflags="$extra_ldflags -static-libgcc" + fi fi AC_MSG_CHECKING([compiler flags]) @@ -665,9 +683,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MAKE_EXE="\${CC} -o \[$]@" LIBPREFIX="lib" - extra_cflags="-pipe" - extra_ldflags="-pipe" - if test "${SHARED_BUILD}" = "0" ; then # static AC_MSG_RESULT([using static flags]) -- cgit v0.12 From b54c2a5958b12875dc5a32cc1f09da20e23b087d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Sep 2013 12:18:45 +0000 Subject: revert mistaken commit of experiment --- generic/tclIOUtil.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6332453..6259216 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1944,7 +1944,7 @@ TclNREvalFile( iPtr->evalFlags |= TCL_EVAL_FILE; TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr, NULL); - return TclNREvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, INT_MIN); + return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN); } static int -- cgit v0.12 From f43e26d84c0342402389b06a5fa4e419a927e541 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 Sep 2013 16:39:26 +0000 Subject: Test demonstrating need for "adjust" manipulation in TclSubstTokens. --- tests/source.test | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/source.test b/tests/source.test index 641838c..dc3c2d8 100644 --- a/tests/source.test +++ b/tests/source.test @@ -187,6 +187,16 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} +test source-4.1 {continuation line parsing} -setup { + set sourcefile [makeFile [string map {CL \\\n} { + format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]" + }] source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -result {source: 3 4 5} + test source-6.1 {source is binary ok} -setup { # Note [makeFile] writes in the system encoding. # [source] defaults to reading in the system encoding. -- cgit v0.12 From 2d6233b88ed95056ca253dc72bf44017a82bb239 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 25 Sep 2013 22:54:29 +0000 Subject: [d614d63989] Ensure that there are no trailing colons as that causes chaos when a deleteProc is specified. --- generic/tclNamesp.c | 83 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 59 insertions(+), 24 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index d2decb9..4b72e03 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -737,6 +737,10 @@ Tcl_CreateNamespace( Tcl_DString *namePtr, *buffPtr; int newEntry, nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *nameStr; + Tcl_DString tmpBuffer; + + Tcl_DStringInit(&tmpBuffer); /* * If there is no active namespace, the interpreter is being initialized. @@ -750,39 +754,68 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; - } else if (*name == '\0') { + goto doCreate; + } + + /* + * Ensure that there are no trailing colons as that causes chaos when a + * deleteProc is specified. [Bug d614d63989] + */ + + if (deleteProc != NULL) { + nameStr = name + strlen(name) - 2; + if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') { + Tcl_DStringAppend(&tmpBuffer, name, -1); + while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0 + && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') { + Tcl_DStringSetLength(&tmpBuffer, nameLen-1); + } + name = Tcl_DStringValue(&tmpBuffer); + } + } + + /* + * If we've ended up with an empty string now, we're attempting to create + * the global namespace despite the global namespace existing. That's + * naughty! + */ + + if (*name == '\0') { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": " "only global namespace can have empty name", NULL); + Tcl_DStringFree(&tmpBuffer); return NULL; - } else { - /* - * Find the parent for the new namespace. - */ + } - TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, - &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); + /* + * Find the parent for the new namespace. + */ - /* - * If the unqualified name at the end is empty, there were trailing - * "::"s after the namespace's name which we ignore. The new namespace - * was already (recursively) created and is pointed to by parentPtr. - */ + TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); - if (*simpleName == '\0') { - return (Tcl_Namespace *) parentPtr; - } + /* + * If the unqualified name at the end is empty, there were trailing "::"s + * after the namespace's name which we ignore. The new namespace was + * already (recursively) created and is pointed to by parentPtr. + */ - /* - * Check for a bad namespace name and make sure that the name does not - * already exist in the parent namespace. - */ + if (*simpleName == '\0') { + Tcl_DStringFree(&tmpBuffer); + return (Tcl_Namespace *) parentPtr; + } - if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { - Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); - return NULL; - } + /* + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. + */ + + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { + Tcl_AppendResult(interp, "can't create namespace \"", name, + "\": already exists", NULL); + Tcl_DStringFree(&tmpBuffer); + return NULL; } /* @@ -790,6 +823,7 @@ Tcl_CreateNamespace( * of namespaces created. */ + doCreate: nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1)); strcpy(nsPtr->name, simpleName); @@ -879,6 +913,7 @@ Tcl_CreateNamespace( Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&tmpBuffer); /* * Return a pointer to the new namespace. -- cgit v0.12 From 38f8605a8d202951bbf792a4813b9b48a20910fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 26 Sep 2013 14:27:37 +0000 Subject: Tcl_SetResult -> Tcl_SetObjResult --- generic/tclBinary.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 58583f4..4e977f2 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2500,7 +2500,8 @@ BinaryEncode64( return TCL_ERROR; } if (maxlen < 0) { - Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; @@ -2606,7 +2607,8 @@ BinaryEncodeUu( return TCL_ERROR; } if (lineLength < 3 || lineLength > 85) { - Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; -- cgit v0.12 From 790f8f7114d0cc7b44cbaddc66e36c877c9c55b6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Sep 2013 09:18:36 +0000 Subject: Workaround for [http://sourceforge.net/p/mingw/bugs/2065/|MinGW bug #2065]. Both MinGW and MinGW-w64 (32-bit) are affected. Even though Win64 is not affected, adding -static-libgcc doesn't harm there, and we don't want to distrubute additional dll's with MinGW-compiled Tcl anyway. --- win/configure | 3 +-- win/tcl.m4 | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/win/configure b/win/configure index be9c98a..d09b588 100755 --- a/win/configure +++ b/win/configure @@ -3450,7 +3450,7 @@ echo "${ECHO_T}yes" >&6 if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 if test "${ac_cv_win32+set}" = set; then @@ -3579,7 +3579,6 @@ echo "${ECHO_T}$ac_cv_municode" >&6 extra_ldflags="$extra_ldflags -municode" else extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" - extra_ldflags="$extra_ldflags -static-libgcc" fi fi diff --git a/win/tcl.m4 b/win/tcl.m4 index 335494b..7ea7fad 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -634,7 +634,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ @@ -665,7 +665,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ extra_ldflags="$extra_ldflags -municode" else extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" - extra_ldflags="$extra_ldflags -static-libgcc" fi fi -- cgit v0.12 From 3b36134fe4997423da879edc4f400e411a702901 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Sep 2013 09:35:05 +0000 Subject: Cherrypick [87d1313df3] from trunk: Workaround for [http://sourceforge.net/p/mingw/bugs/2065/|MinGW bug #2065]. Both MinGW and MinGW-w64 (32-bit) are affected. Even though Win64 is not affected, adding -static-libgcc doesn't harm there, and we don't want to distrubute additional dll's with MinGW-compiled Tcl anyway. --- win/configure | 66 +---------------------------------------------------------- win/tcl.m4 | 18 +--------------- 2 files changed, 2 insertions(+), 82 deletions(-) diff --git a/win/configure b/win/configure index 0a293ca..8e1d0e8 100755 --- a/win/configure +++ b/win/configure @@ -3438,7 +3438,7 @@ echo "${ECHO_T}yes" >&6 if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6 if test "${ac_cv_win32+set}" = set; then @@ -3502,70 +3502,6 @@ echo "${ECHO_T}$ac_cv_win32" >&6 echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} { (exit 1); exit 1; }; } fi - - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" - echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 -echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6 -if test "${ac_cv_municode+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - - #include - int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_municode=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_municode=no -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - -fi -echo "$as_me:$LINENO: result: $ac_cv_municode" >&5 -echo "${ECHO_T}$ac_cv_municode" >&6 - CFLAGS=$hold_cflags - if test "$ac_cv_municode" = "no" ; then - extra_ldflags="$extra_ldflags -static-libgcc" - fi fi echo "$as_me:$LINENO: checking compiler flags" >&5 diff --git a/win/tcl.m4 b/win/tcl.m4 index 589a8c0..7de3013 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -633,7 +633,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "${GCC}" = "yes" ; then extra_cflags="-pipe" - extra_ldflags="-pipe" + extra_ldflags="-pipe -static-libgcc" AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ @@ -647,22 +647,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi - - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" - AC_CACHE_CHECK(for working -municode linker flag, - ac_cv_municode, - AC_TRY_LINK([ - #include - int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} - ], - [], - ac_cv_municode=yes, - ac_cv_municode=no) - ) - CFLAGS=$hold_cflags - if test "$ac_cv_municode" = "no" ; then - extra_ldflags="$extra_ldflags -static-libgcc" - fi fi AC_MSG_CHECKING([compiler flags]) -- cgit v0.12 From a5a2f896bb91053061b5a83f09cb0778c3b53e3b Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 27 Sep 2013 10:29:43 +0000 Subject: =?UTF-8?q?[219226]:=20Rewrote=20how=20::env=20is=20synchronized?= =?UTF-8?q?=20to=20the=20environment=20so=20it=20no=20longer=20smashes=20t?= =?UTF-8?q?he=20array=20or=20its=20elements=20flat,=20This=20affects=20tra?= =?UTF-8?q?ces=20on=20env,=20links=20to=20env,=20and=20iterations=20over?= =?UTF-8?q?=20env:=20it=20makes=20them=20work=20as=20na=C3=AFvely=20expect?= =?UTF-8?q?ed.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclEnv.c | 81 +++++++++++++++++++++++++++++++++++++++++++++----------- generic/tclInt.h | 2 ++ generic/tclVar.c | 47 ++++++++++++++++++++++++++++++++ tests/env.test | 23 ++++++++++++++++ 4 files changed, 137 insertions(+), 16 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index b5ae6ea..6a21947 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -76,36 +76,56 @@ TclSetupEnv( Tcl_Interp *interp) /* Interpreter whose "env" array is to be * managed. */ { + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; Tcl_DString envString; - char *p1, *p2; - int i; + Tcl_HashTable namesHash; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; /* * Synchronize the values in the environ array with the contents of the * Tcl "env" variable. To do this: - * 1) Remove the trace that fires when the "env" var is unset. - * 2) Unset the "env" variable. - * 3) If there are no environ variables, create an empty "env" array. - * Otherwise populate the array with current values. - * 4) Add a trace that synchronizes the "env" array. + * 1) Remove the trace that fires when the "env" var is updated. + * 2) Find the existing contents of the "env", storing in a hash table. + * 3) Create/update elements for each environ variable, removing + * elements from the hash table as we go. + * 4) Remove the elements for each remaining entry in the hash table, + * which must have existed before yet have no analog in the environ + * variable. + * 5) Add a trace that synchronizes the "env" array. */ Tcl_UntraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); - Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); + /* + * Find out what elements are currently in the global env array. + */ - if (environ[0] == NULL) { - Tcl_Obj *varNamePtr; + TclNewLiteralStringObj(varNamePtr, "env"); + Tcl_IncrRefCount(varNamePtr); + Tcl_InitObjHashTable(&namesHash); + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + TclFindArrayPtrElements(varPtr, &namesHash); + + /* + * Go through the environment array and transfer its values into Tcl. At + * the same time, remove those elements we add/update from the hash table + * of existing elements, so that after this part processes, that table + * will hold just the parts to remove. + */ + + if (environ[0] != NULL) { + int i; - TclNewLiteralStringObj(varNamePtr, "env"); - Tcl_IncrRefCount(varNamePtr); - TclArraySet(interp, varNamePtr, NULL); - Tcl_DecrRefCount(varNamePtr); - } else { Tcl_MutexLock(&envMutex); for (i = 0; environ[i] != NULL; i++) { + Tcl_Obj *obj1, *obj2; + char *p1, *p2; + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); p2 = strchr(p1, '='); if (p2 == NULL) { @@ -119,12 +139,41 @@ TclSetupEnv( } p2++; p2[-1] = '\0'; - Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + obj1 = Tcl_NewStringObj(p1, -1); + obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); + + Tcl_IncrRefCount(obj1); + Tcl_IncrRefCount(obj2); + Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY); + hPtr = Tcl_FindHashEntry(&namesHash, obj1); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DecrRefCount(obj1); + Tcl_DecrRefCount(obj2); } Tcl_MutexUnlock(&envMutex); } + /* + * Delete those elements that existed in the array but which had no + * counterparts in the environment array. + */ + + for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL; + hPtr=Tcl_NextHashEntry(&search)) { + Tcl_Obj *elemName = Tcl_GetHashValue(hPtr); + + TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY); + } + Tcl_DeleteHashTable(&namesHash); + Tcl_DecrRefCount(varNamePtr); + + /* + * Re-establish the trace. + */ + Tcl_TraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); diff --git a/generic/tclInt.h b/generic/tclInt.h index 380284f..feea6dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3857,6 +3857,8 @@ MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, const int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); +MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, + Tcl_HashTable *tablePtr); /* * The new extended interface to the variable traces. diff --git a/generic/tclVar.c b/generic/tclVar.c index af1a563..4694cd8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3850,6 +3850,53 @@ ArrayNamesCmd( /* *---------------------------------------------------------------------- * + * TclFindArrayPtrElements -- + * + * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry + * for each existing element of the given array. The provided hash table + * is assumed to be initially empty. + * + * Result: + * none + * + * Side effects: + * The keys of the array gain an extra reference. The supplied hash table + * has elements added to it. + * + *---------------------------------------------------------------------- + */ + +void +TclFindArrayPtrElements( + Var *arrayPtr, + Tcl_HashTable *tablePtr) +{ + Var *varPtr; + Tcl_HashSearch search; + + if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr) + || TclIsVarUndefined(arrayPtr)) { + return; + } + + for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search); + varPtr!=NULL ; varPtr=VarHashNextVar(&search)) { + Tcl_HashEntry *hPtr; + Tcl_Obj *nameObj; + int dummy; + + if (TclIsVarUndefined(varPtr)) { + continue; + } + nameObj = VarHashGetKey(varPtr); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy); + Tcl_SetHashValue(hPtr, nameObj); + } +} + +/* + *---------------------------------------------------------------------- + * * ArraySetCmd -- * * This object-based function is invoked to process the "array set" Tcl diff --git a/tests/env.test b/tests/env.test index fa76433..8115652 100644 --- a/tests/env.test +++ b/tests/env.test @@ -291,6 +291,29 @@ test env-6.1 {corner cases - add lots of env variables} {} { expr {[array size env] - $size} } 100 +test env-7.1 {[219226]: whole env array should not be unset by read} { + set n [array size env] + set s [array startsearch env] + while {[array anymore env $s]} { + array nextelement env $s + incr n -1 + } + array donesearch env $s + return $n +} 0 +test env-7.2 {[219226]: links to env elements should not be removed by read} { + apply {{} { + set ::env(test7_2) ok + upvar env(test7_2) elem + set ::env(PATH) + try { + return $elem + } finally { + unset ::env(test7_2) + } + }} +} ok + # Restore the environment variables at the end of the test. foreach name [array names env] { -- cgit v0.12 From ad4355066f0d4cdafaa288933a1517e6c79817ad Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 27 Sep 2013 17:33:17 +0000 Subject: Fix test source-4.1 --- generic/tclCompile.c | 6 +++++- tests/source.test | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f5c8d41..d15ef3a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2229,7 +2229,7 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - int i, numObjsToConcat, length; + int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; @@ -2266,6 +2266,7 @@ TclCompileTokens( clPosition = ckalloc(maxNumCL * sizeof(int)); } + adjust = 0; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { @@ -2309,6 +2310,7 @@ TclCompileTokens( clPosition[numCL] = clPos; numCL ++; } + adjust++; } break; @@ -2331,8 +2333,10 @@ TclCompileTokens( numCL = 0; } + envPtr->line += adjust; TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + envPtr->line -= adjust; numObjsToConcat++; break; diff --git a/tests/source.test b/tests/source.test index 6ee2198..0235bd1 100644 --- a/tests/source.test +++ b/tests/source.test @@ -187,7 +187,7 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} -test source-4.1 {continuation line parsing} -constraints knownBug -setup { +test source-4.1 {continuation line parsing} -setup { set sourcefile [makeFile [string map {CL \\\n} { format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]" }] source.file] -- cgit v0.12 From 789e4ada24cc5f08a6d5300e354a752cdb066eec Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Sep 2013 21:10:22 +0000 Subject: [dfc08326e3]: Corrected symbol export for TclOO to match Tcl so things work as expected in a static build. --- generic/tclOO.decls | 21 +++++++++++++++--- generic/tclOODecls.h | 58 ++++++++++++++++++++++++------------------------- generic/tclOOIntDecls.h | 32 +++++++++++++-------------- 3 files changed, 63 insertions(+), 48 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..19d3f03 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,12 +1,25 @@ +# tclOO.decls -- +# +# This file contains the declarations for all supported public functions +# that are exported by the TclOO package that is embedded within the Tcl +# library via the stubs table. This file is used to generate the +# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c +# files. +# +# Copyright (c) 2008-2013 by Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + library tclOO +scspec EXTERN ###################################################################### -# public API +# Public API, exposed for general users of TclOO. # interface tclOO hooks tclOOInt -scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -116,7 +129,9 @@ declare 28 { } ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..9cb704e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -12,92 +12,92 @@ */ /* 0 */ -TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); +EXTERN int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, +EXTERN int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); +EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); +EXTERN int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -TCLOOAPI int Tcl_ObjectContextIsFiltering( +EXTERN int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLOOAPI int Tcl_ObjectContextSkippedArgs( +EXTERN int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, +EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, +EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..834d8cb 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -12,46 +12,46 @@ */ /* 0 */ -TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); +EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +60,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +69,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, +EXTERN int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, +EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, +EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, +EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); -- cgit v0.12 From 6a1cc41ccac84140abbe6011995eefbf2e8a4435 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Sep 2013 22:52:11 +0000 Subject: typo; spotted by stu --- doc/Class.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Class.3 b/doc/Class.3 index 28cea9b..febe703 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -111,7 +111,7 @@ function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which -takes creates an object from any class (and which is internally called by both +creates an object from any class (and which is internally called by both the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes parameters that optionally give the name of the object and namespace to create, and which describe the arguments to pass to the class's constructor -- cgit v0.12 From 11fdcc3fedcd680e93a93d28bf862d388ada3f9d Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Sep 2013 03:00:06 +0000 Subject: First attempt at [string trim] compilation. --- generic/tclAssembly.c | 5 +- generic/tclCmdMZ.c | 8 +-- generic/tclCompCmdsSZ.c | 135 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 11 ++++ generic/tclCompile.h | 6 ++- generic/tclExecute.c | 33 ++++++++++++ generic/tclInt.h | 9 ++++ 7 files changed, 202 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 946c729..659f483 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -462,6 +462,8 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, + {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, @@ -502,7 +504,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_COROUTINE_NAME, /* 149 */ INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND /* 154 */ + INST_RESOLVE_COMMAND, /* 154 */ + INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166,167 */ }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5087fbb..2b5e995 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -35,6 +35,8 @@ static int UniCharIsHexDigit(int character); /* * Default set of characters to trim in [string trim] and friends. This is a * UTF-8 literal string containing all Unicode space characters [TIP #413] + * + * Synch with tclCompCmdsSZ.c */ #define DEFAULT_TRIM_SET \ @@ -3342,9 +3344,9 @@ TclInitStringCmd( {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 44cb66e..0177b2d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -640,6 +640,141 @@ TclCompileStringRangeCmd( OP( STR_RANGE); return TCL_OK; } + +/* + * Synch with tclCmdMZ.c + */ + +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x85" /* next line (U+0085) */\ + "\xc2\xa0" /* non-breaking space (U+00a0) */\ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ + "\xe2\x80\x80" /* en quad (U+2000) */\ + "\xe2\x80\x81" /* em quad (U+2001) */\ + "\xe2\x80\x82" /* en space (U+2002) */\ + "\xe2\x80\x83" /* em space (U+2003) */\ + "\xe2\x80\x84" /* three-per-em space (U+2004) */\ + "\xe2\x80\x85" /* four-per-em space (U+2005) */\ + "\xe2\x80\x86" /* six-per-em space (U+2006) */\ + "\xe2\x80\x87" /* figure space (U+2007) */\ + "\xe2\x80\x88" /* punctuation space (U+2008) */\ + "\xe2\x80\x89" /* thin space (U+2009) */\ + "\xe2\x80\x8a" /* hair space (U+200a) */\ + "\xe2\x80\x8b" /* zero width space (U+200b) */\ + "\xe2\x80\xa8" /* line separator (U+2028) */\ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ + "\xe2\x81\xa0" /* word joiner (U+2060) */\ + "\xe3\x80\x80" /* ideographic space (U+3000) */\ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ + +int +TclCompileStringTrimLCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + } + OP( STRTRIM_LEFT); + return TCL_OK; +} + +int +TclCompileStringTrimRCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + } + OP( STRTRIM_RIGHT); + return TCL_OK; +} + +int +TclCompileStringTrimCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + TclNewObj(objPtr); + if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + int len; + const char *p = Tcl_GetStringFromObj(objPtr, &len); + + PushLiteral(envPtr, p, len); + OP( STRTRIM_LEFT); + PushLiteral(envPtr, p, len); + OP( STRTRIM_RIGHT); + } else { + CompileWord(envPtr, tokenPtr, interp, 2); + OP4( REVERSE, 2); + OP4( OVER, 1); + OP( STRTRIM_LEFT); + OP4( REVERSE, 2); + OP( STRTRIM_RIGHT); + } + TclDecrRefCount(objPtr); + } else { + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + OP( STRTRIM_LEFT); + PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + OP( STRTRIM_RIGHT); + } + return TCL_OK; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d15ef3a..cdedbda 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -545,6 +545,17 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimleft] core: removes the characters (designated by the + * value at the top of the stack) from the left of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimright] core: removes the characters (designated by the + * value at the top of the stack) from the right of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5660055..08eb393 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -768,8 +768,12 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 +/* For compilation of [string trim] and related */ +#define INST_STRTRIM_LEFT 166 +#define INST_STRTRIM_RIGHT 167 + /* The last opcode */ -#define LAST_INST_OPCODE 165 +#define LAST_INST_OPCODE 167 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0ca393b..b4785bf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5252,6 +5252,39 @@ TEBCresume( objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); + { + const char *string1, *string2; + + case INST_STRTRIM_LEFT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + match = TclTrimLeft(string1, length, string2, length2); + if (match == 0) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + valuePtr); + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1+match, length-match); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + objResultPtr); + NEXT_INST_F(1, 2, 1); + } + case INST_STRTRIM_RIGHT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + match = TclTrimRight(string1, length, string2, length2); + if (match == 0) { + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1, length-match); + NEXT_INST_F(1, 2, 1); + } + } + case INST_REGEXP: cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ diff --git a/generic/tclInt.h b/generic/tclInt.h index feea6dd..2312734 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3614,6 +3614,15 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 5d83a3919d8912254cb477b87abab826cf78bc53 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 09:03:20 +0000 Subject: Fix [f51efe99a7] by reverting [371bcd0714] --- generic/tclOO.decls | 21 +++--------------- generic/tclOODecls.h | 58 ++++++++++++++++++++++++------------------------- generic/tclOOIntDecls.h | 32 +++++++++++++-------------- 3 files changed, 48 insertions(+), 63 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 19d3f03..31d1113 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,25 +1,12 @@ -# tclOO.decls -- -# -# This file contains the declarations for all supported public functions -# that are exported by the TclOO package that is embedded within the Tcl -# library via the stubs table. This file is used to generate the -# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c -# files. -# -# Copyright (c) 2008-2013 by Donal K. Fellows. -# -# See the file "license.terms" for information on usage and redistribution of -# this file, and for a DISCLAIMER OF ALL WARRANTIES. - library tclOO -scspec EXTERN ###################################################################### -# Public API, exposed for general users of TclOO. +# public API # interface tclOO hooks tclOOInt +scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -129,9 +116,7 @@ declare 28 { } ###################################################################### -# Private API, exposed to support advanced OO systems that plug in on top of -# TclOO; not intended for general use and does not have any commitment to -# long-term support. +# private API, exposed to support advanced OO systems that plug in on top # interface tclOOInt diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 9cb704e..58871c6 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -12,92 +12,92 @@ */ /* 0 */ -EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -EXTERN int Tcl_MethodIsPublic(Tcl_Method method); +TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -EXTERN int Tcl_MethodIsType(Tcl_Method method, +TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); +TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -EXTERN int Tcl_ObjectDeleted(Tcl_Object object); +TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -EXTERN int Tcl_ObjectContextIsFiltering( +TCLOOAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -EXTERN int Tcl_ObjectContextSkippedArgs( +TCLOOAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, +TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, +TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 834d8cb..acafb18 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -12,46 +12,46 @@ */ /* 0 */ -EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); +TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +60,7 @@ EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +69,22 @@ EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -EXTERN int TclOOInvokeObject(Tcl_Interp *interp, +TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, +TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, +TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); -- cgit v0.12 From 09b2762b8a6317ae6ef595df2c9dd239fd4749b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 09:38:49 +0000 Subject: Restore copyright assignments and some improved comments in tclOO.decls: previous commit was a blind revert of [371bcd0714], but those changes should not have been reverted. --- generic/tclOO.decls | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..f22390e 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,12 +1,25 @@ +# tclOO.decls -- +# +# This file contains the declarations for all supported public functions +# that are exported by the TclOO package that is embedded within the Tcl +# library via the stubs table. This file is used to generate the +# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c +# files. +# +# Copyright (c) 2008-2013 by Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + library tclOO +scspec TCLOOAPI ###################################################################### -# public API +# Public API, exposed for general users of TclOO. # interface tclOO hooks tclOOInt -scspec TCLOOAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -116,7 +129,9 @@ declare 28 { } ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt -- cgit v0.12 From 228c6fd96ff315b9d17a84b2b532f33853102168 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Sep 2013 14:03:56 +0000 Subject: Disable command line globbing on MinGW compiles: this saves startup time, since the result of the glob is not used anywhere. --- win/tclAppInit.c | 1 + 1 file changed, 1 insertion(+) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 0edd2c3..251a610 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -24,6 +24,7 @@ extern Tcl_PackageInitProc TclObjTest_Init; #endif /* TCL_TEST */ #if defined(__GNUC__) +int _CRT_glob = 0; static void setargv(int *argcPtr, char ***argvPtr); #endif /* __GNUC__ */ -- cgit v0.12 From ab9b922b76e5a364b81263128b3231b5bbd85c36 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Oct 2013 07:58:50 +0000 Subject: Fix compilation with latest MinGW-w64 version 3.0: Conflict on EXCEPTION_REGISTRATION typedef, which means something completely different in MinGW-w64. --- win/tclWin32Dll.c | 41 ++++++++++++----------------------------- win/tclWinChan.c | 29 ++++++----------------------- win/tclWinFCmd.c | 43 ++++++++++++------------------------------- win/tclWinInt.h | 17 +++++++++++++++++ 4 files changed, 47 insertions(+), 83 deletions(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 6c863b9..2cb7d7c 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -46,23 +46,6 @@ typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule); static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ static int platformId; /* Running under NT, or 95/98? */ -#ifdef HAVE_NO_SEH -/* - * Unlike Borland and Microsoft, we don't register exception handlers by - * pushing registration records onto the runtime stack. Instead, we register - * them by creating an EXCEPTION_REGISTRATION within the activation record. - */ - -typedef struct EXCEPTION_REGISTRATION { - struct EXCEPTION_REGISTRATION *link; - EXCEPTION_DISPOSITION (*handler)( - struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); - void *ebp; - void *esp; - int status; -} EXCEPTION_REGISTRATION; -#endif - /* * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it */ @@ -302,7 +285,7 @@ DllMain( LPVOID reserved) /* Not used. */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif switch (reason) { @@ -321,7 +304,7 @@ DllMain( __asm__ __volatile__ ( /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * Tcl_Finalize */ @@ -335,7 +318,7 @@ DllMain( "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain + * Link the TCLEXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" @@ -347,7 +330,7 @@ DllMain( "call _Tcl_Finalize" "\n\t" /* - * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION + * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION * and store a TCL_OK status */ @@ -357,7 +340,7 @@ DllMain( "jmp 2f" "\n" /* - * Come here on an exception. Get the EXCEPTION_REGISTRATION that + * Come here on an exception. Get the TCLEXCEPTION_REGISTRATION that * we previously put on the chain. */ @@ -368,7 +351,7 @@ DllMain( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" @@ -1086,7 +1069,7 @@ TclWinCPUID( # else - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; /* * Execute the CPUID instruction with the given index, and store results @@ -1095,7 +1078,7 @@ TclWinCPUID( __asm__ __volatile__( /* - * Construct an EXCEPTION_REGISTRATION to protect the CPUID + * Construct an TCLEXCEPTION_REGISTRATION to protect the CPUID * instruction (early 486's don't have CPUID) */ @@ -1109,7 +1092,7 @@ TclWinCPUID( "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain + * Link the TCLEXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" @@ -1128,7 +1111,7 @@ TclWinCPUID( "movl %%edx, 0xc(%%edi)" "\n\t" /* - * Come here on a normal exit. Recover the EXCEPTION_REGISTRATION and + * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION and * store a TCL_OK status. */ @@ -1138,7 +1121,7 @@ TclWinCPUID( "jmp 2f" "\n" /* - * Come here on an exception. Get the EXCEPTION_REGISTRATION that we + * Come here on an exception. Get the TCLEXCEPTION_REGISTRATION that we * previously put on the chain. */ @@ -1148,7 +1131,7 @@ TclWinCPUID( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 8aa2772..89d898f 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -119,23 +119,6 @@ static Tcl_ChannelType fileChannelType = { FileThreadActionProc, /* Thread action proc. */ FileTruncateProc, /* Truncate proc. */ }; - -#ifdef HAVE_NO_SEH -/* - * Unlike Borland and Microsoft, we don't register exception handlers by - * pushing registration records onto the runtime stack. Instead, we register - * them by creating an EXCEPTION_REGISTRATION within the activation record. - */ - -typedef struct EXCEPTION_REGISTRATION { - struct EXCEPTION_REGISTRATION* link; - EXCEPTION_DISPOSITION (*handler)( - struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); - void* ebp; - void* esp; - int status; -} EXCEPTION_REGISTRATION; -#endif /* *---------------------------------------------------------------------- @@ -1027,7 +1010,7 @@ Tcl_MakeFileChannel( * TCL_WRITABLE to indicate file mode. */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif char channelName[16 + TCL_INTEGER_SPACE]; Tcl_Channel channel = NULL; @@ -1108,7 +1091,7 @@ Tcl_MakeFileChannel( "movl %[dupedHandle], %%ebx" "\n\t" /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * CloseHandle. */ @@ -1122,7 +1105,7 @@ Tcl_MakeFileChannel( "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain. + * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" @@ -1135,7 +1118,7 @@ Tcl_MakeFileChannel( "call _CloseHandle@4" "\n\t" /* - * Come here on normal exit. Recover the EXCEPTION_REGISTRATION + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION * and put a TRUE status return into it. */ @@ -1145,7 +1128,7 @@ Tcl_MakeFileChannel( "jmp 2f" "\n" /* - * Come here on an exception. Recover the EXCEPTION_REGISTRATION + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION */ "1:" "\t" @@ -1154,7 +1137,7 @@ Tcl_MakeFileChannel( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index d918b4a..8999831 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -67,25 +67,6 @@ CONST TclFileAttrProcs tclpFileAttrProcs[] = { {GetWinFileShortName, CannotSetAttribute}, {GetWinFileAttributes, SetWinFileAttributes}}; -#ifdef HAVE_NO_SEH - -/* - * Unlike Borland and Microsoft, we don't register exception handlers by - * pushing registration records onto the runtime stack. Instead, we register - * them by creating an EXCEPTION_REGISTRATION within the activation record. - */ - -typedef struct EXCEPTION_REGISTRATION { - struct EXCEPTION_REGISTRATION *link; - EXCEPTION_DISPOSITION (*handler)( - struct _EXCEPTION_RECORD *, void *, struct _CONTEXT *, void *); - void *ebp; - void *esp; - int status; -} EXCEPTION_REGISTRATION; - -#endif - /* * Prototype for the TraverseWinTree callback function. */ @@ -176,7 +157,7 @@ DoRenameFile( * (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif DWORD srcAttr, dstAttr; int retval = -1; @@ -213,7 +194,7 @@ DoRenameFile( "movl %[nativeSrc], %%ecx" "\n\t" /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * MoveFile. */ @@ -227,7 +208,7 @@ DoRenameFile( "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain. + * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" @@ -242,7 +223,7 @@ DoRenameFile( "call *%%eax" "\n\t" /* - * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and * put the status return from MoveFile into it. */ @@ -251,7 +232,7 @@ DoRenameFile( "jmp 2f" "\n" /* - * Come here on an exception. Recover the EXCEPTION_REGISTRATION + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION */ "1:" "\t" @@ -260,7 +241,7 @@ DoRenameFile( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" @@ -568,7 +549,7 @@ DoCopyFile( CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) - EXCEPTION_REGISTRATION registration; + TCLEXCEPTION_REGISTRATION registration; #endif int retval = -1; @@ -605,7 +586,7 @@ DoCopyFile( "movl %[nativeSrc], %%ecx" "\n\t" /* - * Construct an EXCEPTION_REGISTRATION to protect the call to + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to * CopyFile. */ @@ -619,7 +600,7 @@ DoCopyFile( "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* - * Link the EXCEPTION_REGISTRATION on the chain. + * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" @@ -635,7 +616,7 @@ DoCopyFile( "call *%%eax" "\n\t" /* - * Come here on normal exit. Recover the EXCEPTION_REGISTRATION and + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and * put the status return from CopyFile into it. */ @@ -644,7 +625,7 @@ DoCopyFile( "jmp 2f" "\n" /* - * Come here on an exception. Recover the EXCEPTION_REGISTRATION + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION */ "1:" "\t" @@ -653,7 +634,7 @@ DoCopyFile( /* * Come here however we exited. Restore context from the - * EXCEPTION_REGISTRATION in case the stack is unbalanced. + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 2f6659c..3d5e275 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -14,6 +14,23 @@ #include "tclInt.h" +#ifdef HAVE_NO_SEH +/* + * Unlike Borland and Microsoft, we don't register exception handlers by + * pushing registration records onto the runtime stack. Instead, we register + * them by creating an TCLEXCEPTION_REGISTRATION within the activation record. + */ + +typedef struct TCLEXCEPTION_REGISTRATION { + struct TCLEXCEPTION_REGISTRATION *link; + EXCEPTION_DISPOSITION (*handler)( + struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); + void *ebp; + void *esp; + int status; +} TCLEXCEPTION_REGISTRATION; +#endif + /* * The following specifies how much stack space TclpCheckStackSpace() * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj() -- cgit v0.12 From b43170300d1edfb68bdc87f81aa4399d909177ee Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 08:46:29 +0000 Subject: Expand subset of lreplace functionality that is compiled. --- generic/tclCompCmdsGR.c | 159 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 142 insertions(+), 17 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 43ea3d3..e695068 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1430,9 +1430,9 @@ TclCompileLreplaceCmd( Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ Tcl_Obj *tmpObj; - int idx1, idx2, result, guaranteedDropAll = 0; + int idx1, idx2, result, i, offset; - if (parsePtr->numWords != 4) { + if (parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1492,38 +1492,163 @@ TclCompileLreplaceCmd( } /* - * Sanity check: can only issue when we're removing a range at one or - * other end of the list. If we're at one end or the other, convert the - * indices into the equivalent for an [lrange]. + * Work out what this [lreplace] is actually doing. */ + tmpObj = NULL; + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 4) { + if (idx1 == 0) { + if (idx2 == -2) { + goto dropAll; + } + idx1 = idx2 + 1; + idx2 = -2; + goto dropEnd; + } else if (idx2 == -2) { + idx2 = idx1 - 1; + idx1 = 0; + goto dropEnd; + } else { + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto dropRange; + } + } + + tokenPtr = TokenAfter(tokenPtr); + for (i=4 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4( INST_LIST, i - 4, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (idx1 == 0) { if (idx2 == -2) { - guaranteedDropAll = 1; + goto replaceAll; } idx1 = idx2 + 1; idx2 = -2; + goto replaceHead; } else if (idx2 == -2) { idx2 = idx1 - 1; idx1 = 0; + goto replaceTail; } else { - return TCL_ERROR; + if (idx1 > 0 && idx2 > 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } else if (idx1 < 0 && idx2 < 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto replaceRange; } /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. + * Issue instructions to perform the operations relating to configurations + * that just drop. The only argument pushed on the stack is the list to + * operate on. */ - CompileWord(envPtr, listTokenPtr, interp, 1); - if (guaranteedDropAll) { + dropAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushStringLiteral(envPtr, ""); + goto done; + + dropEnd: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + goto done; + + dropRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); - } else { - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( + "list doesn't contain element %d", idx1), NULL), envPtr); + CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, + Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + envPtr->codeStart + offset + 1); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Issue instructions to perform the operations relating to configurations + * that do real replacement. All arguments are pushed and assembled into a + * pair: the list of values to replace with, and the list to do the + * surgery on. + */ + + replaceAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + goto done; + + replaceHead: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceTail: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( + "list doesn't contain element %d", idx1), NULL), envPtr); + CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, + Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + envPtr->codeStart + offset + 1); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Clean up the allocated memory. + */ + + done: + if (tmpObj != NULL) { + Tcl_DecrRefCount(tmpObj); } return TCL_OK; } -- cgit v0.12 From 6671b7930273fc4c18dedbe929e2f3d67e1dedf0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 09:41:01 +0000 Subject: Fix TclOO API export rules. --- generic/tclOO.decls | 1 - generic/tclOO.h | 33 ++++++++++++----------- generic/tclOODecls.h | 72 +++++++++++++++++++++++++++++-------------------- generic/tclOOIntDecls.h | 46 ++++++++++++++++++++----------- 4 files changed, 91 insertions(+), 61 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index f22390e..4f1987c 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -12,7 +12,6 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. library tclOO -scspec TCLOOAPI ###################################################################### # Public API, exposed for general users of TclOO. diff --git a/generic/tclOO.h b/generic/tclOO.h index d5ab8a0..4a6cda7 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -12,21 +12,6 @@ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED -#include "tcl.h" - -#ifndef TCLOOAPI -# if defined(BUILD_tcl) || defined(BUILD_TclOO) -# define TCLOOAPI MODULE_SCOPE -# else -# define TCLOOAPI extern -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS 1 -# endif -#endif - -extern const char *TclOOInitializeStubs( - Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION) /* * Be careful when it comes to versioning; need to make sure that the @@ -42,6 +27,21 @@ extern const char *TclOOInitializeStubs( #define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION +#include "tcl.h" + +/* + * For C++ compilers, use extern "C" + */ + +#ifdef __cplusplus +extern "C" { +#endif + +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version); +#define Tcl_OOInitStubs(interp) \ + TclOOInitializeStubs((interp), TCLOO_VERSION) + /* * These are opaque types. */ @@ -130,6 +130,9 @@ typedef struct { #include "tclOODecls.h" +#ifdef __cplusplus +} +#endif #endif /* diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..c2a5615 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,6 +5,17 @@ #ifndef _TCLOODECLS #define _TCLOODECLS +#undef TCL_STORAGE_CLASS +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ /* @@ -12,92 +23,92 @@ */ /* 0 */ -TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); +EXTERN int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, +EXTERN int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); +EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); +EXTERN int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -TCLOOAPI int Tcl_ObjectContextIsFiltering( +EXTERN int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLOOAPI int Tcl_ObjectContextSkippedArgs( +EXTERN int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, +EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, +EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, +EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { @@ -215,4 +226,7 @@ extern const TclOOStubs *tclOOStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOODECLS */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..f0e3ee5 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -5,6 +5,17 @@ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS +#undef TCL_STORAGE_CLASS +#ifdef BUILD_tcl +# define TCL_STORAGE_CLASS DLLEXPORT +#else +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ /* @@ -12,46 +23,46 @@ */ /* 0 */ -TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); +EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +71,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +80,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, +EXTERN int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, +EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, +EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, +EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); @@ -160,4 +171,7 @@ extern const TclOOIntStubs *tclOOIntStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOOINTDECLS */ -- cgit v0.12 From 0bb601dd7253b545f4f9723a05bdd71c23421c77 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 10:01:50 +0000 Subject: Turn Tcl_OOInitStubs into a no-op in non-stub-enabled usage. --- generic/tclOO.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclOO.h b/generic/tclOO.h index 4a6cda7..e5ed10d 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,10 +37,14 @@ extern "C" { #endif +#ifdef USE_TCLOO_STUBS extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ TclOOInitializeStubs((interp), TCLOO_VERSION) +#else +#define Tcl_OOInitStubs(interp) (TCL_OK) +#endif /* * These are opaque types. -- cgit v0.12 From 497f593fcdae942fd1be5b1f8c9b6bfa22b77b97 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Oct 2013 10:30:19 +0000 Subject: Fix compilation of Itcl and Tdbc --- generic/tclOO.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclOO.h b/generic/tclOO.h index e5ed10d..b77faf4 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,6 +37,10 @@ extern "C" { #endif +#ifdef USE_TCL_STUBS +# define USE_TCLOO_STUBS +#endif + #ifdef USE_TCLOO_STUBS extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); -- cgit v0.12 From 1153158b42de547b96903291c168db993b64d960 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 13:14:29 +0000 Subject: silence warnings with clang --- generic/tclExecute.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0ca393b..fd91bdb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -293,12 +293,14 @@ VarHashCreateVar( switch (nCleanup) { \ case 1: goto cleanup1_pushObjResultPtr; \ case 2: goto cleanup2_pushObjResultPtr; \ + case 0: break; \ } \ } else { \ pc += (pcAdjustment); \ switch (nCleanup) { \ case 1: goto cleanup1; \ case 2: goto cleanup2; \ + case 0: break; \ } \ } \ } while (0) @@ -360,6 +362,8 @@ VarHashCreateVar( #define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) +#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) + /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is @@ -451,7 +455,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -471,7 +475,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ @@ -885,7 +889,7 @@ TclCreateExecEnv( esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -1106,8 +1110,8 @@ GrowEvaluationStack( if (esPtr->nextPtr) { oldPtr = esPtr; esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { + currElems = esPtr->endPtr - STACK_BASE(esPtr); + if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) { Tcl_Panic("STACK: Stack after current is in use"); } if (esPtr->nextPtr) { @@ -1119,7 +1123,7 @@ GrowEvaluationStack( DeleteExecStack(esPtr); esPtr = oldPtr; } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; + currElems = esPtr->endPtr - STACK_BASE(esPtr); } /* @@ -1273,10 +1277,10 @@ TclStackFree( while (esPtr->nextPtr) { esPtr = esPtr->nextPtr; } - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); while (esPtr->prevPtr) { ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { + if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) { DeleteExecStack(tmpPtr); } else { break; -- cgit v0.12 From 08c51736454ed20f4975179188a837a41f8f9d15 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 13:16:10 +0000 Subject: neater --- generic/tclOO.h | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclOO.h b/generic/tclOO.h index b77faf4..e19510d 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,11 +37,7 @@ extern "C" { #endif -#ifdef USE_TCL_STUBS -# define USE_TCLOO_STUBS -#endif - -#ifdef USE_TCLOO_STUBS +#if (defined(USE_TCLOO_STUBS) || defined(USE_TCL_STUBS)) extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ -- cgit v0.12 From 5871b801b3da2d89d15ea3d66bcb3b216f7584fe Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Oct 2013 14:35:30 +0000 Subject: minor: whitespace correction (my bad!) --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fd91bdb..d3c1227 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -455,7 +455,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -475,7 +475,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ -- cgit v0.12 From f9427cdbfd828dbabe79facdc3d757146c090563 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 3 Oct 2013 13:32:06 +0000 Subject: cleaner and faster 'string trim' --- generic/tclAssembly.c | 3 ++- generic/tclCompCmdsSZ.c | 24 ++---------------------- generic/tclCompile.c | 5 +++++ generic/tclCompile.h | 7 ++++--- generic/tclExecute.c | 34 ++++++++++++++++++++++++++++------ 5 files changed, 41 insertions(+), 32 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 659f483..44cddba 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -462,6 +462,7 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrim", ASSEM_1BYTE, INST_STRTRIM, 2, 1}, {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, @@ -505,7 +506,7 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ - INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166,167 */ + INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166-168 */ }; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0177b2d..12f6167 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -739,7 +739,6 @@ TclCompileStringTrimCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { return TCL_ERROR; @@ -749,30 +748,11 @@ TclCompileStringTrimCmd( CompileWord(envPtr, tokenPtr, interp, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); - TclNewObj(objPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - int len; - const char *p = Tcl_GetStringFromObj(objPtr, &len); - - PushLiteral(envPtr, p, len); - OP( STRTRIM_LEFT); - PushLiteral(envPtr, p, len); - OP( STRTRIM_RIGHT); - } else { - CompileWord(envPtr, tokenPtr, interp, 2); - OP4( REVERSE, 2); - OP4( OVER, 1); - OP( STRTRIM_LEFT); - OP4( REVERSE, 2); - OP( STRTRIM_RIGHT); - } - TclDecrRefCount(objPtr); + CompileWord(envPtr, tokenPtr, interp, 2); } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); - OP( STRTRIM_LEFT); - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); - OP( STRTRIM_RIGHT); } + OP( STRTRIM); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cdedbda..7e72d84 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -545,6 +545,11 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + {"strtrim", 1, -1, 0, {OPERAND_NONE}}, + /* [string trim] core: removes the characters (designated by the value + * at the top of the stack) from both ends of the string and pushes + * the resulting string. + * Stack: ... string charset => ... trimmedString */ {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, /* [string trimleft] core: removes the characters (designated by the * value at the top of the stack) from the left of the string and diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 08eb393..fa8d773 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -769,11 +769,12 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 /* For compilation of [string trim] and related */ -#define INST_STRTRIM_LEFT 166 -#define INST_STRTRIM_RIGHT 167 +#define INST_STRTRIM 166 +#define INST_STRTRIM_LEFT 167 +#define INST_STRTRIM_RIGHT 168 /* The last opcode */ -#define LAST_INST_OPCODE 167 +#define LAST_INST_OPCODE 168 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 83f68fd..8470389 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5258,19 +5258,41 @@ TEBCresume( { const char *string1, *string2; + int trim1, trim2; + case INST_STRTRIM: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrimLeft(string1, length, string2, length2); + if (trim1 < length) { + trim2 = TclTrimRight(string1, length, string2, length2); + } else { + trim2 = 0; + } + if (trim1 == 0 && trim2 == 0) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + valuePtr); + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), + objResultPtr); + NEXT_INST_F(1, 2, 1); + } case INST_STRTRIM_LEFT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); string1 = TclGetStringFromObj(valuePtr, &length); - match = TclTrimLeft(string1, length, string2, length2); - if (match == 0) { + trim1 = TclTrimLeft(string1, length, string2, length2); + if (trim1 == 0) { TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), valuePtr); NEXT_INST_F(1, 1, 0); } else { - objResultPtr = Tcl_NewStringObj(string1+match, length-match); + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1); TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), objResultPtr); NEXT_INST_F(1, 2, 1); @@ -5280,11 +5302,11 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); string1 = TclGetStringFromObj(valuePtr, &length); - match = TclTrimRight(string1, length, string2, length2); - if (match == 0) { + trim2 = TclTrimRight(string1, length, string2, length2); + if (trim2 == 0) { NEXT_INST_F(1, 1, 0); } else { - objResultPtr = Tcl_NewStringObj(string1, length-match); + objResultPtr = Tcl_NewStringObj(string1, length-trim2); NEXT_INST_F(1, 2, 1); } } -- cgit v0.12 From c09ca7b7b75b5cd4ce31f726e74fcfdbf011b255 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Oct 2013 15:17:43 +0000 Subject: When compiling with MSVC++, no longer link the stub library with msvcrt??.dll. This way, workarounds in extensions like [http://core.tcl.tk/itcl/info/a961f0729c] are no longer necessary. --- win/Makefile.in | 2 +- win/configure | 11 +++++++---- win/configure.in | 1 + win/makefile.vc | 2 +- win/tcl.m4 | 8 +++++--- 5 files changed, 15 insertions(+), 9 deletions(-) diff --git a/win/Makefile.in b/win/Makefile.in index 6748f1b..2d97807 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -418,7 +418,7 @@ $(CAT32): cat32.$(OBJEXT) ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @$(RM) ${TCL_STUB_LIB_FILE} - @MAKE_LIB@ ${STUB_OBJS} + @MAKE_STUB_LIB@ ${STUB_OBJS} @POST_MAKE_LIB@ ${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) diff --git a/win/configure b/win/configure index 8e1d0e8..a997ac9 100755 --- a/win/configure +++ b/win/configure @@ -309,7 +309,7 @@ ac_includes_default="\ # include #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. @@ -3519,6 +3519,7 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 RC_DEFINE=--define RES=res.o MAKE_LIB="\${STLIB_LD} \$@" + MAKE_STUB_LIB="\${STLIB_LD} \$@" POST_MAKE_LIB="\${RANLIB} \$@" MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" @@ -3549,9 +3550,8 @@ echo "$as_me: error: ${CC} does not support the -shared option. runtime= # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. Make sure CFLAGS is - # included so -mno-cygwin passed the correct libs to the linker. - SHLIB_LD='${CC} -shared ${CFLAGS}' + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \ @@ -3932,6 +3932,7 @@ _ACEOF RC_DEFINE=-d RES=res MAKE_LIB="\${STLIB_LD} -out:\$@" + MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\$@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\$@" LIBPREFIX="" @@ -4881,6 +4882,7 @@ fi + # empty on win, but needs sub'ing @@ -5613,6 +5615,7 @@ s,@LIBSUFFIX@,$LIBSUFFIX,;t t s,@EXESUFFIX@,$EXESUFFIX,;t t s,@LIBRARIES@,$LIBRARIES,;t t s,@MAKE_LIB@,$MAKE_LIB,;t t +s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t s,@POST_MAKE_LIB@,$POST_MAKE_LIB,;t t s,@MAKE_DLL@,$MAKE_DLL,;t t s,@MAKE_EXE@,$MAKE_EXE,;t t diff --git a/win/configure.in b/win/configure.in index ea25843..8b181f8 100644 --- a/win/configure.in +++ b/win/configure.in @@ -305,6 +305,7 @@ AC_SUBST(LIBSUFFIX) AC_SUBST(EXESUFFIX) AC_SUBST(LIBRARIES) AC_SUBST(MAKE_LIB) +AC_SUBST(MAKE_STUB_LIB) AC_SUBST(POST_MAKE_LIB) AC_SUBST(MAKE_DLL) AC_SUBST(MAKE_EXE) diff --git a/win/makefile.vc b/win/makefile.vc index 3d17331..d9570b9 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -574,7 +574,7 @@ $** !endif $(TCLSTUBLIB): $(TCLSTUBOBJS) - $(lib32) -nologo $(LINKERFLAGS) -out:$@ $(TCLSTUBOBJS) + $(lib32) -nologo $(LINKERFLAGS) -nodefaultlib -out:$@ $(TCLSTUBOBJS) $(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** diff --git a/win/tcl.m4 b/win/tcl.m4 index 7de3013..44fd47e 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -523,6 +523,7 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ # RES # # MAKE_LIB +# MAKE_STUB_LIB # MAKE_EXE # MAKE_DLL # @@ -663,6 +664,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ RC_DEFINE=--define RES=res.o MAKE_LIB="\${STLIB_LD} \[$]@" + MAKE_STUB_LIB="\${STLIB_LD} \[$]@" POST_MAKE_LIB="\${RANLIB} \[$]@" MAKE_EXE="\${CC} -o \[$]@" LIBPREFIX="lib" @@ -688,9 +690,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ runtime= # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. Make sure CFLAGS is - # included so -mno-cygwin passed the correct libs to the linker. - SHLIB_LD='${CC} -shared ${CFLAGS}' + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ @@ -948,6 +949,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ RC_DEFINE=-d RES=res MAKE_LIB="\${STLIB_LD} -out:\[$]@" + MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\[$]@" POST_MAKE_LIB= MAKE_EXE="\${CC} -Fe\[$]@" LIBPREFIX="" -- cgit v0.12 From 84ae9beda9265b2eea4f1c06d39e10cabc760103 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 4 Oct 2013 13:12:22 +0000 Subject: Added missing documentation. Corrected result of Tcl_OOInitStubs in non-stub case. --- doc/OOInitStubs.3 | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOO.h | 2 +- 2 files changed, 55 insertions(+), 1 deletion(-) create mode 100644 doc/OOInitStubs.3 diff --git a/doc/OOInitStubs.3 b/doc/OOInitStubs.3 new file mode 100644 index 0000000..be531c8 --- /dev/null +++ b/doc/OOInitStubs.3 @@ -0,0 +1,54 @@ +'\" +'\" Copyright (c) 2012 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.so man.macros +.TH Tcl_OOInitStubs 3 1.0 TclOO "TclOO Library Functions" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_OOInitStubs \- initialize library access to TclOO functionality +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +const char * +\fBTcl_OOInitStubs\fR(\fIinterp\fR) +.fi +.SH ARGUMENTS +.AS Tcl_Interp *interp in +.AP Tcl_Interp *interp in +The Tcl interpreter that the TclOO API is integrated with and whose C +interface is going to be used. +.BE +.SH DESCRIPTION +.PP +When an extension library is going to use the C interface exposed by TclOO, it +should use \fBTcl_OOInitStubs\fR to initialize its access to that interface +from within its \fI*\fB_Init\fR (or \fI*\fB_SafeInit\fR) function, passing in +the \fIinterp\fR that was passed into that routine as context. If the result +of calling \fBTcl_OOInitStubs\fR is NULL, the initialization failed and an +error message will have been left in the interpreter's result. Otherwise, the +initialization succeeded and the TclOO API may thereafter be used; the +version of the TclOO API is returned. +.PP +When using this function, either the C #define symbol \fBUSE_TCLOO_STUBS\fR +should be defined and your library code linked against the Tcl stub library, +or that #define symbol should \fInot\fR be defined and your library code +linked against the Tcl main library directly. +.SH "BACKWARD COMPATIBILITY NOTE" +.PP +If you are linking against the Tcl 8.5 forward compatibility package for +TclOO, \fIonly\fR the stub-enabled configuration is supported and you should +also link against the TclOO independent stub library; that library is an +integrated part of the main Tcl stub library in Tcl 8.6. +.SH KEYWORDS +stubs +.SH "SEE ALSO" +Tcl_InitStubs(3) +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/generic/tclOO.h b/generic/tclOO.h index e19510d..41be168 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -43,7 +43,7 @@ extern const char *TclOOInitializeStubs( #define Tcl_OOInitStubs(interp) \ TclOOInitializeStubs((interp), TCLOO_VERSION) #else -#define Tcl_OOInitStubs(interp) (TCL_OK) +#define Tcl_OOInitStubs(interp) (TCLOO_PATCHLEVEL) #endif /* -- cgit v0.12 From bf332fb49405c13e2d003ac1b447bae2ac4291b4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 5 Oct 2013 13:53:30 +0000 Subject: Added 'linsert' compiler. Factored out constant list index parser. --- generic/tclBasic.c | 2 +- generic/tclCompCmdsGR.c | 278 +++++++++++++++++++++++++++--------------------- generic/tclInt.h | 3 + 3 files changed, 160 insertions(+), 123 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a41351e..9f40932 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -227,7 +227,7 @@ static const CmdInfo builtInCmds[] = { {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index e695068..c5a0126 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,7 +27,57 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); + +/* + *---------------------------------------------------------------------- + * + * TclCompileLinsertCmd -- + * + * Parse a token and get the encoded version of the index (as understood + * by TEBC), assuming it is at all knowable at compile time. Only handles + * indices that are integers or 'end' or 'end-integer'. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * Sets *index to the index value if successful. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetIndexFromToken( + Tcl_Token *tokenPtr, + int *index) +{ + Tcl_Obj *tmpObj = Tcl_NewObj(); + int result, idx; + + if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + Tcl_DecrRefCount(tmpObj); + return TCL_ERROR; + } + result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); + if (result == TCL_OK && idx > -2) { + result = TCL_ERROR; + } + } + Tcl_DecrRefCount(tmpObj); + + if (result == TCL_OK) { + *index = idx; + } + + return result; +} /* *---------------------------------------------------------------------- @@ -1060,7 +1110,7 @@ TclCompileLindexCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, numWords = parsePtr->numWords; + int i, idx, numWords = parsePtr->numWords; DefineLineInformation; /* TIP #280 */ /* @@ -1078,46 +1128,28 @@ TclCompileLindexCmd( } idxTokenPtr = TokenAfter(valTokenPtr); - if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_Obj *tmpObj; - int idx, result; - - tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx); - if (result == TCL_OK) { - if (idx < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); - if (result == TCL_OK && idx > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - - if (result == TCL_OK) { - /* - * All checks have been completed, and we have exactly one of - * these constructs: - * lindex - * lindex end- - * This is best compiled as a push of the arbitrary value followed - * by an "immediate lindex" which is the most efficient variety. - */ - - CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - return TCL_OK; - } - + if (GetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) { /* - * If the conversion failed or the value was negative, we just keep on - * going with the more complex compilation. + * All checks have been completed, and we have exactly one of these + * constructs: + * lindex + * lindex end- + * This is best compiled as a push of the arbitrary value followed by + * an "immediate lindex" which is the most efficient variety. */ + + CompileWord(envPtr, valTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + return TCL_OK; } /* + * If the value was not known at compile time, the conversion failed or + * the value was negative, we just keep on going with the more complex + * compilation. + */ + + /* * Push the operands onto the stack. */ @@ -1330,8 +1362,7 @@ TclCompileLrangeCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result; + int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; @@ -1339,56 +1370,18 @@ TclCompileLrangeCmd( listTokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an + * Parse the indices. Will only compile if both are constants and not an * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * end-relative indexing) or an end-based index greater than 'end' itself. */ tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { return TCL_ERROR; } @@ -1407,19 +1400,16 @@ TclCompileLrangeCmd( /* *---------------------------------------------------------------------- * - * TclCompileLreplaceCmd -- + * TclCompileLinsertCmd -- * - * How to compile the "lreplace" command. We only bother with the case - * where there are no elements to insert and where both the 'first' and - * 'last' arguments are constant and one can be deterined to be at the - * end of the list. (This is the case that could also be written with - * "lrange".) + * How to compile the "linsert" command. We only bother with the case + * where the index is constant. * *---------------------------------------------------------------------- */ int -TclCompileLreplaceCmd( +TclCompileLinsertCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ @@ -1429,65 +1419,109 @@ TclCompileLreplaceCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result, i, offset; + int idx, i; - if (parsePtr->numWords < 4) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an + * Parse the index. Will only compile if it is constant and not an * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * end-relative indexing) or an end-based index greater than 'end' itself. */ tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (GetIndexFromToken(tokenPtr, &idx) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } + + /* + * There are four main cases. If there are no values to insert, this is + * just a confirm-listiness check. If the index is '0', this is a prepend. + * If the index is 'end' (== -2), this is an append. Otherwise, this is a + * splice (== split, insert values as list, concat-3). + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( -2, envPtr); + return TCL_OK; + } + + for (i=3 ; inumWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + TclEmitInstInt4( INST_LIST, i-3, envPtr); + + if (idx == 0 /*start*/) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } else if (idx == -2 /*end*/) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; + if (idx < 0) { + idx++; } + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx-1, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( -2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLreplaceCmd -- + * + * How to compile the "lreplace" command. We only bother with the case + * where the indices are constant. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLreplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *tmpObj; + int idx1, idx2, i, offset; + + if (parsePtr->numWords < 4) { return TCL_ERROR; } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Parse the second index. Will only compile if it is constant and not an + * Parse the indices. Will only compile if both are constants and not an * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * end-relative indexing) or an end-based index greater than 'end' itself. */ - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + tokenPtr = TokenAfter(listTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + + tokenPtr = TokenAfter(tokenPtr); + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 2312734..6fe07f8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3533,6 +3533,9 @@ MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 6a229b9d227ed7356d5a8e0ba52b84a213ec7563 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 5 Oct 2013 16:22:16 +0000 Subject: Advance to tzdata2013g --- library/tzdata/Africa/Casablanca | 284 ++++++++++++------------------ library/tzdata/Africa/Juba | 40 +---- library/tzdata/America/Anguilla | 7 +- library/tzdata/America/Araguaina | 174 +----------------- library/tzdata/America/Argentina/San_Luis | 2 +- library/tzdata/America/Aruba | 8 +- library/tzdata/America/Cayman | 4 +- library/tzdata/America/Dominica | 7 +- library/tzdata/America/Grand_Turk | 4 +- library/tzdata/America/Grenada | 7 +- library/tzdata/America/Guadeloupe | 7 +- library/tzdata/America/Jamaica | 6 +- library/tzdata/America/Marigot | 6 +- library/tzdata/America/Montserrat | 7 +- library/tzdata/America/St_Barthelemy | 6 +- library/tzdata/America/St_Kitts | 7 +- library/tzdata/America/St_Lucia | 8 +- library/tzdata/America/St_Thomas | 7 +- library/tzdata/America/St_Vincent | 8 +- library/tzdata/America/Tortola | 7 +- library/tzdata/America/Virgin | 6 +- library/tzdata/Antarctica/McMurdo | 258 +-------------------------- library/tzdata/Antarctica/South_Pole | 6 +- library/tzdata/Asia/Amman | 175 +----------------- library/tzdata/Asia/Dili | 2 +- library/tzdata/Asia/Gaza | 174 +++++++++--------- library/tzdata/Asia/Hebron | 174 +++++++++--------- library/tzdata/Asia/Jakarta | 12 +- library/tzdata/Asia/Jayapura | 4 +- library/tzdata/Asia/Makassar | 4 +- library/tzdata/Asia/Pontianak | 12 +- library/tzdata/Europe/Vaduz | 246 +------------------------- library/tzdata/Europe/Zurich | 4 +- library/tzdata/Pacific/Fiji | 78 ++++---- library/tzdata/Pacific/Johnston | 6 +- 35 files changed, 413 insertions(+), 1354 deletions(-) diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 757007c..dec2778 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -36,189 +36,133 @@ set TZData(:Africa/Casablanca) { {1367114400 3600 1 WEST} {1373162400 0 0 WET} {1376100000 3600 1 WEST} - {1380420000 0 0 WET} - {1398564000 3600 1 WEST} + {1382839200 0 0 WET} + {1396144800 3600 1 WEST} {1404007200 0 0 WET} {1406599200 3600 1 WEST} - {1411869600 0 0 WET} - {1430013600 3600 1 WEST} + {1414288800 0 0 WET} + {1427594400 3600 1 WEST} {1434592800 0 0 WET} {1437184800 3600 1 WEST} - {1443319200 0 0 WET} - {1461463200 3600 1 WEST} + {1445738400 0 0 WET} + {1459044000 3600 1 WEST} {1465264800 0 0 WET} {1467856800 3600 1 WEST} - {1474768800 0 0 WET} - {1493517600 3600 1 WEST} + {1477792800 0 0 WET} + {1490493600 3600 1 WEST} {1495850400 0 0 WET} {1498442400 3600 1 WEST} - {1506218400 0 0 WET} - {1524967200 3600 1 WEST} + {1509242400 0 0 WET} + {1521943200 3600 1 WEST} {1526436000 0 0 WET} {1529028000 3600 1 WEST} - {1538272800 0 0 WET} - {1556416800 3600 1 WEST} + {1540692000 0 0 WET} + {1553997600 3600 1 WEST} {1557108000 0 0 WET} {1559700000 3600 1 WEST} - {1569722400 0 0 WET} + {1572141600 0 0 WET} + {1585447200 3600 1 WEST} + {1587693600 0 0 WET} {1590285600 3600 1 WEST} - {1601172000 0 0 WET} + {1603591200 0 0 WET} + {1616896800 3600 1 WEST} + {1618279200 0 0 WET} {1620871200 3600 1 WEST} - {1632621600 0 0 WET} + {1635645600 0 0 WET} + {1648346400 3600 1 WEST} + {1648951200 0 0 WET} {1651543200 3600 1 WEST} - {1664071200 0 0 WET} - {1682820000 3600 1 WEST} - {1695520800 0 0 WET} - {1714269600 3600 1 WEST} - {1727575200 0 0 WET} - {1745719200 3600 1 WEST} - {1759024800 0 0 WET} - {1777168800 3600 1 WEST} - {1790474400 0 0 WET} - {1808618400 3600 1 WEST} - {1821924000 0 0 WET} - {1840672800 3600 1 WEST} - {1853373600 0 0 WET} - {1872122400 3600 1 WEST} - {1885428000 0 0 WET} - {1903572000 3600 1 WEST} - {1916877600 0 0 WET} - {1935021600 3600 1 WEST} - {1948327200 0 0 WET} - {1966471200 3600 1 WEST} - {1979776800 0 0 WET} - {1997920800 3600 1 WEST} - {2011226400 0 0 WET} - {2029975200 3600 1 WEST} - {2042676000 0 0 WET} - {2061424800 3600 1 WEST} - {2074730400 0 0 WET} - {2092874400 3600 1 WEST} - {2106180000 0 0 WET} - {2124324000 3600 1 WEST} - {2137629600 0 0 WET} - {2155773600 3600 1 WEST} - {2169079200 0 0 WET} - {2187223200 3600 1 WEST} - {2200528800 0 0 WET} - {2219277600 3600 1 WEST} - {2232583200 0 0 WET} - {2250727200 3600 1 WEST} - {2264032800 0 0 WET} - {2282176800 3600 1 WEST} - {2295482400 0 0 WET} - {2313626400 3600 1 WEST} - {2326932000 0 0 WET} - {2345076000 3600 1 WEST} - {2358381600 0 0 WET} - {2377130400 3600 1 WEST} - {2389831200 0 0 WET} - {2408580000 3600 1 WEST} - {2421885600 0 0 WET} - {2440029600 3600 1 WEST} - {2453335200 0 0 WET} - {2471479200 3600 1 WEST} - {2484784800 0 0 WET} - {2502928800 3600 1 WEST} - {2516234400 0 0 WET} - {2534378400 3600 1 WEST} - {2547684000 0 0 WET} - {2566432800 3600 1 WEST} - {2579133600 0 0 WET} - {2597882400 3600 1 WEST} - {2611188000 0 0 WET} - {2629332000 3600 1 WEST} - {2642637600 0 0 WET} - {2660781600 3600 1 WEST} - {2674087200 0 0 WET} - {2692231200 3600 1 WEST} - {2705536800 0 0 WET} - {2724285600 3600 1 WEST} - {2736986400 0 0 WET} - {2755735200 3600 1 WEST} - {2769040800 0 0 WET} - {2787184800 3600 1 WEST} - {2800490400 0 0 WET} - {2818634400 3600 1 WEST} - {2831940000 0 0 WET} - {2850084000 3600 1 WEST} - {2863389600 0 0 WET} - {2881533600 3600 1 WEST} - {2894839200 0 0 WET} - {2913588000 3600 1 WEST} - {2926288800 0 0 WET} - {2945037600 3600 1 WEST} - {2958343200 0 0 WET} - {2976487200 3600 1 WEST} - {2989792800 0 0 WET} - {3007936800 3600 1 WEST} - {3021242400 0 0 WET} - {3039386400 3600 1 WEST} - {3052692000 0 0 WET} - {3070836000 3600 1 WEST} - {3084141600 0 0 WET} - {3102890400 3600 1 WEST} - {3116196000 0 0 WET} - {3134340000 3600 1 WEST} - {3147645600 0 0 WET} - {3165789600 3600 1 WEST} - {3179095200 0 0 WET} - {3197239200 3600 1 WEST} - {3210544800 0 0 WET} - {3228688800 3600 1 WEST} - {3241994400 0 0 WET} - {3260743200 3600 1 WEST} - {3273444000 0 0 WET} - {3292192800 3600 1 WEST} - {3305498400 0 0 WET} - {3323642400 3600 1 WEST} - {3336948000 0 0 WET} - {3355092000 3600 1 WEST} - {3368397600 0 0 WET} - {3386541600 3600 1 WEST} - {3399847200 0 0 WET} - {3417991200 3600 1 WEST} - {3431296800 0 0 WET} - {3450045600 3600 1 WEST} - {3462746400 0 0 WET} - {3481495200 3600 1 WEST} - {3494800800 0 0 WET} - {3512944800 3600 1 WEST} - {3526250400 0 0 WET} - {3544394400 3600 1 WEST} - {3557700000 0 0 WET} - {3575844000 3600 1 WEST} - {3589149600 0 0 WET} - {3607898400 3600 1 WEST} - {3620599200 0 0 WET} - {3639348000 3600 1 WEST} - {3652653600 0 0 WET} - {3670797600 3600 1 WEST} - {3684103200 0 0 WET} - {3702247200 3600 1 WEST} - {3715552800 0 0 WET} - {3733696800 3600 1 WEST} - {3747002400 0 0 WET} - {3765146400 3600 1 WEST} - {3778452000 0 0 WET} - {3797200800 3600 1 WEST} - {3809901600 0 0 WET} - {3828650400 3600 1 WEST} - {3841956000 0 0 WET} - {3860100000 3600 1 WEST} - {3873405600 0 0 WET} - {3891549600 3600 1 WEST} - {3904855200 0 0 WET} - {3922999200 3600 1 WEST} - {3936304800 0 0 WET} - {3954448800 3600 1 WEST} - {3967754400 0 0 WET} - {3986503200 3600 1 WEST} - {3999808800 0 0 WET} - {4017952800 3600 1 WEST} - {4031258400 0 0 WET} - {4049402400 3600 1 WEST} - {4062708000 0 0 WET} - {4080852000 3600 1 WEST} - {4094157600 0 0 WET} + {1667095200 0 0 WET} + {1682128800 3600 1 WEST} + {1698544800 0 0 WET} + {1712714400 3600 1 WEST} + {1729994400 0 0 WET} + {1743386400 3600 1 WEST} + {1761444000 0 0 WET} + {1774749600 3600 1 WEST} + {1792893600 0 0 WET} + {1806199200 3600 1 WEST} + {1824948000 0 0 WET} + {1837648800 3600 1 WEST} + {1856397600 0 0 WET} + {1869098400 3600 1 WEST} + {1887847200 0 0 WET} + {1901152800 3600 1 WEST} + {1919296800 0 0 WET} + {1932602400 3600 1 WEST} + {1950746400 0 0 WET} + {1964052000 3600 1 WEST} + {1982800800 0 0 WET} + {1995501600 3600 1 WEST} + {2014250400 0 0 WET} + {2026951200 3600 1 WEST} + {2045700000 0 0 WET} + {2058400800 3600 1 WEST} + {2077149600 0 0 WET} + {2090455200 3600 1 WEST} + {2108167200 0 0 WET} + {2121904800 3600 1 WEST} + {2138839200 0 0 WET} + {2153354400 3600 1 WEST} + {2184800400 3600 1 WEST} + {2216250000 3600 1 WEST} + {2248304400 3600 1 WEST} + {2279754000 3600 1 WEST} + {2311203600 3600 1 WEST} + {2342653200 3600 1 WEST} + {2374102800 3600 1 WEST} + {2405552400 3600 1 WEST} + {2437606800 3600 1 WEST} + {2469056400 3600 1 WEST} + {2500506000 3600 1 WEST} + {2531955600 3600 1 WEST} + {2563405200 3600 1 WEST} + {2595459600 3600 1 WEST} + {2626909200 3600 1 WEST} + {2658358800 3600 1 WEST} + {2689808400 3600 1 WEST} + {2721258000 3600 1 WEST} + {2752707600 3600 1 WEST} + {2784762000 3600 1 WEST} + {2816211600 3600 1 WEST} + {2847661200 3600 1 WEST} + {2879110800 3600 1 WEST} + {2910560400 3600 1 WEST} + {2942010000 3600 1 WEST} + {2974064400 3600 1 WEST} + {3005514000 3600 1 WEST} + {3036963600 3600 1 WEST} + {3068413200 3600 1 WEST} + {3099862800 3600 1 WEST} + {3131917200 3600 1 WEST} + {3163366800 3600 1 WEST} + {3194816400 3600 1 WEST} + {3226266000 3600 1 WEST} + {3257715600 3600 1 WEST} + {3289165200 3600 1 WEST} + {3321219600 3600 1 WEST} + {3352669200 3600 1 WEST} + {3384118800 3600 1 WEST} + {3415568400 3600 1 WEST} + {3447018000 3600 1 WEST} + {3479072400 3600 1 WEST} + {3510522000 3600 1 WEST} + {3541971600 3600 1 WEST} + {3573421200 3600 1 WEST} + {3604870800 3600 1 WEST} + {3636320400 3600 1 WEST} + {3668374800 3600 1 WEST} + {3699824400 3600 1 WEST} + {3731274000 3600 1 WEST} + {3762723600 3600 1 WEST} + {3794173200 3600 1 WEST} + {3825622800 3600 1 WEST} + {3857677200 3600 1 WEST} + {3889126800 3600 1 WEST} + {3920576400 3600 1 WEST} + {3952026000 3600 1 WEST} + {3983475600 3600 1 WEST} + {4015530000 3600 1 WEST} + {4046979600 3600 1 WEST} + {4078429200 3600 1 WEST} } diff --git a/library/tzdata/Africa/Juba b/library/tzdata/Africa/Juba index 7495981..40551f2 100644 --- a/library/tzdata/Africa/Juba +++ b/library/tzdata/Africa/Juba @@ -1,39 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Africa/Juba) { - {-9223372036854775808 7584 0 LMT} - {-1230775584 7200 0 CAT} - {10360800 10800 1 CAST} - {24786000 7200 0 CAT} - {41810400 10800 1 CAST} - {56322000 7200 0 CAT} - {73432800 10800 1 CAST} - {87944400 7200 0 CAT} - {104882400 10800 1 CAST} - {119480400 7200 0 CAT} - {136332000 10800 1 CAST} - {151016400 7200 0 CAT} - {167781600 10800 1 CAST} - {182552400 7200 0 CAT} - {199231200 10800 1 CAST} - {214174800 7200 0 CAT} - {230680800 10800 1 CAST} - {245710800 7200 0 CAT} - {262735200 10800 1 CAST} - {277246800 7200 0 CAT} - {294184800 10800 1 CAST} - {308782800 7200 0 CAT} - {325634400 10800 1 CAST} - {340405200 7200 0 CAT} - {357084000 10800 1 CAST} - {371941200 7200 0 CAT} - {388533600 10800 1 CAST} - {403477200 7200 0 CAT} - {419983200 10800 1 CAST} - {435013200 7200 0 CAT} - {452037600 10800 1 CAST} - {466635600 7200 0 CAT} - {483487200 10800 1 CAST} - {498171600 7200 0 CAT} - {947930400 10800 0 EAT} +if {![info exists TZData(Africa/Khartoum)]} { + LoadTimeZoneFile Africa/Khartoum } +set TZData(:Africa/Juba) $TZData(:Africa/Khartoum) diff --git a/library/tzdata/America/Anguilla b/library/tzdata/America/Anguilla index cfe7483..39a0d18 100644 --- a/library/tzdata/America/Anguilla +++ b/library/tzdata/America/Anguilla @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Anguilla) { - {-9223372036854775808 -15136 0 LMT} - {-1825098464 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Anguilla) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Araguaina b/library/tzdata/America/Araguaina index dc1b543..e4a0d52 100644 --- a/library/tzdata/America/Araguaina +++ b/library/tzdata/America/Araguaina @@ -56,177 +56,5 @@ set TZData(:America/Araguaina) { {1064368800 -10800 0 BRT} {1350788400 -7200 0 BRST} {1361066400 -10800 0 BRT} - {1382238000 -7200 1 BRST} - {1392516000 -10800 0 BRT} - {1413687600 -7200 1 BRST} - {1424570400 -10800 0 BRT} - {1445137200 -7200 1 BRST} - {1456020000 -10800 0 BRT} - {1476586800 -7200 1 BRST} - {1487469600 -10800 0 BRT} - {1508036400 -7200 1 BRST} - {1518919200 -10800 0 BRT} - {1540090800 -7200 1 BRST} - {1550368800 -10800 0 BRT} - {1571540400 -7200 1 BRST} - {1581818400 -10800 0 BRT} - {1602990000 -7200 1 BRST} - {1613872800 -10800 0 BRT} - {1634439600 -7200 1 BRST} - {1645322400 -10800 0 BRT} - {1665889200 -7200 1 BRST} - {1677376800 -10800 0 BRT} - {1697338800 -7200 1 BRST} - {1708221600 -10800 0 BRT} - {1729393200 -7200 1 BRST} - {1739671200 -10800 0 BRT} - {1760842800 -7200 1 BRST} - {1771725600 -10800 0 BRT} - {1792292400 -7200 1 BRST} - {1803175200 -10800 0 BRT} - {1823742000 -7200 1 BRST} - {1834624800 -10800 0 BRT} - {1855191600 -7200 1 BRST} - {1866074400 -10800 0 BRT} - {1887246000 -7200 1 BRST} - {1897524000 -10800 0 BRT} - {1918695600 -7200 1 BRST} - {1928973600 -10800 0 BRT} - {1950145200 -7200 1 BRST} - {1960423200 -10800 0 BRT} - {1981594800 -7200 1 BRST} - {1992477600 -10800 0 BRT} - {2013044400 -7200 1 BRST} - {2024532000 -10800 0 BRT} - {2044494000 -7200 1 BRST} - {2055376800 -10800 0 BRT} - {2076548400 -7200 1 BRST} - {2086826400 -10800 0 BRT} - {2107998000 -7200 1 BRST} - {2118880800 -10800 0 BRT} - {2139447600 -7200 1 BRST} - {2150330400 -10800 0 BRT} - {2170897200 -7200 1 BRST} - {2181780000 -10800 0 BRT} - {2202346800 -7200 1 BRST} - {2213229600 -10800 0 BRT} - {2234401200 -7200 1 BRST} - {2244679200 -10800 0 BRT} - {2265850800 -7200 1 BRST} - {2276128800 -10800 0 BRT} - {2297300400 -7200 1 BRST} - {2307578400 -10800 0 BRT} - {2328750000 -7200 1 BRST} - {2339632800 -10800 0 BRT} - {2360199600 -7200 1 BRST} - {2371082400 -10800 0 BRT} - {2391649200 -7200 1 BRST} - {2402532000 -10800 0 BRT} - {2423703600 -7200 1 BRST} - {2433981600 -10800 0 BRT} - {2455153200 -7200 1 BRST} - {2465431200 -10800 0 BRT} - {2486602800 -7200 1 BRST} - {2497485600 -10800 0 BRT} - {2518052400 -7200 1 BRST} - {2528935200 -10800 0 BRT} - {2549502000 -7200 1 BRST} - {2560384800 -10800 0 BRT} - {2580951600 -7200 1 BRST} - {2591834400 -10800 0 BRT} - {2613006000 -7200 1 BRST} - {2623284000 -10800 0 BRT} - {2644455600 -7200 1 BRST} - {2654733600 -10800 0 BRT} - {2675905200 -7200 1 BRST} - {2686788000 -10800 0 BRT} - {2707354800 -7200 1 BRST} - {2718237600 -10800 0 BRT} - {2738804400 -7200 1 BRST} - {2749687200 -10800 0 BRT} - {2770858800 -7200 1 BRST} - {2781136800 -10800 0 BRT} - {2802308400 -7200 1 BRST} - {2812586400 -10800 0 BRT} - {2833758000 -7200 1 BRST} - {2844036000 -10800 0 BRT} - {2865207600 -7200 1 BRST} - {2876090400 -10800 0 BRT} - {2896657200 -7200 1 BRST} - {2907540000 -10800 0 BRT} - {2928106800 -7200 1 BRST} - {2938989600 -10800 0 BRT} - {2960161200 -7200 1 BRST} - {2970439200 -10800 0 BRT} - {2991610800 -7200 1 BRST} - {3001888800 -10800 0 BRT} - {3023060400 -7200 1 BRST} - {3033943200 -10800 0 BRT} - {3054510000 -7200 1 BRST} - {3065392800 -10800 0 BRT} - {3085959600 -7200 1 BRST} - {3096842400 -10800 0 BRT} - {3118014000 -7200 1 BRST} - {3128292000 -10800 0 BRT} - {3149463600 -7200 1 BRST} - {3159741600 -10800 0 BRT} - {3180913200 -7200 1 BRST} - {3191191200 -10800 0 BRT} - {3212362800 -7200 1 BRST} - {3223245600 -10800 0 BRT} - {3243812400 -7200 1 BRST} - {3254695200 -10800 0 BRT} - {3275262000 -7200 1 BRST} - {3286144800 -10800 0 BRT} - {3307316400 -7200 1 BRST} - {3317594400 -10800 0 BRT} - {3338766000 -7200 1 BRST} - {3349044000 -10800 0 BRT} - {3370215600 -7200 1 BRST} - {3381098400 -10800 0 BRT} - {3401665200 -7200 1 BRST} - {3412548000 -10800 0 BRT} - {3433114800 -7200 1 BRST} - {3443997600 -10800 0 BRT} - {3464564400 -7200 1 BRST} - {3475447200 -10800 0 BRT} - {3496618800 -7200 1 BRST} - {3506896800 -10800 0 BRT} - {3528068400 -7200 1 BRST} - {3538346400 -10800 0 BRT} - {3559518000 -7200 1 BRST} - {3570400800 -10800 0 BRT} - {3590967600 -7200 1 BRST} - {3601850400 -10800 0 BRT} - {3622417200 -7200 1 BRST} - {3633300000 -10800 0 BRT} - {3654471600 -7200 1 BRST} - {3664749600 -10800 0 BRT} - {3685921200 -7200 1 BRST} - {3696199200 -10800 0 BRT} - {3717370800 -7200 1 BRST} - {3727648800 -10800 0 BRT} - {3748820400 -7200 1 BRST} - {3759703200 -10800 0 BRT} - {3780270000 -7200 1 BRST} - {3791152800 -10800 0 BRT} - {3811719600 -7200 1 BRST} - {3822602400 -10800 0 BRT} - {3843774000 -7200 1 BRST} - {3854052000 -10800 0 BRT} - {3875223600 -7200 1 BRST} - {3885501600 -10800 0 BRT} - {3906673200 -7200 1 BRST} - {3917556000 -10800 0 BRT} - {3938122800 -7200 1 BRST} - {3949005600 -10800 0 BRT} - {3969572400 -7200 1 BRST} - {3980455200 -10800 0 BRT} - {4001626800 -7200 1 BRST} - {4011904800 -10800 0 BRT} - {4033076400 -7200 1 BRST} - {4043354400 -10800 0 BRT} - {4064526000 -7200 1 BRST} - {4074804000 -10800 0 BRT} - {4095975600 -7200 1 BRST} + {1378000800 -10800 0 BRT} } diff --git a/library/tzdata/America/Argentina/San_Luis b/library/tzdata/America/Argentina/San_Luis index bec1554..8ca55d7 100644 --- a/library/tzdata/America/Argentina/San_Luis +++ b/library/tzdata/America/Argentina/San_Luis @@ -64,5 +64,5 @@ set TZData(:America/Argentina/San_Luis) { {1205031600 -14400 0 WART} {1223784000 -10800 1 WARST} {1236481200 -14400 0 WART} - {1255233600 -10800 1 WARST} + {1255233600 -10800 0 ART} } diff --git a/library/tzdata/America/Aruba b/library/tzdata/America/Aruba index 92f182d..e02d5fc 100644 --- a/library/tzdata/America/Aruba +++ b/library/tzdata/America/Aruba @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Aruba) { - {-9223372036854775808 -16824 0 LMT} - {-1826738376 -16200 0 ANT} - {-157750200 -14400 0 AST} +if {![info exists TZData(America/Curacao)]} { + LoadTimeZoneFile America/Curacao } +set TZData(:America/Aruba) $TZData(:America/Curacao) diff --git a/library/tzdata/America/Cayman b/library/tzdata/America/Cayman index ab5d12b..3e2e3cc 100644 --- a/library/tzdata/America/Cayman +++ b/library/tzdata/America/Cayman @@ -2,6 +2,6 @@ set TZData(:America/Cayman) { {-9223372036854775808 -19532 0 LMT} - {-2524502068 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524502068 -18431 0 KMT} + {-1827687169 -18000 0 EST} } diff --git a/library/tzdata/America/Dominica b/library/tzdata/America/Dominica index 3503a65..b97cb0e 100644 --- a/library/tzdata/America/Dominica +++ b/library/tzdata/America/Dominica @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Dominica) { - {-9223372036854775808 -14736 0 LMT} - {-1846266804 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Dominica) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Grand_Turk b/library/tzdata/America/Grand_Turk index a455dd5..6c8ea4a 100644 --- a/library/tzdata/America/Grand_Turk +++ b/library/tzdata/America/Grand_Turk @@ -2,8 +2,8 @@ set TZData(:America/Grand_Turk) { {-9223372036854775808 -17072 0 LMT} - {-2524504528 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524504528 -18431 0 KMT} + {-1827687169 -18000 0 EST} {294217200 -14400 1 EDT} {309938400 -18000 0 EST} {325666800 -14400 1 EDT} diff --git a/library/tzdata/America/Grenada b/library/tzdata/America/Grenada index 3c2919b..92300c3 100644 --- a/library/tzdata/America/Grenada +++ b/library/tzdata/America/Grenada @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Grenada) { - {-9223372036854775808 -14820 0 LMT} - {-1846266780 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Grenada) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Guadeloupe b/library/tzdata/America/Guadeloupe index b1987ce..aba6bd7 100644 --- a/library/tzdata/America/Guadeloupe +++ b/library/tzdata/America/Guadeloupe @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Guadeloupe) { - {-9223372036854775808 -14768 0 LMT} - {-1848254032 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Guadeloupe) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Jamaica b/library/tzdata/America/Jamaica index 393d90a8..682e47c 100644 --- a/library/tzdata/America/Jamaica +++ b/library/tzdata/America/Jamaica @@ -1,9 +1,9 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:America/Jamaica) { - {-9223372036854775808 -18432 0 LMT} - {-2524503168 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-9223372036854775808 -18431 0 LMT} + {-2524503169 -18431 0 KMT} + {-1827687169 -18000 0 EST} {136364400 -14400 0 EDT} {152085600 -18000 0 EST} {162370800 -14400 1 EDT} diff --git a/library/tzdata/America/Marigot b/library/tzdata/America/Marigot index 9f3f8f6..c2b3873 100644 --- a/library/tzdata/America/Marigot +++ b/library/tzdata/America/Marigot @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Marigot) $TZData(:America/Guadeloupe) +set TZData(:America/Marigot) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Montserrat b/library/tzdata/America/Montserrat index 4d82766..0a656d3 100644 --- a/library/tzdata/America/Montserrat +++ b/library/tzdata/America/Montserrat @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Montserrat) { - {-9223372036854775808 -14932 0 LMT} - {-1846266608 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Montserrat) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Barthelemy b/library/tzdata/America/St_Barthelemy index 25c114a..46bc287 100644 --- a/library/tzdata/America/St_Barthelemy +++ b/library/tzdata/America/St_Barthelemy @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/St_Barthelemy) $TZData(:America/Guadeloupe) +set TZData(:America/St_Barthelemy) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Kitts b/library/tzdata/America/St_Kitts index bfd803b..6ad7f04 100644 --- a/library/tzdata/America/St_Kitts +++ b/library/tzdata/America/St_Kitts @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Kitts) { - {-9223372036854775808 -15052 0 LMT} - {-1825098548 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Kitts) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Lucia b/library/tzdata/America/St_Lucia index c2767dd..e479b31 100644 --- a/library/tzdata/America/St_Lucia +++ b/library/tzdata/America/St_Lucia @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Lucia) { - {-9223372036854775808 -14640 0 LMT} - {-2524506960 -14640 0 CMT} - {-1830369360 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Lucia) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Thomas b/library/tzdata/America/St_Thomas index bf93595..24698b8 100644 --- a/library/tzdata/America/St_Thomas +++ b/library/tzdata/America/St_Thomas @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Thomas) { - {-9223372036854775808 -15584 0 LMT} - {-1846266016 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Thomas) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Vincent b/library/tzdata/America/St_Vincent index 3a884c7..e3b32fb 100644 --- a/library/tzdata/America/St_Vincent +++ b/library/tzdata/America/St_Vincent @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Vincent) { - {-9223372036854775808 -14696 0 LMT} - {-2524506904 -14696 0 KMT} - {-1830369304 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Vincent) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Tortola b/library/tzdata/America/Tortola index bf7f1fc..aa6f655 100644 --- a/library/tzdata/America/Tortola +++ b/library/tzdata/America/Tortola @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Tortola) { - {-9223372036854775808 -15508 0 LMT} - {-1846266092 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Tortola) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Virgin b/library/tzdata/America/Virgin index 390d7c2..c267e5b 100644 --- a/library/tzdata/America/Virgin +++ b/library/tzdata/America/Virgin @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/St_Thomas)]} { - LoadTimeZoneFile America/St_Thomas +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Virgin) $TZData(:America/St_Thomas) +set TZData(:America/Virgin) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/Antarctica/McMurdo b/library/tzdata/Antarctica/McMurdo index 670f7eb..3b29ba1 100644 --- a/library/tzdata/Antarctica/McMurdo +++ b/library/tzdata/Antarctica/McMurdo @@ -1,257 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Antarctica/McMurdo) { - {-9223372036854775808 0 0 zzz} - {-441849600 43200 0 NZST} - {152632800 46800 1 NZDT} - {162309600 43200 0 NZST} - {183477600 46800 1 NZDT} - {194968800 43200 0 NZST} - {215532000 46800 1 NZDT} - {226418400 43200 0 NZST} - {246981600 46800 1 NZDT} - {257868000 43200 0 NZST} - {278431200 46800 1 NZDT} - {289317600 43200 0 NZST} - {309880800 46800 1 NZDT} - {320767200 43200 0 NZST} - {341330400 46800 1 NZDT} - {352216800 43200 0 NZST} - {372780000 46800 1 NZDT} - {384271200 43200 0 NZST} - {404834400 46800 1 NZDT} - {415720800 43200 0 NZST} - {436284000 46800 1 NZDT} - {447170400 43200 0 NZST} - {467733600 46800 1 NZDT} - {478620000 43200 0 NZST} - {499183200 46800 1 NZDT} - {510069600 43200 0 NZST} - {530632800 46800 1 NZDT} - {541519200 43200 0 NZST} - {562082400 46800 1 NZDT} - {573573600 43200 0 NZST} - {594136800 46800 1 NZDT} - {605023200 43200 0 NZST} - {623772000 46800 1 NZDT} - {637682400 43200 0 NZST} - {655221600 46800 1 NZDT} - {669132000 43200 0 NZST} - {686671200 46800 1 NZDT} - {700581600 43200 0 NZST} - {718120800 46800 1 NZDT} - {732636000 43200 0 NZST} - {749570400 46800 1 NZDT} - {764085600 43200 0 NZST} - {781020000 46800 1 NZDT} - {795535200 43200 0 NZST} - {812469600 46800 1 NZDT} - {826984800 43200 0 NZST} - {844524000 46800 1 NZDT} - {858434400 43200 0 NZST} - {875973600 46800 1 NZDT} - {889884000 43200 0 NZST} - {907423200 46800 1 NZDT} - {921938400 43200 0 NZST} - {938872800 46800 1 NZDT} - {953388000 43200 0 NZST} - {970322400 46800 1 NZDT} - {984837600 43200 0 NZST} - {1002376800 46800 1 NZDT} - {1016287200 43200 0 NZST} - {1033826400 46800 1 NZDT} - {1047736800 43200 0 NZST} - {1065276000 46800 1 NZDT} - {1079791200 43200 0 NZST} - {1096725600 46800 1 NZDT} - {1111240800 43200 0 NZST} - {1128175200 46800 1 NZDT} - {1142690400 43200 0 NZST} - {1159624800 46800 1 NZDT} - {1174140000 43200 0 NZST} - {1191074400 46800 1 NZDT} - {1207404000 43200 0 NZST} - {1222524000 46800 1 NZDT} - {1238853600 43200 0 NZST} - {1253973600 46800 1 NZDT} - {1270303200 43200 0 NZST} - {1285423200 46800 1 NZDT} - {1301752800 43200 0 NZST} - {1316872800 46800 1 NZDT} - {1333202400 43200 0 NZST} - {1348927200 46800 1 NZDT} - {1365256800 43200 0 NZST} - {1380376800 46800 1 NZDT} - {1396706400 43200 0 NZST} - {1411826400 46800 1 NZDT} - {1428156000 43200 0 NZST} - {1443276000 46800 1 NZDT} - {1459605600 43200 0 NZST} - {1474725600 46800 1 NZDT} - {1491055200 43200 0 NZST} - {1506175200 46800 1 NZDT} - {1522504800 43200 0 NZST} - {1538229600 46800 1 NZDT} - {1554559200 43200 0 NZST} - {1569679200 46800 1 NZDT} - {1586008800 43200 0 NZST} - {1601128800 46800 1 NZDT} - {1617458400 43200 0 NZST} - {1632578400 46800 1 NZDT} - {1648908000 43200 0 NZST} - {1664028000 46800 1 NZDT} - {1680357600 43200 0 NZST} - {1695477600 46800 1 NZDT} - {1712412000 43200 0 NZST} - {1727532000 46800 1 NZDT} - {1743861600 43200 0 NZST} - {1758981600 46800 1 NZDT} - {1775311200 43200 0 NZST} - {1790431200 46800 1 NZDT} - {1806760800 43200 0 NZST} - {1821880800 46800 1 NZDT} - {1838210400 43200 0 NZST} - {1853330400 46800 1 NZDT} - {1869660000 43200 0 NZST} - {1885384800 46800 1 NZDT} - {1901714400 43200 0 NZST} - {1916834400 46800 1 NZDT} - {1933164000 43200 0 NZST} - {1948284000 46800 1 NZDT} - {1964613600 43200 0 NZST} - {1979733600 46800 1 NZDT} - {1996063200 43200 0 NZST} - {2011183200 46800 1 NZDT} - {2027512800 43200 0 NZST} - {2042632800 46800 1 NZDT} - {2058962400 43200 0 NZST} - {2074687200 46800 1 NZDT} - {2091016800 43200 0 NZST} - {2106136800 46800 1 NZDT} - {2122466400 43200 0 NZST} - {2137586400 46800 1 NZDT} - {2153916000 43200 0 NZST} - {2169036000 46800 1 NZDT} - {2185365600 43200 0 NZST} - {2200485600 46800 1 NZDT} - {2216815200 43200 0 NZST} - {2232540000 46800 1 NZDT} - {2248869600 43200 0 NZST} - {2263989600 46800 1 NZDT} - {2280319200 43200 0 NZST} - {2295439200 46800 1 NZDT} - {2311768800 43200 0 NZST} - {2326888800 46800 1 NZDT} - {2343218400 43200 0 NZST} - {2358338400 46800 1 NZDT} - {2374668000 43200 0 NZST} - {2389788000 46800 1 NZDT} - {2406117600 43200 0 NZST} - {2421842400 46800 1 NZDT} - {2438172000 43200 0 NZST} - {2453292000 46800 1 NZDT} - {2469621600 43200 0 NZST} - {2484741600 46800 1 NZDT} - {2501071200 43200 0 NZST} - {2516191200 46800 1 NZDT} - {2532520800 43200 0 NZST} - {2547640800 46800 1 NZDT} - {2563970400 43200 0 NZST} - {2579090400 46800 1 NZDT} - {2596024800 43200 0 NZST} - {2611144800 46800 1 NZDT} - {2627474400 43200 0 NZST} - {2642594400 46800 1 NZDT} - {2658924000 43200 0 NZST} - {2674044000 46800 1 NZDT} - {2690373600 43200 0 NZST} - {2705493600 46800 1 NZDT} - {2721823200 43200 0 NZST} - {2736943200 46800 1 NZDT} - {2753272800 43200 0 NZST} - {2768997600 46800 1 NZDT} - {2785327200 43200 0 NZST} - {2800447200 46800 1 NZDT} - {2816776800 43200 0 NZST} - {2831896800 46800 1 NZDT} - {2848226400 43200 0 NZST} - {2863346400 46800 1 NZDT} - {2879676000 43200 0 NZST} - {2894796000 46800 1 NZDT} - {2911125600 43200 0 NZST} - {2926245600 46800 1 NZDT} - {2942575200 43200 0 NZST} - {2958300000 46800 1 NZDT} - {2974629600 43200 0 NZST} - {2989749600 46800 1 NZDT} - {3006079200 43200 0 NZST} - {3021199200 46800 1 NZDT} - {3037528800 43200 0 NZST} - {3052648800 46800 1 NZDT} - {3068978400 43200 0 NZST} - {3084098400 46800 1 NZDT} - {3100428000 43200 0 NZST} - {3116152800 46800 1 NZDT} - {3132482400 43200 0 NZST} - {3147602400 46800 1 NZDT} - {3163932000 43200 0 NZST} - {3179052000 46800 1 NZDT} - {3195381600 43200 0 NZST} - {3210501600 46800 1 NZDT} - {3226831200 43200 0 NZST} - {3241951200 46800 1 NZDT} - {3258280800 43200 0 NZST} - {3273400800 46800 1 NZDT} - {3289730400 43200 0 NZST} - {3305455200 46800 1 NZDT} - {3321784800 43200 0 NZST} - {3336904800 46800 1 NZDT} - {3353234400 43200 0 NZST} - {3368354400 46800 1 NZDT} - {3384684000 43200 0 NZST} - {3399804000 46800 1 NZDT} - {3416133600 43200 0 NZST} - {3431253600 46800 1 NZDT} - {3447583200 43200 0 NZST} - {3462703200 46800 1 NZDT} - {3479637600 43200 0 NZST} - {3494757600 46800 1 NZDT} - {3511087200 43200 0 NZST} - {3526207200 46800 1 NZDT} - {3542536800 43200 0 NZST} - {3557656800 46800 1 NZDT} - {3573986400 43200 0 NZST} - {3589106400 46800 1 NZDT} - {3605436000 43200 0 NZST} - {3620556000 46800 1 NZDT} - {3636885600 43200 0 NZST} - {3652610400 46800 1 NZDT} - {3668940000 43200 0 NZST} - {3684060000 46800 1 NZDT} - {3700389600 43200 0 NZST} - {3715509600 46800 1 NZDT} - {3731839200 43200 0 NZST} - {3746959200 46800 1 NZDT} - {3763288800 43200 0 NZST} - {3778408800 46800 1 NZDT} - {3794738400 43200 0 NZST} - {3809858400 46800 1 NZDT} - {3826188000 43200 0 NZST} - {3841912800 46800 1 NZDT} - {3858242400 43200 0 NZST} - {3873362400 46800 1 NZDT} - {3889692000 43200 0 NZST} - {3904812000 46800 1 NZDT} - {3921141600 43200 0 NZST} - {3936261600 46800 1 NZDT} - {3952591200 43200 0 NZST} - {3967711200 46800 1 NZDT} - {3984040800 43200 0 NZST} - {3999765600 46800 1 NZDT} - {4016095200 43200 0 NZST} - {4031215200 46800 1 NZDT} - {4047544800 43200 0 NZST} - {4062664800 46800 1 NZDT} - {4078994400 43200 0 NZST} - {4094114400 46800 1 NZDT} +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } +set TZData(:Antarctica/McMurdo) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Antarctica/South_Pole b/library/tzdata/Antarctica/South_Pole index 34d0db1..544bde4 100644 --- a/library/tzdata/Antarctica/South_Pole +++ b/library/tzdata/Antarctica/South_Pole @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Antarctica/McMurdo)]} { - LoadTimeZoneFile Antarctica/McMurdo +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } -set TZData(:Antarctica/South_Pole) $TZData(:Antarctica/McMurdo) +set TZData(:Antarctica/South_Pole) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Asia/Amman b/library/tzdata/Asia/Amman index 33f0ba7..d5e8616 100644 --- a/library/tzdata/Asia/Amman +++ b/library/tzdata/Asia/Amman @@ -70,178 +70,5 @@ set TZData(:Asia/Amman) { {1301608800 10800 1 EEST} {1319752800 7200 0 EET} {1333058400 10800 1 EEST} - {1364504400 10800 1 EEST} - {1382652000 7200 0 EET} - {1395957600 10800 1 EEST} - {1414706400 7200 0 EET} - {1427407200 10800 1 EEST} - {1446156000 7200 0 EET} - {1459461600 10800 1 EEST} - {1477605600 7200 0 EET} - {1490911200 10800 1 EEST} - {1509055200 7200 0 EET} - {1522360800 10800 1 EEST} - {1540504800 7200 0 EET} - {1553810400 10800 1 EEST} - {1571954400 7200 0 EET} - {1585260000 10800 1 EEST} - {1604008800 7200 0 EET} - {1616709600 10800 1 EEST} - {1635458400 7200 0 EET} - {1648764000 10800 1 EEST} - {1666908000 7200 0 EET} - {1680213600 10800 1 EEST} - {1698357600 7200 0 EET} - {1711663200 10800 1 EEST} - {1729807200 7200 0 EET} - {1743112800 10800 1 EEST} - {1761861600 7200 0 EET} - {1774562400 10800 1 EEST} - {1793311200 7200 0 EET} - {1806012000 10800 1 EEST} - {1824760800 7200 0 EET} - {1838066400 10800 1 EEST} - {1856210400 7200 0 EET} - {1869516000 10800 1 EEST} - {1887660000 7200 0 EET} - {1900965600 10800 1 EEST} - {1919109600 7200 0 EET} - {1932415200 10800 1 EEST} - {1951164000 7200 0 EET} - {1963864800 10800 1 EEST} - {1982613600 7200 0 EET} - {1995919200 10800 1 EEST} - {2014063200 7200 0 EET} - {2027368800 10800 1 EEST} - {2045512800 7200 0 EET} - {2058818400 10800 1 EEST} - {2076962400 7200 0 EET} - {2090268000 10800 1 EEST} - {2109016800 7200 0 EET} - {2121717600 10800 1 EEST} - {2140466400 7200 0 EET} - {2153167200 10800 1 EEST} - {2171916000 7200 0 EET} - {2185221600 10800 1 EEST} - {2203365600 7200 0 EET} - {2216671200 10800 1 EEST} - {2234815200 7200 0 EET} - {2248120800 10800 1 EEST} - {2266264800 7200 0 EET} - {2279570400 10800 1 EEST} - {2298319200 7200 0 EET} - {2311020000 10800 1 EEST} - {2329768800 7200 0 EET} - {2343074400 10800 1 EEST} - {2361218400 7200 0 EET} - {2374524000 10800 1 EEST} - {2392668000 7200 0 EET} - {2405973600 10800 1 EEST} - {2424117600 7200 0 EET} - {2437423200 10800 1 EEST} - {2455567200 7200 0 EET} - {2468872800 10800 1 EEST} - {2487621600 7200 0 EET} - {2500322400 10800 1 EEST} - {2519071200 7200 0 EET} - {2532376800 10800 1 EEST} - {2550520800 7200 0 EET} - {2563826400 10800 1 EEST} - {2581970400 7200 0 EET} - {2595276000 10800 1 EEST} - {2613420000 7200 0 EET} - {2626725600 10800 1 EEST} - {2645474400 7200 0 EET} - {2658175200 10800 1 EEST} - {2676924000 7200 0 EET} - {2689624800 10800 1 EEST} - {2708373600 7200 0 EET} - {2721679200 10800 1 EEST} - {2739823200 7200 0 EET} - {2753128800 10800 1 EEST} - {2771272800 7200 0 EET} - {2784578400 10800 1 EEST} - {2802722400 7200 0 EET} - {2816028000 10800 1 EEST} - {2834776800 7200 0 EET} - {2847477600 10800 1 EEST} - {2866226400 7200 0 EET} - {2879532000 10800 1 EEST} - {2897676000 7200 0 EET} - {2910981600 10800 1 EEST} - {2929125600 7200 0 EET} - {2942431200 10800 1 EEST} - {2960575200 7200 0 EET} - {2973880800 10800 1 EEST} - {2992629600 7200 0 EET} - {3005330400 10800 1 EEST} - {3024079200 7200 0 EET} - {3036780000 10800 1 EEST} - {3055528800 7200 0 EET} - {3068834400 10800 1 EEST} - {3086978400 7200 0 EET} - {3100284000 10800 1 EEST} - {3118428000 7200 0 EET} - {3131733600 10800 1 EEST} - {3149877600 7200 0 EET} - {3163183200 10800 1 EEST} - {3181932000 7200 0 EET} - {3194632800 10800 1 EEST} - {3213381600 7200 0 EET} - {3226687200 10800 1 EEST} - {3244831200 7200 0 EET} - {3258136800 10800 1 EEST} - {3276280800 7200 0 EET} - {3289586400 10800 1 EEST} - {3307730400 7200 0 EET} - {3321036000 10800 1 EEST} - {3339180000 7200 0 EET} - {3352485600 10800 1 EEST} - {3371234400 7200 0 EET} - {3383935200 10800 1 EEST} - {3402684000 7200 0 EET} - {3415989600 10800 1 EEST} - {3434133600 7200 0 EET} - {3447439200 10800 1 EEST} - {3465583200 7200 0 EET} - {3478888800 10800 1 EEST} - {3497032800 7200 0 EET} - {3510338400 10800 1 EEST} - {3529087200 7200 0 EET} - {3541788000 10800 1 EEST} - {3560536800 7200 0 EET} - {3573237600 10800 1 EEST} - {3591986400 7200 0 EET} - {3605292000 10800 1 EEST} - {3623436000 7200 0 EET} - {3636741600 10800 1 EEST} - {3654885600 7200 0 EET} - {3668191200 10800 1 EEST} - {3686335200 7200 0 EET} - {3699640800 10800 1 EEST} - {3718389600 7200 0 EET} - {3731090400 10800 1 EEST} - {3749839200 7200 0 EET} - {3763144800 10800 1 EEST} - {3781288800 7200 0 EET} - {3794594400 10800 1 EEST} - {3812738400 7200 0 EET} - {3826044000 10800 1 EEST} - {3844188000 7200 0 EET} - {3857493600 10800 1 EEST} - {3876242400 7200 0 EET} - {3888943200 10800 1 EEST} - {3907692000 7200 0 EET} - {3920392800 10800 1 EEST} - {3939141600 7200 0 EET} - {3952447200 10800 1 EEST} - {3970591200 7200 0 EET} - {3983896800 10800 1 EEST} - {4002040800 7200 0 EET} - {4015346400 10800 1 EEST} - {4033490400 7200 0 EET} - {4046796000 10800 1 EEST} - {4065544800 7200 0 EET} - {4078245600 10800 1 EEST} - {4096994400 7200 0 EET} + {1351202400 10800 0 AST} } diff --git a/library/tzdata/Asia/Dili b/library/tzdata/Asia/Dili index 36910fd..f783557 100644 --- a/library/tzdata/Asia/Dili +++ b/library/tzdata/Asia/Dili @@ -5,6 +5,6 @@ set TZData(:Asia/Dili) { {-1830414140 28800 0 TLT} {-879152400 32400 0 JST} {-766054800 32400 0 TLT} - {199897200 28800 0 CIT} + {199897200 28800 0 WITA} {969120000 32400 0 TLT} } diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index a0636e2..7d62a96 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -102,177 +102,177 @@ set TZData(:Asia/Gaza) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index a8a9019..1333d5a 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -101,177 +101,177 @@ set TZData(:Asia/Hebron) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Jakarta b/library/tzdata/Asia/Jakarta index 27033e8..75cd659 100644 --- a/library/tzdata/Asia/Jakarta +++ b/library/tzdata/Asia/Jakarta @@ -2,12 +2,12 @@ set TZData(:Asia/Jakarta) { {-9223372036854775808 25632 0 LMT} - {-3231299232 25632 0 JMT} + {-3231299232 25632 0 BMT} {-1451719200 26400 0 JAVT} - {-1172906400 27000 0 WIT} + {-1172906400 27000 0 WIB} {-876641400 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 25200 0 WIB} } diff --git a/library/tzdata/Asia/Jayapura b/library/tzdata/Asia/Jayapura index 893da8b..a71228f 100644 --- a/library/tzdata/Asia/Jayapura +++ b/library/tzdata/Asia/Jayapura @@ -2,7 +2,7 @@ set TZData(:Asia/Jayapura) { {-9223372036854775808 33768 0 LMT} - {-1172913768 32400 0 EIT} + {-1172913768 32400 0 WIT} {-799491600 34200 0 CST} - {-189423000 32400 0 EIT} + {-189423000 32400 0 WIT} } diff --git a/library/tzdata/Asia/Makassar b/library/tzdata/Asia/Makassar index aa604b4..be947f3 100644 --- a/library/tzdata/Asia/Makassar +++ b/library/tzdata/Asia/Makassar @@ -3,7 +3,7 @@ set TZData(:Asia/Makassar) { {-9223372036854775808 28656 0 LMT} {-1577951856 28656 0 MMT} - {-1172908656 28800 0 CIT} + {-1172908656 28800 0 WITA} {-880272000 32400 0 JST} - {-766054800 28800 0 CIT} + {-766054800 28800 0 WITA} } diff --git a/library/tzdata/Asia/Pontianak b/library/tzdata/Asia/Pontianak index f3567dd..728b552 100644 --- a/library/tzdata/Asia/Pontianak +++ b/library/tzdata/Asia/Pontianak @@ -3,11 +3,11 @@ set TZData(:Asia/Pontianak) { {-9223372036854775808 26240 0 LMT} {-1946186240 26240 0 PMT} - {-1172906240 27000 0 WIT} + {-1172906240 27000 0 WIB} {-881220600 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 28800 0 CIT} - {567964800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 28800 0 WITA} + {567964800 25200 0 WIB} } diff --git a/library/tzdata/Europe/Vaduz b/library/tzdata/Europe/Vaduz index 3118331..095e018 100644 --- a/library/tzdata/Europe/Vaduz +++ b/library/tzdata/Europe/Vaduz @@ -1,245 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Vaduz) { - {-9223372036854775808 2284 0 LMT} - {-2385247084 3600 0 CET} - {347151600 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Zurich)]} { + LoadTimeZoneFile Europe/Zurich } +set TZData(:Europe/Vaduz) $TZData(:Europe/Zurich) diff --git a/library/tzdata/Europe/Zurich b/library/tzdata/Europe/Zurich index 33831c3..87a20db 100644 --- a/library/tzdata/Europe/Zurich +++ b/library/tzdata/Europe/Zurich @@ -2,8 +2,8 @@ set TZData(:Europe/Zurich) { {-9223372036854775808 2048 0 LMT} - {-3827954048 1784 0 BMT} - {-2385246584 3600 0 CET} + {-3675198848 1786 0 BMT} + {-2385246586 3600 0 CET} {-904435200 7200 1 CEST} {-891129600 3600 0 CET} {-872985600 7200 1 CEST} diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index bfcaa03..454ee87 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -15,11 +15,11 @@ set TZData(:Pacific/Fiji) { {1327154400 43200 0 FJT} {1350741600 46800 1 FJST} {1358604000 43200 0 FJT} - {1382191200 46800 1 FJST} + {1382796000 46800 1 FJST} {1390053600 43200 0 FJT} - {1413640800 46800 1 FJST} + {1414245600 46800 1 FJST} {1421503200 43200 0 FJT} - {1445090400 46800 1 FJST} + {1445695200 46800 1 FJST} {1453557600 43200 0 FJT} {1477144800 46800 1 FJST} {1485007200 43200 0 FJT} @@ -27,9 +27,9 @@ set TZData(:Pacific/Fiji) { {1516456800 43200 0 FJT} {1540044000 46800 1 FJST} {1547906400 43200 0 FJT} - {1571493600 46800 1 FJST} + {1572098400 46800 1 FJST} {1579356000 43200 0 FJT} - {1602943200 46800 1 FJST} + {1603548000 46800 1 FJST} {1611410400 43200 0 FJT} {1634997600 46800 1 FJST} {1642860000 43200 0 FJT} @@ -37,11 +37,11 @@ set TZData(:Pacific/Fiji) { {1674309600 43200 0 FJT} {1697896800 46800 1 FJST} {1705759200 43200 0 FJT} - {1729346400 46800 1 FJST} + {1729951200 46800 1 FJST} {1737208800 43200 0 FJT} - {1760796000 46800 1 FJST} + {1761400800 46800 1 FJST} {1768658400 43200 0 FJT} - {1792245600 46800 1 FJST} + {1792850400 46800 1 FJST} {1800712800 43200 0 FJT} {1824300000 46800 1 FJST} {1832162400 43200 0 FJT} @@ -49,9 +49,9 @@ set TZData(:Pacific/Fiji) { {1863612000 43200 0 FJT} {1887199200 46800 1 FJST} {1895061600 43200 0 FJT} - {1918648800 46800 1 FJST} + {1919253600 46800 1 FJST} {1926511200 43200 0 FJT} - {1950098400 46800 1 FJST} + {1950703200 46800 1 FJST} {1957960800 43200 0 FJT} {1982152800 46800 1 FJST} {1990015200 43200 0 FJT} @@ -61,9 +61,9 @@ set TZData(:Pacific/Fiji) { {2052914400 43200 0 FJT} {2076501600 46800 1 FJST} {2084364000 43200 0 FJT} - {2107951200 46800 1 FJST} + {2108556000 46800 1 FJST} {2115813600 43200 0 FJT} - {2139400800 46800 1 FJST} + {2140005600 46800 1 FJST} {2147868000 43200 0 FJT} {2171455200 46800 1 FJST} {2179317600 43200 0 FJT} @@ -71,11 +71,11 @@ set TZData(:Pacific/Fiji) { {2210767200 43200 0 FJT} {2234354400 46800 1 FJST} {2242216800 43200 0 FJT} - {2265804000 46800 1 FJST} + {2266408800 46800 1 FJST} {2273666400 43200 0 FJT} - {2297253600 46800 1 FJST} + {2297858400 46800 1 FJST} {2305116000 43200 0 FJT} - {2328703200 46800 1 FJST} + {2329308000 46800 1 FJST} {2337170400 43200 0 FJT} {2360757600 46800 1 FJST} {2368620000 43200 0 FJT} @@ -83,9 +83,9 @@ set TZData(:Pacific/Fiji) { {2400069600 43200 0 FJT} {2423656800 46800 1 FJST} {2431519200 43200 0 FJT} - {2455106400 46800 1 FJST} + {2455711200 46800 1 FJST} {2462968800 43200 0 FJT} - {2486556000 46800 1 FJST} + {2487160800 46800 1 FJST} {2495023200 43200 0 FJT} {2518610400 46800 1 FJST} {2526472800 43200 0 FJT} @@ -93,11 +93,11 @@ set TZData(:Pacific/Fiji) { {2557922400 43200 0 FJT} {2581509600 46800 1 FJST} {2589372000 43200 0 FJT} - {2612959200 46800 1 FJST} + {2613564000 46800 1 FJST} {2620821600 43200 0 FJT} - {2644408800 46800 1 FJST} + {2645013600 46800 1 FJST} {2652271200 43200 0 FJT} - {2675858400 46800 1 FJST} + {2676463200 46800 1 FJST} {2684325600 43200 0 FJT} {2707912800 46800 1 FJST} {2715775200 43200 0 FJT} @@ -105,9 +105,9 @@ set TZData(:Pacific/Fiji) { {2747224800 43200 0 FJT} {2770812000 46800 1 FJST} {2778674400 43200 0 FJT} - {2802261600 46800 1 FJST} + {2802866400 46800 1 FJST} {2810124000 43200 0 FJT} - {2833711200 46800 1 FJST} + {2834316000 46800 1 FJST} {2841573600 43200 0 FJT} {2865765600 46800 1 FJST} {2873628000 43200 0 FJT} @@ -117,9 +117,9 @@ set TZData(:Pacific/Fiji) { {2936527200 43200 0 FJT} {2960114400 46800 1 FJST} {2967976800 43200 0 FJT} - {2991564000 46800 1 FJST} + {2992168800 46800 1 FJST} {2999426400 43200 0 FJT} - {3023013600 46800 1 FJST} + {3023618400 46800 1 FJST} {3031480800 43200 0 FJT} {3055068000 46800 1 FJST} {3062930400 43200 0 FJT} @@ -127,11 +127,11 @@ set TZData(:Pacific/Fiji) { {3094380000 43200 0 FJT} {3117967200 46800 1 FJST} {3125829600 43200 0 FJT} - {3149416800 46800 1 FJST} + {3150021600 46800 1 FJST} {3157279200 43200 0 FJT} - {3180866400 46800 1 FJST} + {3181471200 46800 1 FJST} {3188728800 43200 0 FJT} - {3212316000 46800 1 FJST} + {3212920800 46800 1 FJST} {3220783200 43200 0 FJT} {3244370400 46800 1 FJST} {3252232800 43200 0 FJT} @@ -139,9 +139,9 @@ set TZData(:Pacific/Fiji) { {3283682400 43200 0 FJT} {3307269600 46800 1 FJST} {3315132000 43200 0 FJT} - {3338719200 46800 1 FJST} + {3339324000 46800 1 FJST} {3346581600 43200 0 FJT} - {3370168800 46800 1 FJST} + {3370773600 46800 1 FJST} {3378636000 43200 0 FJT} {3402223200 46800 1 FJST} {3410085600 43200 0 FJT} @@ -149,11 +149,11 @@ set TZData(:Pacific/Fiji) { {3441535200 43200 0 FJT} {3465122400 46800 1 FJST} {3472984800 43200 0 FJT} - {3496572000 46800 1 FJST} + {3497176800 46800 1 FJST} {3504434400 43200 0 FJT} - {3528021600 46800 1 FJST} + {3528626400 46800 1 FJST} {3535884000 43200 0 FJT} - {3559471200 46800 1 FJST} + {3560076000 46800 1 FJST} {3567938400 43200 0 FJT} {3591525600 46800 1 FJST} {3599388000 43200 0 FJT} @@ -161,9 +161,9 @@ set TZData(:Pacific/Fiji) { {3630837600 43200 0 FJT} {3654424800 46800 1 FJST} {3662287200 43200 0 FJT} - {3685874400 46800 1 FJST} + {3686479200 46800 1 FJST} {3693736800 43200 0 FJT} - {3717324000 46800 1 FJST} + {3717928800 46800 1 FJST} {3725186400 43200 0 FJT} {3749378400 46800 1 FJST} {3757240800 43200 0 FJT} @@ -173,9 +173,9 @@ set TZData(:Pacific/Fiji) { {3820140000 43200 0 FJT} {3843727200 46800 1 FJST} {3851589600 43200 0 FJT} - {3875176800 46800 1 FJST} + {3875781600 46800 1 FJST} {3883039200 43200 0 FJT} - {3906626400 46800 1 FJST} + {3907231200 46800 1 FJST} {3915093600 43200 0 FJT} {3938680800 46800 1 FJST} {3946543200 43200 0 FJT} @@ -183,9 +183,9 @@ set TZData(:Pacific/Fiji) { {3977992800 43200 0 FJT} {4001580000 46800 1 FJST} {4009442400 43200 0 FJT} - {4033029600 46800 1 FJST} + {4033634400 46800 1 FJST} {4040892000 43200 0 FJT} - {4064479200 46800 1 FJST} + {4065084000 46800 1 FJST} {4072341600 43200 0 FJT} - {4095928800 46800 1 FJST} + {4096533600 46800 1 FJST} } diff --git a/library/tzdata/Pacific/Johnston b/library/tzdata/Pacific/Johnston index 7f9fee4..21ab39a 100644 --- a/library/tzdata/Pacific/Johnston +++ b/library/tzdata/Pacific/Johnston @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Johnston) { - {-9223372036854775808 -36000 0 HST} +if {![info exists TZData(Pacific/Honolulu)]} { + LoadTimeZoneFile Pacific/Honolulu } +set TZData(:Pacific/Johnston) $TZData(:Pacific/Honolulu) -- cgit v0.12 From 40fefcafadb6a8be490c3ec0be0c6ed724cd1845 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 5 Oct 2013 16:28:52 +0000 Subject: Advance to tzdata2013g --- library/tzdata/Africa/Casablanca | 284 ++++++++++++------------------ library/tzdata/Africa/Juba | 40 +---- library/tzdata/America/Anguilla | 7 +- library/tzdata/America/Araguaina | 174 +----------------- library/tzdata/America/Argentina/San_Luis | 2 +- library/tzdata/America/Aruba | 8 +- library/tzdata/America/Cayman | 4 +- library/tzdata/America/Dominica | 7 +- library/tzdata/America/Grand_Turk | 4 +- library/tzdata/America/Grenada | 7 +- library/tzdata/America/Guadeloupe | 7 +- library/tzdata/America/Jamaica | 6 +- library/tzdata/America/Marigot | 6 +- library/tzdata/America/Montserrat | 7 +- library/tzdata/America/St_Barthelemy | 6 +- library/tzdata/America/St_Kitts | 7 +- library/tzdata/America/St_Lucia | 8 +- library/tzdata/America/St_Thomas | 7 +- library/tzdata/America/St_Vincent | 8 +- library/tzdata/America/Tortola | 7 +- library/tzdata/America/Virgin | 6 +- library/tzdata/Antarctica/McMurdo | 258 +-------------------------- library/tzdata/Antarctica/South_Pole | 6 +- library/tzdata/Asia/Amman | 175 +----------------- library/tzdata/Asia/Dili | 2 +- library/tzdata/Asia/Gaza | 174 +++++++++--------- library/tzdata/Asia/Hebron | 174 +++++++++--------- library/tzdata/Asia/Jakarta | 12 +- library/tzdata/Asia/Jayapura | 4 +- library/tzdata/Asia/Makassar | 4 +- library/tzdata/Asia/Pontianak | 12 +- library/tzdata/Europe/Vaduz | 246 +------------------------- library/tzdata/Europe/Zurich | 4 +- library/tzdata/Pacific/Fiji | 78 ++++---- library/tzdata/Pacific/Johnston | 6 +- 35 files changed, 413 insertions(+), 1354 deletions(-) diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 757007c..dec2778 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -36,189 +36,133 @@ set TZData(:Africa/Casablanca) { {1367114400 3600 1 WEST} {1373162400 0 0 WET} {1376100000 3600 1 WEST} - {1380420000 0 0 WET} - {1398564000 3600 1 WEST} + {1382839200 0 0 WET} + {1396144800 3600 1 WEST} {1404007200 0 0 WET} {1406599200 3600 1 WEST} - {1411869600 0 0 WET} - {1430013600 3600 1 WEST} + {1414288800 0 0 WET} + {1427594400 3600 1 WEST} {1434592800 0 0 WET} {1437184800 3600 1 WEST} - {1443319200 0 0 WET} - {1461463200 3600 1 WEST} + {1445738400 0 0 WET} + {1459044000 3600 1 WEST} {1465264800 0 0 WET} {1467856800 3600 1 WEST} - {1474768800 0 0 WET} - {1493517600 3600 1 WEST} + {1477792800 0 0 WET} + {1490493600 3600 1 WEST} {1495850400 0 0 WET} {1498442400 3600 1 WEST} - {1506218400 0 0 WET} - {1524967200 3600 1 WEST} + {1509242400 0 0 WET} + {1521943200 3600 1 WEST} {1526436000 0 0 WET} {1529028000 3600 1 WEST} - {1538272800 0 0 WET} - {1556416800 3600 1 WEST} + {1540692000 0 0 WET} + {1553997600 3600 1 WEST} {1557108000 0 0 WET} {1559700000 3600 1 WEST} - {1569722400 0 0 WET} + {1572141600 0 0 WET} + {1585447200 3600 1 WEST} + {1587693600 0 0 WET} {1590285600 3600 1 WEST} - {1601172000 0 0 WET} + {1603591200 0 0 WET} + {1616896800 3600 1 WEST} + {1618279200 0 0 WET} {1620871200 3600 1 WEST} - {1632621600 0 0 WET} + {1635645600 0 0 WET} + {1648346400 3600 1 WEST} + {1648951200 0 0 WET} {1651543200 3600 1 WEST} - {1664071200 0 0 WET} - {1682820000 3600 1 WEST} - {1695520800 0 0 WET} - {1714269600 3600 1 WEST} - {1727575200 0 0 WET} - {1745719200 3600 1 WEST} - {1759024800 0 0 WET} - {1777168800 3600 1 WEST} - {1790474400 0 0 WET} - {1808618400 3600 1 WEST} - {1821924000 0 0 WET} - {1840672800 3600 1 WEST} - {1853373600 0 0 WET} - {1872122400 3600 1 WEST} - {1885428000 0 0 WET} - {1903572000 3600 1 WEST} - {1916877600 0 0 WET} - {1935021600 3600 1 WEST} - {1948327200 0 0 WET} - {1966471200 3600 1 WEST} - {1979776800 0 0 WET} - {1997920800 3600 1 WEST} - {2011226400 0 0 WET} - {2029975200 3600 1 WEST} - {2042676000 0 0 WET} - {2061424800 3600 1 WEST} - {2074730400 0 0 WET} - {2092874400 3600 1 WEST} - {2106180000 0 0 WET} - {2124324000 3600 1 WEST} - {2137629600 0 0 WET} - {2155773600 3600 1 WEST} - {2169079200 0 0 WET} - {2187223200 3600 1 WEST} - {2200528800 0 0 WET} - {2219277600 3600 1 WEST} - {2232583200 0 0 WET} - {2250727200 3600 1 WEST} - {2264032800 0 0 WET} - {2282176800 3600 1 WEST} - {2295482400 0 0 WET} - {2313626400 3600 1 WEST} - {2326932000 0 0 WET} - {2345076000 3600 1 WEST} - {2358381600 0 0 WET} - {2377130400 3600 1 WEST} - {2389831200 0 0 WET} - {2408580000 3600 1 WEST} - {2421885600 0 0 WET} - {2440029600 3600 1 WEST} - {2453335200 0 0 WET} - {2471479200 3600 1 WEST} - {2484784800 0 0 WET} - {2502928800 3600 1 WEST} - {2516234400 0 0 WET} - {2534378400 3600 1 WEST} - {2547684000 0 0 WET} - {2566432800 3600 1 WEST} - {2579133600 0 0 WET} - {2597882400 3600 1 WEST} - {2611188000 0 0 WET} - {2629332000 3600 1 WEST} - {2642637600 0 0 WET} - {2660781600 3600 1 WEST} - {2674087200 0 0 WET} - {2692231200 3600 1 WEST} - {2705536800 0 0 WET} - {2724285600 3600 1 WEST} - {2736986400 0 0 WET} - {2755735200 3600 1 WEST} - {2769040800 0 0 WET} - {2787184800 3600 1 WEST} - {2800490400 0 0 WET} - {2818634400 3600 1 WEST} - {2831940000 0 0 WET} - {2850084000 3600 1 WEST} - {2863389600 0 0 WET} - {2881533600 3600 1 WEST} - {2894839200 0 0 WET} - {2913588000 3600 1 WEST} - {2926288800 0 0 WET} - {2945037600 3600 1 WEST} - {2958343200 0 0 WET} - {2976487200 3600 1 WEST} - {2989792800 0 0 WET} - {3007936800 3600 1 WEST} - {3021242400 0 0 WET} - {3039386400 3600 1 WEST} - {3052692000 0 0 WET} - {3070836000 3600 1 WEST} - {3084141600 0 0 WET} - {3102890400 3600 1 WEST} - {3116196000 0 0 WET} - {3134340000 3600 1 WEST} - {3147645600 0 0 WET} - {3165789600 3600 1 WEST} - {3179095200 0 0 WET} - {3197239200 3600 1 WEST} - {3210544800 0 0 WET} - {3228688800 3600 1 WEST} - {3241994400 0 0 WET} - {3260743200 3600 1 WEST} - {3273444000 0 0 WET} - {3292192800 3600 1 WEST} - {3305498400 0 0 WET} - {3323642400 3600 1 WEST} - {3336948000 0 0 WET} - {3355092000 3600 1 WEST} - {3368397600 0 0 WET} - {3386541600 3600 1 WEST} - {3399847200 0 0 WET} - {3417991200 3600 1 WEST} - {3431296800 0 0 WET} - {3450045600 3600 1 WEST} - {3462746400 0 0 WET} - {3481495200 3600 1 WEST} - {3494800800 0 0 WET} - {3512944800 3600 1 WEST} - {3526250400 0 0 WET} - {3544394400 3600 1 WEST} - {3557700000 0 0 WET} - {3575844000 3600 1 WEST} - {3589149600 0 0 WET} - {3607898400 3600 1 WEST} - {3620599200 0 0 WET} - {3639348000 3600 1 WEST} - {3652653600 0 0 WET} - {3670797600 3600 1 WEST} - {3684103200 0 0 WET} - {3702247200 3600 1 WEST} - {3715552800 0 0 WET} - {3733696800 3600 1 WEST} - {3747002400 0 0 WET} - {3765146400 3600 1 WEST} - {3778452000 0 0 WET} - {3797200800 3600 1 WEST} - {3809901600 0 0 WET} - {3828650400 3600 1 WEST} - {3841956000 0 0 WET} - {3860100000 3600 1 WEST} - {3873405600 0 0 WET} - {3891549600 3600 1 WEST} - {3904855200 0 0 WET} - {3922999200 3600 1 WEST} - {3936304800 0 0 WET} - {3954448800 3600 1 WEST} - {3967754400 0 0 WET} - {3986503200 3600 1 WEST} - {3999808800 0 0 WET} - {4017952800 3600 1 WEST} - {4031258400 0 0 WET} - {4049402400 3600 1 WEST} - {4062708000 0 0 WET} - {4080852000 3600 1 WEST} - {4094157600 0 0 WET} + {1667095200 0 0 WET} + {1682128800 3600 1 WEST} + {1698544800 0 0 WET} + {1712714400 3600 1 WEST} + {1729994400 0 0 WET} + {1743386400 3600 1 WEST} + {1761444000 0 0 WET} + {1774749600 3600 1 WEST} + {1792893600 0 0 WET} + {1806199200 3600 1 WEST} + {1824948000 0 0 WET} + {1837648800 3600 1 WEST} + {1856397600 0 0 WET} + {1869098400 3600 1 WEST} + {1887847200 0 0 WET} + {1901152800 3600 1 WEST} + {1919296800 0 0 WET} + {1932602400 3600 1 WEST} + {1950746400 0 0 WET} + {1964052000 3600 1 WEST} + {1982800800 0 0 WET} + {1995501600 3600 1 WEST} + {2014250400 0 0 WET} + {2026951200 3600 1 WEST} + {2045700000 0 0 WET} + {2058400800 3600 1 WEST} + {2077149600 0 0 WET} + {2090455200 3600 1 WEST} + {2108167200 0 0 WET} + {2121904800 3600 1 WEST} + {2138839200 0 0 WET} + {2153354400 3600 1 WEST} + {2184800400 3600 1 WEST} + {2216250000 3600 1 WEST} + {2248304400 3600 1 WEST} + {2279754000 3600 1 WEST} + {2311203600 3600 1 WEST} + {2342653200 3600 1 WEST} + {2374102800 3600 1 WEST} + {2405552400 3600 1 WEST} + {2437606800 3600 1 WEST} + {2469056400 3600 1 WEST} + {2500506000 3600 1 WEST} + {2531955600 3600 1 WEST} + {2563405200 3600 1 WEST} + {2595459600 3600 1 WEST} + {2626909200 3600 1 WEST} + {2658358800 3600 1 WEST} + {2689808400 3600 1 WEST} + {2721258000 3600 1 WEST} + {2752707600 3600 1 WEST} + {2784762000 3600 1 WEST} + {2816211600 3600 1 WEST} + {2847661200 3600 1 WEST} + {2879110800 3600 1 WEST} + {2910560400 3600 1 WEST} + {2942010000 3600 1 WEST} + {2974064400 3600 1 WEST} + {3005514000 3600 1 WEST} + {3036963600 3600 1 WEST} + {3068413200 3600 1 WEST} + {3099862800 3600 1 WEST} + {3131917200 3600 1 WEST} + {3163366800 3600 1 WEST} + {3194816400 3600 1 WEST} + {3226266000 3600 1 WEST} + {3257715600 3600 1 WEST} + {3289165200 3600 1 WEST} + {3321219600 3600 1 WEST} + {3352669200 3600 1 WEST} + {3384118800 3600 1 WEST} + {3415568400 3600 1 WEST} + {3447018000 3600 1 WEST} + {3479072400 3600 1 WEST} + {3510522000 3600 1 WEST} + {3541971600 3600 1 WEST} + {3573421200 3600 1 WEST} + {3604870800 3600 1 WEST} + {3636320400 3600 1 WEST} + {3668374800 3600 1 WEST} + {3699824400 3600 1 WEST} + {3731274000 3600 1 WEST} + {3762723600 3600 1 WEST} + {3794173200 3600 1 WEST} + {3825622800 3600 1 WEST} + {3857677200 3600 1 WEST} + {3889126800 3600 1 WEST} + {3920576400 3600 1 WEST} + {3952026000 3600 1 WEST} + {3983475600 3600 1 WEST} + {4015530000 3600 1 WEST} + {4046979600 3600 1 WEST} + {4078429200 3600 1 WEST} } diff --git a/library/tzdata/Africa/Juba b/library/tzdata/Africa/Juba index 7495981..40551f2 100644 --- a/library/tzdata/Africa/Juba +++ b/library/tzdata/Africa/Juba @@ -1,39 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Africa/Juba) { - {-9223372036854775808 7584 0 LMT} - {-1230775584 7200 0 CAT} - {10360800 10800 1 CAST} - {24786000 7200 0 CAT} - {41810400 10800 1 CAST} - {56322000 7200 0 CAT} - {73432800 10800 1 CAST} - {87944400 7200 0 CAT} - {104882400 10800 1 CAST} - {119480400 7200 0 CAT} - {136332000 10800 1 CAST} - {151016400 7200 0 CAT} - {167781600 10800 1 CAST} - {182552400 7200 0 CAT} - {199231200 10800 1 CAST} - {214174800 7200 0 CAT} - {230680800 10800 1 CAST} - {245710800 7200 0 CAT} - {262735200 10800 1 CAST} - {277246800 7200 0 CAT} - {294184800 10800 1 CAST} - {308782800 7200 0 CAT} - {325634400 10800 1 CAST} - {340405200 7200 0 CAT} - {357084000 10800 1 CAST} - {371941200 7200 0 CAT} - {388533600 10800 1 CAST} - {403477200 7200 0 CAT} - {419983200 10800 1 CAST} - {435013200 7200 0 CAT} - {452037600 10800 1 CAST} - {466635600 7200 0 CAT} - {483487200 10800 1 CAST} - {498171600 7200 0 CAT} - {947930400 10800 0 EAT} +if {![info exists TZData(Africa/Khartoum)]} { + LoadTimeZoneFile Africa/Khartoum } +set TZData(:Africa/Juba) $TZData(:Africa/Khartoum) diff --git a/library/tzdata/America/Anguilla b/library/tzdata/America/Anguilla index cfe7483..39a0d18 100644 --- a/library/tzdata/America/Anguilla +++ b/library/tzdata/America/Anguilla @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Anguilla) { - {-9223372036854775808 -15136 0 LMT} - {-1825098464 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Anguilla) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Araguaina b/library/tzdata/America/Araguaina index dc1b543..e4a0d52 100644 --- a/library/tzdata/America/Araguaina +++ b/library/tzdata/America/Araguaina @@ -56,177 +56,5 @@ set TZData(:America/Araguaina) { {1064368800 -10800 0 BRT} {1350788400 -7200 0 BRST} {1361066400 -10800 0 BRT} - {1382238000 -7200 1 BRST} - {1392516000 -10800 0 BRT} - {1413687600 -7200 1 BRST} - {1424570400 -10800 0 BRT} - {1445137200 -7200 1 BRST} - {1456020000 -10800 0 BRT} - {1476586800 -7200 1 BRST} - {1487469600 -10800 0 BRT} - {1508036400 -7200 1 BRST} - {1518919200 -10800 0 BRT} - {1540090800 -7200 1 BRST} - {1550368800 -10800 0 BRT} - {1571540400 -7200 1 BRST} - {1581818400 -10800 0 BRT} - {1602990000 -7200 1 BRST} - {1613872800 -10800 0 BRT} - {1634439600 -7200 1 BRST} - {1645322400 -10800 0 BRT} - {1665889200 -7200 1 BRST} - {1677376800 -10800 0 BRT} - {1697338800 -7200 1 BRST} - {1708221600 -10800 0 BRT} - {1729393200 -7200 1 BRST} - {1739671200 -10800 0 BRT} - {1760842800 -7200 1 BRST} - {1771725600 -10800 0 BRT} - {1792292400 -7200 1 BRST} - {1803175200 -10800 0 BRT} - {1823742000 -7200 1 BRST} - {1834624800 -10800 0 BRT} - {1855191600 -7200 1 BRST} - {1866074400 -10800 0 BRT} - {1887246000 -7200 1 BRST} - {1897524000 -10800 0 BRT} - {1918695600 -7200 1 BRST} - {1928973600 -10800 0 BRT} - {1950145200 -7200 1 BRST} - {1960423200 -10800 0 BRT} - {1981594800 -7200 1 BRST} - {1992477600 -10800 0 BRT} - {2013044400 -7200 1 BRST} - {2024532000 -10800 0 BRT} - {2044494000 -7200 1 BRST} - {2055376800 -10800 0 BRT} - {2076548400 -7200 1 BRST} - {2086826400 -10800 0 BRT} - {2107998000 -7200 1 BRST} - {2118880800 -10800 0 BRT} - {2139447600 -7200 1 BRST} - {2150330400 -10800 0 BRT} - {2170897200 -7200 1 BRST} - {2181780000 -10800 0 BRT} - {2202346800 -7200 1 BRST} - {2213229600 -10800 0 BRT} - {2234401200 -7200 1 BRST} - {2244679200 -10800 0 BRT} - {2265850800 -7200 1 BRST} - {2276128800 -10800 0 BRT} - {2297300400 -7200 1 BRST} - {2307578400 -10800 0 BRT} - {2328750000 -7200 1 BRST} - {2339632800 -10800 0 BRT} - {2360199600 -7200 1 BRST} - {2371082400 -10800 0 BRT} - {2391649200 -7200 1 BRST} - {2402532000 -10800 0 BRT} - {2423703600 -7200 1 BRST} - {2433981600 -10800 0 BRT} - {2455153200 -7200 1 BRST} - {2465431200 -10800 0 BRT} - {2486602800 -7200 1 BRST} - {2497485600 -10800 0 BRT} - {2518052400 -7200 1 BRST} - {2528935200 -10800 0 BRT} - {2549502000 -7200 1 BRST} - {2560384800 -10800 0 BRT} - {2580951600 -7200 1 BRST} - {2591834400 -10800 0 BRT} - {2613006000 -7200 1 BRST} - {2623284000 -10800 0 BRT} - {2644455600 -7200 1 BRST} - {2654733600 -10800 0 BRT} - {2675905200 -7200 1 BRST} - {2686788000 -10800 0 BRT} - {2707354800 -7200 1 BRST} - {2718237600 -10800 0 BRT} - {2738804400 -7200 1 BRST} - {2749687200 -10800 0 BRT} - {2770858800 -7200 1 BRST} - {2781136800 -10800 0 BRT} - {2802308400 -7200 1 BRST} - {2812586400 -10800 0 BRT} - {2833758000 -7200 1 BRST} - {2844036000 -10800 0 BRT} - {2865207600 -7200 1 BRST} - {2876090400 -10800 0 BRT} - {2896657200 -7200 1 BRST} - {2907540000 -10800 0 BRT} - {2928106800 -7200 1 BRST} - {2938989600 -10800 0 BRT} - {2960161200 -7200 1 BRST} - {2970439200 -10800 0 BRT} - {2991610800 -7200 1 BRST} - {3001888800 -10800 0 BRT} - {3023060400 -7200 1 BRST} - {3033943200 -10800 0 BRT} - {3054510000 -7200 1 BRST} - {3065392800 -10800 0 BRT} - {3085959600 -7200 1 BRST} - {3096842400 -10800 0 BRT} - {3118014000 -7200 1 BRST} - {3128292000 -10800 0 BRT} - {3149463600 -7200 1 BRST} - {3159741600 -10800 0 BRT} - {3180913200 -7200 1 BRST} - {3191191200 -10800 0 BRT} - {3212362800 -7200 1 BRST} - {3223245600 -10800 0 BRT} - {3243812400 -7200 1 BRST} - {3254695200 -10800 0 BRT} - {3275262000 -7200 1 BRST} - {3286144800 -10800 0 BRT} - {3307316400 -7200 1 BRST} - {3317594400 -10800 0 BRT} - {3338766000 -7200 1 BRST} - {3349044000 -10800 0 BRT} - {3370215600 -7200 1 BRST} - {3381098400 -10800 0 BRT} - {3401665200 -7200 1 BRST} - {3412548000 -10800 0 BRT} - {3433114800 -7200 1 BRST} - {3443997600 -10800 0 BRT} - {3464564400 -7200 1 BRST} - {3475447200 -10800 0 BRT} - {3496618800 -7200 1 BRST} - {3506896800 -10800 0 BRT} - {3528068400 -7200 1 BRST} - {3538346400 -10800 0 BRT} - {3559518000 -7200 1 BRST} - {3570400800 -10800 0 BRT} - {3590967600 -7200 1 BRST} - {3601850400 -10800 0 BRT} - {3622417200 -7200 1 BRST} - {3633300000 -10800 0 BRT} - {3654471600 -7200 1 BRST} - {3664749600 -10800 0 BRT} - {3685921200 -7200 1 BRST} - {3696199200 -10800 0 BRT} - {3717370800 -7200 1 BRST} - {3727648800 -10800 0 BRT} - {3748820400 -7200 1 BRST} - {3759703200 -10800 0 BRT} - {3780270000 -7200 1 BRST} - {3791152800 -10800 0 BRT} - {3811719600 -7200 1 BRST} - {3822602400 -10800 0 BRT} - {3843774000 -7200 1 BRST} - {3854052000 -10800 0 BRT} - {3875223600 -7200 1 BRST} - {3885501600 -10800 0 BRT} - {3906673200 -7200 1 BRST} - {3917556000 -10800 0 BRT} - {3938122800 -7200 1 BRST} - {3949005600 -10800 0 BRT} - {3969572400 -7200 1 BRST} - {3980455200 -10800 0 BRT} - {4001626800 -7200 1 BRST} - {4011904800 -10800 0 BRT} - {4033076400 -7200 1 BRST} - {4043354400 -10800 0 BRT} - {4064526000 -7200 1 BRST} - {4074804000 -10800 0 BRT} - {4095975600 -7200 1 BRST} + {1378000800 -10800 0 BRT} } diff --git a/library/tzdata/America/Argentina/San_Luis b/library/tzdata/America/Argentina/San_Luis index bec1554..8ca55d7 100644 --- a/library/tzdata/America/Argentina/San_Luis +++ b/library/tzdata/America/Argentina/San_Luis @@ -64,5 +64,5 @@ set TZData(:America/Argentina/San_Luis) { {1205031600 -14400 0 WART} {1223784000 -10800 1 WARST} {1236481200 -14400 0 WART} - {1255233600 -10800 1 WARST} + {1255233600 -10800 0 ART} } diff --git a/library/tzdata/America/Aruba b/library/tzdata/America/Aruba index 92f182d..e02d5fc 100644 --- a/library/tzdata/America/Aruba +++ b/library/tzdata/America/Aruba @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Aruba) { - {-9223372036854775808 -16824 0 LMT} - {-1826738376 -16200 0 ANT} - {-157750200 -14400 0 AST} +if {![info exists TZData(America/Curacao)]} { + LoadTimeZoneFile America/Curacao } +set TZData(:America/Aruba) $TZData(:America/Curacao) diff --git a/library/tzdata/America/Cayman b/library/tzdata/America/Cayman index ab5d12b..3e2e3cc 100644 --- a/library/tzdata/America/Cayman +++ b/library/tzdata/America/Cayman @@ -2,6 +2,6 @@ set TZData(:America/Cayman) { {-9223372036854775808 -19532 0 LMT} - {-2524502068 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524502068 -18431 0 KMT} + {-1827687169 -18000 0 EST} } diff --git a/library/tzdata/America/Dominica b/library/tzdata/America/Dominica index 3503a65..b97cb0e 100644 --- a/library/tzdata/America/Dominica +++ b/library/tzdata/America/Dominica @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Dominica) { - {-9223372036854775808 -14736 0 LMT} - {-1846266804 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Dominica) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Grand_Turk b/library/tzdata/America/Grand_Turk index a455dd5..6c8ea4a 100644 --- a/library/tzdata/America/Grand_Turk +++ b/library/tzdata/America/Grand_Turk @@ -2,8 +2,8 @@ set TZData(:America/Grand_Turk) { {-9223372036854775808 -17072 0 LMT} - {-2524504528 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-2524504528 -18431 0 KMT} + {-1827687169 -18000 0 EST} {294217200 -14400 1 EDT} {309938400 -18000 0 EST} {325666800 -14400 1 EDT} diff --git a/library/tzdata/America/Grenada b/library/tzdata/America/Grenada index 3c2919b..92300c3 100644 --- a/library/tzdata/America/Grenada +++ b/library/tzdata/America/Grenada @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Grenada) { - {-9223372036854775808 -14820 0 LMT} - {-1846266780 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Grenada) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Guadeloupe b/library/tzdata/America/Guadeloupe index b1987ce..aba6bd7 100644 --- a/library/tzdata/America/Guadeloupe +++ b/library/tzdata/America/Guadeloupe @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Guadeloupe) { - {-9223372036854775808 -14768 0 LMT} - {-1848254032 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Guadeloupe) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Jamaica b/library/tzdata/America/Jamaica index 393d90a8..682e47c 100644 --- a/library/tzdata/America/Jamaica +++ b/library/tzdata/America/Jamaica @@ -1,9 +1,9 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:America/Jamaica) { - {-9223372036854775808 -18432 0 LMT} - {-2524503168 -18432 0 KMT} - {-1827687168 -18000 0 EST} + {-9223372036854775808 -18431 0 LMT} + {-2524503169 -18431 0 KMT} + {-1827687169 -18000 0 EST} {136364400 -14400 0 EDT} {152085600 -18000 0 EST} {162370800 -14400 1 EDT} diff --git a/library/tzdata/America/Marigot b/library/tzdata/America/Marigot index 9f3f8f6..c2b3873 100644 --- a/library/tzdata/America/Marigot +++ b/library/tzdata/America/Marigot @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Marigot) $TZData(:America/Guadeloupe) +set TZData(:America/Marigot) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Montserrat b/library/tzdata/America/Montserrat index 4d82766..0a656d3 100644 --- a/library/tzdata/America/Montserrat +++ b/library/tzdata/America/Montserrat @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Montserrat) { - {-9223372036854775808 -14932 0 LMT} - {-1846266608 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Montserrat) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Barthelemy b/library/tzdata/America/St_Barthelemy index 25c114a..46bc287 100644 --- a/library/tzdata/America/St_Barthelemy +++ b/library/tzdata/America/St_Barthelemy @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/Guadeloupe)]} { - LoadTimeZoneFile America/Guadeloupe +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/St_Barthelemy) $TZData(:America/Guadeloupe) +set TZData(:America/St_Barthelemy) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Kitts b/library/tzdata/America/St_Kitts index bfd803b..6ad7f04 100644 --- a/library/tzdata/America/St_Kitts +++ b/library/tzdata/America/St_Kitts @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Kitts) { - {-9223372036854775808 -15052 0 LMT} - {-1825098548 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Kitts) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Lucia b/library/tzdata/America/St_Lucia index c2767dd..e479b31 100644 --- a/library/tzdata/America/St_Lucia +++ b/library/tzdata/America/St_Lucia @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Lucia) { - {-9223372036854775808 -14640 0 LMT} - {-2524506960 -14640 0 CMT} - {-1830369360 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Lucia) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Thomas b/library/tzdata/America/St_Thomas index bf93595..24698b8 100644 --- a/library/tzdata/America/St_Thomas +++ b/library/tzdata/America/St_Thomas @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Thomas) { - {-9223372036854775808 -15584 0 LMT} - {-1846266016 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Thomas) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/St_Vincent b/library/tzdata/America/St_Vincent index 3a884c7..e3b32fb 100644 --- a/library/tzdata/America/St_Vincent +++ b/library/tzdata/America/St_Vincent @@ -1,7 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/St_Vincent) { - {-9223372036854775808 -14696 0 LMT} - {-2524506904 -14696 0 KMT} - {-1830369304 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/St_Vincent) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Tortola b/library/tzdata/America/Tortola index bf7f1fc..aa6f655 100644 --- a/library/tzdata/America/Tortola +++ b/library/tzdata/America/Tortola @@ -1,6 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Tortola) { - {-9223372036854775808 -15508 0 LMT} - {-1846266092 -14400 0 AST} +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } +set TZData(:America/Tortola) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/America/Virgin b/library/tzdata/America/Virgin index 390d7c2..c267e5b 100644 --- a/library/tzdata/America/Virgin +++ b/library/tzdata/America/Virgin @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(America/St_Thomas)]} { - LoadTimeZoneFile America/St_Thomas +if {![info exists TZData(America/Port_of_Spain)]} { + LoadTimeZoneFile America/Port_of_Spain } -set TZData(:America/Virgin) $TZData(:America/St_Thomas) +set TZData(:America/Virgin) $TZData(:America/Port_of_Spain) diff --git a/library/tzdata/Antarctica/McMurdo b/library/tzdata/Antarctica/McMurdo index 670f7eb..3b29ba1 100644 --- a/library/tzdata/Antarctica/McMurdo +++ b/library/tzdata/Antarctica/McMurdo @@ -1,257 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Antarctica/McMurdo) { - {-9223372036854775808 0 0 zzz} - {-441849600 43200 0 NZST} - {152632800 46800 1 NZDT} - {162309600 43200 0 NZST} - {183477600 46800 1 NZDT} - {194968800 43200 0 NZST} - {215532000 46800 1 NZDT} - {226418400 43200 0 NZST} - {246981600 46800 1 NZDT} - {257868000 43200 0 NZST} - {278431200 46800 1 NZDT} - {289317600 43200 0 NZST} - {309880800 46800 1 NZDT} - {320767200 43200 0 NZST} - {341330400 46800 1 NZDT} - {352216800 43200 0 NZST} - {372780000 46800 1 NZDT} - {384271200 43200 0 NZST} - {404834400 46800 1 NZDT} - {415720800 43200 0 NZST} - {436284000 46800 1 NZDT} - {447170400 43200 0 NZST} - {467733600 46800 1 NZDT} - {478620000 43200 0 NZST} - {499183200 46800 1 NZDT} - {510069600 43200 0 NZST} - {530632800 46800 1 NZDT} - {541519200 43200 0 NZST} - {562082400 46800 1 NZDT} - {573573600 43200 0 NZST} - {594136800 46800 1 NZDT} - {605023200 43200 0 NZST} - {623772000 46800 1 NZDT} - {637682400 43200 0 NZST} - {655221600 46800 1 NZDT} - {669132000 43200 0 NZST} - {686671200 46800 1 NZDT} - {700581600 43200 0 NZST} - {718120800 46800 1 NZDT} - {732636000 43200 0 NZST} - {749570400 46800 1 NZDT} - {764085600 43200 0 NZST} - {781020000 46800 1 NZDT} - {795535200 43200 0 NZST} - {812469600 46800 1 NZDT} - {826984800 43200 0 NZST} - {844524000 46800 1 NZDT} - {858434400 43200 0 NZST} - {875973600 46800 1 NZDT} - {889884000 43200 0 NZST} - {907423200 46800 1 NZDT} - {921938400 43200 0 NZST} - {938872800 46800 1 NZDT} - {953388000 43200 0 NZST} - {970322400 46800 1 NZDT} - {984837600 43200 0 NZST} - {1002376800 46800 1 NZDT} - {1016287200 43200 0 NZST} - {1033826400 46800 1 NZDT} - {1047736800 43200 0 NZST} - {1065276000 46800 1 NZDT} - {1079791200 43200 0 NZST} - {1096725600 46800 1 NZDT} - {1111240800 43200 0 NZST} - {1128175200 46800 1 NZDT} - {1142690400 43200 0 NZST} - {1159624800 46800 1 NZDT} - {1174140000 43200 0 NZST} - {1191074400 46800 1 NZDT} - {1207404000 43200 0 NZST} - {1222524000 46800 1 NZDT} - {1238853600 43200 0 NZST} - {1253973600 46800 1 NZDT} - {1270303200 43200 0 NZST} - {1285423200 46800 1 NZDT} - {1301752800 43200 0 NZST} - {1316872800 46800 1 NZDT} - {1333202400 43200 0 NZST} - {1348927200 46800 1 NZDT} - {1365256800 43200 0 NZST} - {1380376800 46800 1 NZDT} - {1396706400 43200 0 NZST} - {1411826400 46800 1 NZDT} - {1428156000 43200 0 NZST} - {1443276000 46800 1 NZDT} - {1459605600 43200 0 NZST} - {1474725600 46800 1 NZDT} - {1491055200 43200 0 NZST} - {1506175200 46800 1 NZDT} - {1522504800 43200 0 NZST} - {1538229600 46800 1 NZDT} - {1554559200 43200 0 NZST} - {1569679200 46800 1 NZDT} - {1586008800 43200 0 NZST} - {1601128800 46800 1 NZDT} - {1617458400 43200 0 NZST} - {1632578400 46800 1 NZDT} - {1648908000 43200 0 NZST} - {1664028000 46800 1 NZDT} - {1680357600 43200 0 NZST} - {1695477600 46800 1 NZDT} - {1712412000 43200 0 NZST} - {1727532000 46800 1 NZDT} - {1743861600 43200 0 NZST} - {1758981600 46800 1 NZDT} - {1775311200 43200 0 NZST} - {1790431200 46800 1 NZDT} - {1806760800 43200 0 NZST} - {1821880800 46800 1 NZDT} - {1838210400 43200 0 NZST} - {1853330400 46800 1 NZDT} - {1869660000 43200 0 NZST} - {1885384800 46800 1 NZDT} - {1901714400 43200 0 NZST} - {1916834400 46800 1 NZDT} - {1933164000 43200 0 NZST} - {1948284000 46800 1 NZDT} - {1964613600 43200 0 NZST} - {1979733600 46800 1 NZDT} - {1996063200 43200 0 NZST} - {2011183200 46800 1 NZDT} - {2027512800 43200 0 NZST} - {2042632800 46800 1 NZDT} - {2058962400 43200 0 NZST} - {2074687200 46800 1 NZDT} - {2091016800 43200 0 NZST} - {2106136800 46800 1 NZDT} - {2122466400 43200 0 NZST} - {2137586400 46800 1 NZDT} - {2153916000 43200 0 NZST} - {2169036000 46800 1 NZDT} - {2185365600 43200 0 NZST} - {2200485600 46800 1 NZDT} - {2216815200 43200 0 NZST} - {2232540000 46800 1 NZDT} - {2248869600 43200 0 NZST} - {2263989600 46800 1 NZDT} - {2280319200 43200 0 NZST} - {2295439200 46800 1 NZDT} - {2311768800 43200 0 NZST} - {2326888800 46800 1 NZDT} - {2343218400 43200 0 NZST} - {2358338400 46800 1 NZDT} - {2374668000 43200 0 NZST} - {2389788000 46800 1 NZDT} - {2406117600 43200 0 NZST} - {2421842400 46800 1 NZDT} - {2438172000 43200 0 NZST} - {2453292000 46800 1 NZDT} - {2469621600 43200 0 NZST} - {2484741600 46800 1 NZDT} - {2501071200 43200 0 NZST} - {2516191200 46800 1 NZDT} - {2532520800 43200 0 NZST} - {2547640800 46800 1 NZDT} - {2563970400 43200 0 NZST} - {2579090400 46800 1 NZDT} - {2596024800 43200 0 NZST} - {2611144800 46800 1 NZDT} - {2627474400 43200 0 NZST} - {2642594400 46800 1 NZDT} - {2658924000 43200 0 NZST} - {2674044000 46800 1 NZDT} - {2690373600 43200 0 NZST} - {2705493600 46800 1 NZDT} - {2721823200 43200 0 NZST} - {2736943200 46800 1 NZDT} - {2753272800 43200 0 NZST} - {2768997600 46800 1 NZDT} - {2785327200 43200 0 NZST} - {2800447200 46800 1 NZDT} - {2816776800 43200 0 NZST} - {2831896800 46800 1 NZDT} - {2848226400 43200 0 NZST} - {2863346400 46800 1 NZDT} - {2879676000 43200 0 NZST} - {2894796000 46800 1 NZDT} - {2911125600 43200 0 NZST} - {2926245600 46800 1 NZDT} - {2942575200 43200 0 NZST} - {2958300000 46800 1 NZDT} - {2974629600 43200 0 NZST} - {2989749600 46800 1 NZDT} - {3006079200 43200 0 NZST} - {3021199200 46800 1 NZDT} - {3037528800 43200 0 NZST} - {3052648800 46800 1 NZDT} - {3068978400 43200 0 NZST} - {3084098400 46800 1 NZDT} - {3100428000 43200 0 NZST} - {3116152800 46800 1 NZDT} - {3132482400 43200 0 NZST} - {3147602400 46800 1 NZDT} - {3163932000 43200 0 NZST} - {3179052000 46800 1 NZDT} - {3195381600 43200 0 NZST} - {3210501600 46800 1 NZDT} - {3226831200 43200 0 NZST} - {3241951200 46800 1 NZDT} - {3258280800 43200 0 NZST} - {3273400800 46800 1 NZDT} - {3289730400 43200 0 NZST} - {3305455200 46800 1 NZDT} - {3321784800 43200 0 NZST} - {3336904800 46800 1 NZDT} - {3353234400 43200 0 NZST} - {3368354400 46800 1 NZDT} - {3384684000 43200 0 NZST} - {3399804000 46800 1 NZDT} - {3416133600 43200 0 NZST} - {3431253600 46800 1 NZDT} - {3447583200 43200 0 NZST} - {3462703200 46800 1 NZDT} - {3479637600 43200 0 NZST} - {3494757600 46800 1 NZDT} - {3511087200 43200 0 NZST} - {3526207200 46800 1 NZDT} - {3542536800 43200 0 NZST} - {3557656800 46800 1 NZDT} - {3573986400 43200 0 NZST} - {3589106400 46800 1 NZDT} - {3605436000 43200 0 NZST} - {3620556000 46800 1 NZDT} - {3636885600 43200 0 NZST} - {3652610400 46800 1 NZDT} - {3668940000 43200 0 NZST} - {3684060000 46800 1 NZDT} - {3700389600 43200 0 NZST} - {3715509600 46800 1 NZDT} - {3731839200 43200 0 NZST} - {3746959200 46800 1 NZDT} - {3763288800 43200 0 NZST} - {3778408800 46800 1 NZDT} - {3794738400 43200 0 NZST} - {3809858400 46800 1 NZDT} - {3826188000 43200 0 NZST} - {3841912800 46800 1 NZDT} - {3858242400 43200 0 NZST} - {3873362400 46800 1 NZDT} - {3889692000 43200 0 NZST} - {3904812000 46800 1 NZDT} - {3921141600 43200 0 NZST} - {3936261600 46800 1 NZDT} - {3952591200 43200 0 NZST} - {3967711200 46800 1 NZDT} - {3984040800 43200 0 NZST} - {3999765600 46800 1 NZDT} - {4016095200 43200 0 NZST} - {4031215200 46800 1 NZDT} - {4047544800 43200 0 NZST} - {4062664800 46800 1 NZDT} - {4078994400 43200 0 NZST} - {4094114400 46800 1 NZDT} +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } +set TZData(:Antarctica/McMurdo) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Antarctica/South_Pole b/library/tzdata/Antarctica/South_Pole index 34d0db1..544bde4 100644 --- a/library/tzdata/Antarctica/South_Pole +++ b/library/tzdata/Antarctica/South_Pole @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Antarctica/McMurdo)]} { - LoadTimeZoneFile Antarctica/McMurdo +if {![info exists TZData(Pacific/Auckland)]} { + LoadTimeZoneFile Pacific/Auckland } -set TZData(:Antarctica/South_Pole) $TZData(:Antarctica/McMurdo) +set TZData(:Antarctica/South_Pole) $TZData(:Pacific/Auckland) diff --git a/library/tzdata/Asia/Amman b/library/tzdata/Asia/Amman index 33f0ba7..d5e8616 100644 --- a/library/tzdata/Asia/Amman +++ b/library/tzdata/Asia/Amman @@ -70,178 +70,5 @@ set TZData(:Asia/Amman) { {1301608800 10800 1 EEST} {1319752800 7200 0 EET} {1333058400 10800 1 EEST} - {1364504400 10800 1 EEST} - {1382652000 7200 0 EET} - {1395957600 10800 1 EEST} - {1414706400 7200 0 EET} - {1427407200 10800 1 EEST} - {1446156000 7200 0 EET} - {1459461600 10800 1 EEST} - {1477605600 7200 0 EET} - {1490911200 10800 1 EEST} - {1509055200 7200 0 EET} - {1522360800 10800 1 EEST} - {1540504800 7200 0 EET} - {1553810400 10800 1 EEST} - {1571954400 7200 0 EET} - {1585260000 10800 1 EEST} - {1604008800 7200 0 EET} - {1616709600 10800 1 EEST} - {1635458400 7200 0 EET} - {1648764000 10800 1 EEST} - {1666908000 7200 0 EET} - {1680213600 10800 1 EEST} - {1698357600 7200 0 EET} - {1711663200 10800 1 EEST} - {1729807200 7200 0 EET} - {1743112800 10800 1 EEST} - {1761861600 7200 0 EET} - {1774562400 10800 1 EEST} - {1793311200 7200 0 EET} - {1806012000 10800 1 EEST} - {1824760800 7200 0 EET} - {1838066400 10800 1 EEST} - {1856210400 7200 0 EET} - {1869516000 10800 1 EEST} - {1887660000 7200 0 EET} - {1900965600 10800 1 EEST} - {1919109600 7200 0 EET} - {1932415200 10800 1 EEST} - {1951164000 7200 0 EET} - {1963864800 10800 1 EEST} - {1982613600 7200 0 EET} - {1995919200 10800 1 EEST} - {2014063200 7200 0 EET} - {2027368800 10800 1 EEST} - {2045512800 7200 0 EET} - {2058818400 10800 1 EEST} - {2076962400 7200 0 EET} - {2090268000 10800 1 EEST} - {2109016800 7200 0 EET} - {2121717600 10800 1 EEST} - {2140466400 7200 0 EET} - {2153167200 10800 1 EEST} - {2171916000 7200 0 EET} - {2185221600 10800 1 EEST} - {2203365600 7200 0 EET} - {2216671200 10800 1 EEST} - {2234815200 7200 0 EET} - {2248120800 10800 1 EEST} - {2266264800 7200 0 EET} - {2279570400 10800 1 EEST} - {2298319200 7200 0 EET} - {2311020000 10800 1 EEST} - {2329768800 7200 0 EET} - {2343074400 10800 1 EEST} - {2361218400 7200 0 EET} - {2374524000 10800 1 EEST} - {2392668000 7200 0 EET} - {2405973600 10800 1 EEST} - {2424117600 7200 0 EET} - {2437423200 10800 1 EEST} - {2455567200 7200 0 EET} - {2468872800 10800 1 EEST} - {2487621600 7200 0 EET} - {2500322400 10800 1 EEST} - {2519071200 7200 0 EET} - {2532376800 10800 1 EEST} - {2550520800 7200 0 EET} - {2563826400 10800 1 EEST} - {2581970400 7200 0 EET} - {2595276000 10800 1 EEST} - {2613420000 7200 0 EET} - {2626725600 10800 1 EEST} - {2645474400 7200 0 EET} - {2658175200 10800 1 EEST} - {2676924000 7200 0 EET} - {2689624800 10800 1 EEST} - {2708373600 7200 0 EET} - {2721679200 10800 1 EEST} - {2739823200 7200 0 EET} - {2753128800 10800 1 EEST} - {2771272800 7200 0 EET} - {2784578400 10800 1 EEST} - {2802722400 7200 0 EET} - {2816028000 10800 1 EEST} - {2834776800 7200 0 EET} - {2847477600 10800 1 EEST} - {2866226400 7200 0 EET} - {2879532000 10800 1 EEST} - {2897676000 7200 0 EET} - {2910981600 10800 1 EEST} - {2929125600 7200 0 EET} - {2942431200 10800 1 EEST} - {2960575200 7200 0 EET} - {2973880800 10800 1 EEST} - {2992629600 7200 0 EET} - {3005330400 10800 1 EEST} - {3024079200 7200 0 EET} - {3036780000 10800 1 EEST} - {3055528800 7200 0 EET} - {3068834400 10800 1 EEST} - {3086978400 7200 0 EET} - {3100284000 10800 1 EEST} - {3118428000 7200 0 EET} - {3131733600 10800 1 EEST} - {3149877600 7200 0 EET} - {3163183200 10800 1 EEST} - {3181932000 7200 0 EET} - {3194632800 10800 1 EEST} - {3213381600 7200 0 EET} - {3226687200 10800 1 EEST} - {3244831200 7200 0 EET} - {3258136800 10800 1 EEST} - {3276280800 7200 0 EET} - {3289586400 10800 1 EEST} - {3307730400 7200 0 EET} - {3321036000 10800 1 EEST} - {3339180000 7200 0 EET} - {3352485600 10800 1 EEST} - {3371234400 7200 0 EET} - {3383935200 10800 1 EEST} - {3402684000 7200 0 EET} - {3415989600 10800 1 EEST} - {3434133600 7200 0 EET} - {3447439200 10800 1 EEST} - {3465583200 7200 0 EET} - {3478888800 10800 1 EEST} - {3497032800 7200 0 EET} - {3510338400 10800 1 EEST} - {3529087200 7200 0 EET} - {3541788000 10800 1 EEST} - {3560536800 7200 0 EET} - {3573237600 10800 1 EEST} - {3591986400 7200 0 EET} - {3605292000 10800 1 EEST} - {3623436000 7200 0 EET} - {3636741600 10800 1 EEST} - {3654885600 7200 0 EET} - {3668191200 10800 1 EEST} - {3686335200 7200 0 EET} - {3699640800 10800 1 EEST} - {3718389600 7200 0 EET} - {3731090400 10800 1 EEST} - {3749839200 7200 0 EET} - {3763144800 10800 1 EEST} - {3781288800 7200 0 EET} - {3794594400 10800 1 EEST} - {3812738400 7200 0 EET} - {3826044000 10800 1 EEST} - {3844188000 7200 0 EET} - {3857493600 10800 1 EEST} - {3876242400 7200 0 EET} - {3888943200 10800 1 EEST} - {3907692000 7200 0 EET} - {3920392800 10800 1 EEST} - {3939141600 7200 0 EET} - {3952447200 10800 1 EEST} - {3970591200 7200 0 EET} - {3983896800 10800 1 EEST} - {4002040800 7200 0 EET} - {4015346400 10800 1 EEST} - {4033490400 7200 0 EET} - {4046796000 10800 1 EEST} - {4065544800 7200 0 EET} - {4078245600 10800 1 EEST} - {4096994400 7200 0 EET} + {1351202400 10800 0 AST} } diff --git a/library/tzdata/Asia/Dili b/library/tzdata/Asia/Dili index 36910fd..f783557 100644 --- a/library/tzdata/Asia/Dili +++ b/library/tzdata/Asia/Dili @@ -5,6 +5,6 @@ set TZData(:Asia/Dili) { {-1830414140 28800 0 TLT} {-879152400 32400 0 JST} {-766054800 32400 0 TLT} - {199897200 28800 0 CIT} + {199897200 28800 0 WITA} {969120000 32400 0 TLT} } diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index a0636e2..7d62a96 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -102,177 +102,177 @@ set TZData(:Asia/Gaza) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index a8a9019..1333d5a 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -101,177 +101,177 @@ set TZData(:Asia/Hebron) { {1333058400 10800 1 EEST} {1348178400 7200 0 EET} {1364508000 10800 1 EEST} - {1380232800 7200 0 EET} + {1380229200 7200 0 EET} {1395957600 10800 1 EEST} - {1411682400 7200 0 EET} + {1411678800 7200 0 EET} {1427407200 10800 1 EEST} - {1443132000 7200 0 EET} + {1443128400 7200 0 EET} {1459461600 10800 1 EEST} - {1474581600 7200 0 EET} + {1474578000 7200 0 EET} {1490911200 10800 1 EEST} - {1506031200 7200 0 EET} + {1506027600 7200 0 EET} {1522360800 10800 1 EEST} - {1537480800 7200 0 EET} + {1537477200 7200 0 EET} {1553810400 10800 1 EEST} - {1569535200 7200 0 EET} + {1569531600 7200 0 EET} {1585260000 10800 1 EEST} - {1600984800 7200 0 EET} + {1600981200 7200 0 EET} {1616709600 10800 1 EEST} - {1632434400 7200 0 EET} + {1632430800 7200 0 EET} {1648764000 10800 1 EEST} - {1663884000 7200 0 EET} + {1663880400 7200 0 EET} {1680213600 10800 1 EEST} - {1695333600 7200 0 EET} + {1695330000 7200 0 EET} {1711663200 10800 1 EEST} - {1727388000 7200 0 EET} + {1727384400 7200 0 EET} {1743112800 10800 1 EEST} - {1758837600 7200 0 EET} + {1758834000 7200 0 EET} {1774562400 10800 1 EEST} - {1790287200 7200 0 EET} + {1790283600 7200 0 EET} {1806012000 10800 1 EEST} - {1821736800 7200 0 EET} + {1821733200 7200 0 EET} {1838066400 10800 1 EEST} - {1853186400 7200 0 EET} + {1853182800 7200 0 EET} {1869516000 10800 1 EEST} - {1884636000 7200 0 EET} + {1884632400 7200 0 EET} {1900965600 10800 1 EEST} - {1916690400 7200 0 EET} + {1916686800 7200 0 EET} {1932415200 10800 1 EEST} - {1948140000 7200 0 EET} + {1948136400 7200 0 EET} {1963864800 10800 1 EEST} - {1979589600 7200 0 EET} + {1979586000 7200 0 EET} {1995919200 10800 1 EEST} - {2011039200 7200 0 EET} + {2011035600 7200 0 EET} {2027368800 10800 1 EEST} - {2042488800 7200 0 EET} + {2042485200 7200 0 EET} {2058818400 10800 1 EEST} - {2073938400 7200 0 EET} + {2073934800 7200 0 EET} {2090268000 10800 1 EEST} - {2105992800 7200 0 EET} + {2105989200 7200 0 EET} {2121717600 10800 1 EEST} - {2137442400 7200 0 EET} + {2137438800 7200 0 EET} {2153167200 10800 1 EEST} - {2168892000 7200 0 EET} + {2168888400 7200 0 EET} {2185221600 10800 1 EEST} - {2200341600 7200 0 EET} + {2200338000 7200 0 EET} {2216671200 10800 1 EEST} - {2231791200 7200 0 EET} + {2231787600 7200 0 EET} {2248120800 10800 1 EEST} - {2263845600 7200 0 EET} + {2263842000 7200 0 EET} {2279570400 10800 1 EEST} - {2295295200 7200 0 EET} + {2295291600 7200 0 EET} {2311020000 10800 1 EEST} - {2326744800 7200 0 EET} + {2326741200 7200 0 EET} {2343074400 10800 1 EEST} - {2358194400 7200 0 EET} + {2358190800 7200 0 EET} {2374524000 10800 1 EEST} - {2389644000 7200 0 EET} + {2389640400 7200 0 EET} {2405973600 10800 1 EEST} - {2421093600 7200 0 EET} + {2421090000 7200 0 EET} {2437423200 10800 1 EEST} - {2453148000 7200 0 EET} + {2453144400 7200 0 EET} {2468872800 10800 1 EEST} - {2484597600 7200 0 EET} + {2484594000 7200 0 EET} {2500322400 10800 1 EEST} - {2516047200 7200 0 EET} + {2516043600 7200 0 EET} {2532376800 10800 1 EEST} - {2547496800 7200 0 EET} + {2547493200 7200 0 EET} {2563826400 10800 1 EEST} - {2578946400 7200 0 EET} + {2578942800 7200 0 EET} {2595276000 10800 1 EEST} - {2611000800 7200 0 EET} + {2610997200 7200 0 EET} {2626725600 10800 1 EEST} - {2642450400 7200 0 EET} + {2642446800 7200 0 EET} {2658175200 10800 1 EEST} - {2673900000 7200 0 EET} + {2673896400 7200 0 EET} {2689624800 10800 1 EEST} - {2705349600 7200 0 EET} + {2705346000 7200 0 EET} {2721679200 10800 1 EEST} - {2736799200 7200 0 EET} + {2736795600 7200 0 EET} {2753128800 10800 1 EEST} - {2768248800 7200 0 EET} + {2768245200 7200 0 EET} {2784578400 10800 1 EEST} - {2800303200 7200 0 EET} + {2800299600 7200 0 EET} {2816028000 10800 1 EEST} - {2831752800 7200 0 EET} + {2831749200 7200 0 EET} {2847477600 10800 1 EEST} - {2863202400 7200 0 EET} + {2863198800 7200 0 EET} {2879532000 10800 1 EEST} - {2894652000 7200 0 EET} + {2894648400 7200 0 EET} {2910981600 10800 1 EEST} - {2926101600 7200 0 EET} + {2926098000 7200 0 EET} {2942431200 10800 1 EEST} - {2957551200 7200 0 EET} + {2957547600 7200 0 EET} {2973880800 10800 1 EEST} - {2989605600 7200 0 EET} + {2989602000 7200 0 EET} {3005330400 10800 1 EEST} - {3021055200 7200 0 EET} + {3021051600 7200 0 EET} {3036780000 10800 1 EEST} - {3052504800 7200 0 EET} + {3052501200 7200 0 EET} {3068834400 10800 1 EEST} - {3083954400 7200 0 EET} + {3083950800 7200 0 EET} {3100284000 10800 1 EEST} - {3115404000 7200 0 EET} + {3115400400 7200 0 EET} {3131733600 10800 1 EEST} - {3147458400 7200 0 EET} + {3147454800 7200 0 EET} {3163183200 10800 1 EEST} - {3178908000 7200 0 EET} + {3178904400 7200 0 EET} {3194632800 10800 1 EEST} - {3210357600 7200 0 EET} + {3210354000 7200 0 EET} {3226687200 10800 1 EEST} - {3241807200 7200 0 EET} + {3241803600 7200 0 EET} {3258136800 10800 1 EEST} - {3273256800 7200 0 EET} + {3273253200 7200 0 EET} {3289586400 10800 1 EEST} - {3304706400 7200 0 EET} + {3304702800 7200 0 EET} {3321036000 10800 1 EEST} - {3336760800 7200 0 EET} + {3336757200 7200 0 EET} {3352485600 10800 1 EEST} - {3368210400 7200 0 EET} + {3368206800 7200 0 EET} {3383935200 10800 1 EEST} - {3399660000 7200 0 EET} + {3399656400 7200 0 EET} {3415989600 10800 1 EEST} - {3431109600 7200 0 EET} + {3431106000 7200 0 EET} {3447439200 10800 1 EEST} - {3462559200 7200 0 EET} + {3462555600 7200 0 EET} {3478888800 10800 1 EEST} - {3494613600 7200 0 EET} + {3494610000 7200 0 EET} {3510338400 10800 1 EEST} - {3526063200 7200 0 EET} + {3526059600 7200 0 EET} {3541788000 10800 1 EEST} - {3557512800 7200 0 EET} + {3557509200 7200 0 EET} {3573237600 10800 1 EEST} - {3588962400 7200 0 EET} + {3588958800 7200 0 EET} {3605292000 10800 1 EEST} - {3620412000 7200 0 EET} + {3620408400 7200 0 EET} {3636741600 10800 1 EEST} - {3651861600 7200 0 EET} + {3651858000 7200 0 EET} {3668191200 10800 1 EEST} - {3683916000 7200 0 EET} + {3683912400 7200 0 EET} {3699640800 10800 1 EEST} - {3715365600 7200 0 EET} + {3715362000 7200 0 EET} {3731090400 10800 1 EEST} - {3746815200 7200 0 EET} + {3746811600 7200 0 EET} {3763144800 10800 1 EEST} - {3778264800 7200 0 EET} + {3778261200 7200 0 EET} {3794594400 10800 1 EEST} - {3809714400 7200 0 EET} + {3809710800 7200 0 EET} {3826044000 10800 1 EEST} - {3841164000 7200 0 EET} + {3841160400 7200 0 EET} {3857493600 10800 1 EEST} - {3873218400 7200 0 EET} + {3873214800 7200 0 EET} {3888943200 10800 1 EEST} - {3904668000 7200 0 EET} + {3904664400 7200 0 EET} {3920392800 10800 1 EEST} - {3936117600 7200 0 EET} + {3936114000 7200 0 EET} {3952447200 10800 1 EEST} - {3967567200 7200 0 EET} + {3967563600 7200 0 EET} {3983896800 10800 1 EEST} - {3999016800 7200 0 EET} + {3999013200 7200 0 EET} {4015346400 10800 1 EEST} - {4031071200 7200 0 EET} + {4031067600 7200 0 EET} {4046796000 10800 1 EEST} - {4062520800 7200 0 EET} + {4062517200 7200 0 EET} {4078245600 10800 1 EEST} - {4093970400 7200 0 EET} + {4093966800 7200 0 EET} } diff --git a/library/tzdata/Asia/Jakarta b/library/tzdata/Asia/Jakarta index 27033e8..75cd659 100644 --- a/library/tzdata/Asia/Jakarta +++ b/library/tzdata/Asia/Jakarta @@ -2,12 +2,12 @@ set TZData(:Asia/Jakarta) { {-9223372036854775808 25632 0 LMT} - {-3231299232 25632 0 JMT} + {-3231299232 25632 0 BMT} {-1451719200 26400 0 JAVT} - {-1172906400 27000 0 WIT} + {-1172906400 27000 0 WIB} {-876641400 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 25200 0 WIB} } diff --git a/library/tzdata/Asia/Jayapura b/library/tzdata/Asia/Jayapura index 893da8b..a71228f 100644 --- a/library/tzdata/Asia/Jayapura +++ b/library/tzdata/Asia/Jayapura @@ -2,7 +2,7 @@ set TZData(:Asia/Jayapura) { {-9223372036854775808 33768 0 LMT} - {-1172913768 32400 0 EIT} + {-1172913768 32400 0 WIT} {-799491600 34200 0 CST} - {-189423000 32400 0 EIT} + {-189423000 32400 0 WIT} } diff --git a/library/tzdata/Asia/Makassar b/library/tzdata/Asia/Makassar index aa604b4..be947f3 100644 --- a/library/tzdata/Asia/Makassar +++ b/library/tzdata/Asia/Makassar @@ -3,7 +3,7 @@ set TZData(:Asia/Makassar) { {-9223372036854775808 28656 0 LMT} {-1577951856 28656 0 MMT} - {-1172908656 28800 0 CIT} + {-1172908656 28800 0 WITA} {-880272000 32400 0 JST} - {-766054800 28800 0 CIT} + {-766054800 28800 0 WITA} } diff --git a/library/tzdata/Asia/Pontianak b/library/tzdata/Asia/Pontianak index f3567dd..728b552 100644 --- a/library/tzdata/Asia/Pontianak +++ b/library/tzdata/Asia/Pontianak @@ -3,11 +3,11 @@ set TZData(:Asia/Pontianak) { {-9223372036854775808 26240 0 LMT} {-1946186240 26240 0 PMT} - {-1172906240 27000 0 WIT} + {-1172906240 27000 0 WIB} {-881220600 32400 0 JST} - {-766054800 27000 0 WIT} - {-683883000 28800 0 WIT} - {-620812800 27000 0 WIT} - {-189415800 28800 0 CIT} - {567964800 25200 0 WIT} + {-766054800 27000 0 WIB} + {-683883000 28800 0 WIB} + {-620812800 27000 0 WIB} + {-189415800 28800 0 WITA} + {567964800 25200 0 WIB} } diff --git a/library/tzdata/Europe/Vaduz b/library/tzdata/Europe/Vaduz index 3118331..095e018 100644 --- a/library/tzdata/Europe/Vaduz +++ b/library/tzdata/Europe/Vaduz @@ -1,245 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Vaduz) { - {-9223372036854775808 2284 0 LMT} - {-2385247084 3600 0 CET} - {347151600 3600 0 CET} - {354675600 7200 1 CEST} - {370400400 3600 0 CET} - {386125200 7200 1 CEST} - {401850000 3600 0 CET} - {417574800 7200 1 CEST} - {433299600 3600 0 CET} - {449024400 7200 1 CEST} - {465354000 3600 0 CET} - {481078800 7200 1 CEST} - {496803600 3600 0 CET} - {512528400 7200 1 CEST} - {528253200 3600 0 CET} - {543978000 7200 1 CEST} - {559702800 3600 0 CET} - {575427600 7200 1 CEST} - {591152400 3600 0 CET} - {606877200 7200 1 CEST} - {622602000 3600 0 CET} - {638326800 7200 1 CEST} - {654656400 3600 0 CET} - {670381200 7200 1 CEST} - {686106000 3600 0 CET} - {701830800 7200 1 CEST} - {717555600 3600 0 CET} - {733280400 7200 1 CEST} - {749005200 3600 0 CET} - {764730000 7200 1 CEST} - {780454800 3600 0 CET} - {796179600 7200 1 CEST} - {811904400 3600 0 CET} - {828234000 7200 1 CEST} - {846378000 3600 0 CET} - {859683600 7200 1 CEST} - {877827600 3600 0 CET} - {891133200 7200 1 CEST} - {909277200 3600 0 CET} - {922582800 7200 1 CEST} - {941331600 3600 0 CET} - {954032400 7200 1 CEST} - {972781200 3600 0 CET} - {985482000 7200 1 CEST} - {1004230800 3600 0 CET} - {1017536400 7200 1 CEST} - {1035680400 3600 0 CET} - {1048986000 7200 1 CEST} - {1067130000 3600 0 CET} - {1080435600 7200 1 CEST} - {1099184400 3600 0 CET} - {1111885200 7200 1 CEST} - {1130634000 3600 0 CET} - {1143334800 7200 1 CEST} - {1162083600 3600 0 CET} - {1174784400 7200 1 CEST} - {1193533200 3600 0 CET} - {1206838800 7200 1 CEST} - {1224982800 3600 0 CET} - {1238288400 7200 1 CEST} - {1256432400 3600 0 CET} - {1269738000 7200 1 CEST} - {1288486800 3600 0 CET} - {1301187600 7200 1 CEST} - {1319936400 3600 0 CET} - {1332637200 7200 1 CEST} - {1351386000 3600 0 CET} - {1364691600 7200 1 CEST} - {1382835600 3600 0 CET} - {1396141200 7200 1 CEST} - {1414285200 3600 0 CET} - {1427590800 7200 1 CEST} - {1445734800 3600 0 CET} - {1459040400 7200 1 CEST} - {1477789200 3600 0 CET} - {1490490000 7200 1 CEST} - {1509238800 3600 0 CET} - {1521939600 7200 1 CEST} - {1540688400 3600 0 CET} - {1553994000 7200 1 CEST} - {1572138000 3600 0 CET} - {1585443600 7200 1 CEST} - {1603587600 3600 0 CET} - {1616893200 7200 1 CEST} - {1635642000 3600 0 CET} - {1648342800 7200 1 CEST} - {1667091600 3600 0 CET} - {1679792400 7200 1 CEST} - {1698541200 3600 0 CET} - {1711846800 7200 1 CEST} - {1729990800 3600 0 CET} - {1743296400 7200 1 CEST} - {1761440400 3600 0 CET} - {1774746000 7200 1 CEST} - {1792890000 3600 0 CET} - {1806195600 7200 1 CEST} - {1824944400 3600 0 CET} - {1837645200 7200 1 CEST} - {1856394000 3600 0 CET} - {1869094800 7200 1 CEST} - {1887843600 3600 0 CET} - {1901149200 7200 1 CEST} - {1919293200 3600 0 CET} - {1932598800 7200 1 CEST} - {1950742800 3600 0 CET} - {1964048400 7200 1 CEST} - {1982797200 3600 0 CET} - {1995498000 7200 1 CEST} - {2014246800 3600 0 CET} - {2026947600 7200 1 CEST} - {2045696400 3600 0 CET} - {2058397200 7200 1 CEST} - {2077146000 3600 0 CET} - {2090451600 7200 1 CEST} - {2108595600 3600 0 CET} - {2121901200 7200 1 CEST} - {2140045200 3600 0 CET} - {2153350800 7200 1 CEST} - {2172099600 3600 0 CET} - {2184800400 7200 1 CEST} - {2203549200 3600 0 CET} - {2216250000 7200 1 CEST} - {2234998800 3600 0 CET} - {2248304400 7200 1 CEST} - {2266448400 3600 0 CET} - {2279754000 7200 1 CEST} - {2297898000 3600 0 CET} - {2311203600 7200 1 CEST} - {2329347600 3600 0 CET} - {2342653200 7200 1 CEST} - {2361402000 3600 0 CET} - {2374102800 7200 1 CEST} - {2392851600 3600 0 CET} - {2405552400 7200 1 CEST} - {2424301200 3600 0 CET} - {2437606800 7200 1 CEST} - {2455750800 3600 0 CET} - {2469056400 7200 1 CEST} - {2487200400 3600 0 CET} - {2500506000 7200 1 CEST} - {2519254800 3600 0 CET} - {2531955600 7200 1 CEST} - {2550704400 3600 0 CET} - {2563405200 7200 1 CEST} - {2582154000 3600 0 CET} - {2595459600 7200 1 CEST} - {2613603600 3600 0 CET} - {2626909200 7200 1 CEST} - {2645053200 3600 0 CET} - {2658358800 7200 1 CEST} - {2676502800 3600 0 CET} - {2689808400 7200 1 CEST} - {2708557200 3600 0 CET} - {2721258000 7200 1 CEST} - {2740006800 3600 0 CET} - {2752707600 7200 1 CEST} - {2771456400 3600 0 CET} - {2784762000 7200 1 CEST} - {2802906000 3600 0 CET} - {2816211600 7200 1 CEST} - {2834355600 3600 0 CET} - {2847661200 7200 1 CEST} - {2866410000 3600 0 CET} - {2879110800 7200 1 CEST} - {2897859600 3600 0 CET} - {2910560400 7200 1 CEST} - {2929309200 3600 0 CET} - {2942010000 7200 1 CEST} - {2960758800 3600 0 CET} - {2974064400 7200 1 CEST} - {2992208400 3600 0 CET} - {3005514000 7200 1 CEST} - {3023658000 3600 0 CET} - {3036963600 7200 1 CEST} - {3055712400 3600 0 CET} - {3068413200 7200 1 CEST} - {3087162000 3600 0 CET} - {3099862800 7200 1 CEST} - {3118611600 3600 0 CET} - {3131917200 7200 1 CEST} - {3150061200 3600 0 CET} - {3163366800 7200 1 CEST} - {3181510800 3600 0 CET} - {3194816400 7200 1 CEST} - {3212960400 3600 0 CET} - {3226266000 7200 1 CEST} - {3245014800 3600 0 CET} - {3257715600 7200 1 CEST} - {3276464400 3600 0 CET} - {3289165200 7200 1 CEST} - {3307914000 3600 0 CET} - {3321219600 7200 1 CEST} - {3339363600 3600 0 CET} - {3352669200 7200 1 CEST} - {3370813200 3600 0 CET} - {3384118800 7200 1 CEST} - {3402867600 3600 0 CET} - {3415568400 7200 1 CEST} - {3434317200 3600 0 CET} - {3447018000 7200 1 CEST} - {3465766800 3600 0 CET} - {3479072400 7200 1 CEST} - {3497216400 3600 0 CET} - {3510522000 7200 1 CEST} - {3528666000 3600 0 CET} - {3541971600 7200 1 CEST} - {3560115600 3600 0 CET} - {3573421200 7200 1 CEST} - {3592170000 3600 0 CET} - {3604870800 7200 1 CEST} - {3623619600 3600 0 CET} - {3636320400 7200 1 CEST} - {3655069200 3600 0 CET} - {3668374800 7200 1 CEST} - {3686518800 3600 0 CET} - {3699824400 7200 1 CEST} - {3717968400 3600 0 CET} - {3731274000 7200 1 CEST} - {3750022800 3600 0 CET} - {3762723600 7200 1 CEST} - {3781472400 3600 0 CET} - {3794173200 7200 1 CEST} - {3812922000 3600 0 CET} - {3825622800 7200 1 CEST} - {3844371600 3600 0 CET} - {3857677200 7200 1 CEST} - {3875821200 3600 0 CET} - {3889126800 7200 1 CEST} - {3907270800 3600 0 CET} - {3920576400 7200 1 CEST} - {3939325200 3600 0 CET} - {3952026000 7200 1 CEST} - {3970774800 3600 0 CET} - {3983475600 7200 1 CEST} - {4002224400 3600 0 CET} - {4015530000 7200 1 CEST} - {4033674000 3600 0 CET} - {4046979600 7200 1 CEST} - {4065123600 3600 0 CET} - {4078429200 7200 1 CEST} - {4096573200 3600 0 CET} +if {![info exists TZData(Europe/Zurich)]} { + LoadTimeZoneFile Europe/Zurich } +set TZData(:Europe/Vaduz) $TZData(:Europe/Zurich) diff --git a/library/tzdata/Europe/Zurich b/library/tzdata/Europe/Zurich index 33831c3..87a20db 100644 --- a/library/tzdata/Europe/Zurich +++ b/library/tzdata/Europe/Zurich @@ -2,8 +2,8 @@ set TZData(:Europe/Zurich) { {-9223372036854775808 2048 0 LMT} - {-3827954048 1784 0 BMT} - {-2385246584 3600 0 CET} + {-3675198848 1786 0 BMT} + {-2385246586 3600 0 CET} {-904435200 7200 1 CEST} {-891129600 3600 0 CET} {-872985600 7200 1 CEST} diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index bfcaa03..454ee87 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -15,11 +15,11 @@ set TZData(:Pacific/Fiji) { {1327154400 43200 0 FJT} {1350741600 46800 1 FJST} {1358604000 43200 0 FJT} - {1382191200 46800 1 FJST} + {1382796000 46800 1 FJST} {1390053600 43200 0 FJT} - {1413640800 46800 1 FJST} + {1414245600 46800 1 FJST} {1421503200 43200 0 FJT} - {1445090400 46800 1 FJST} + {1445695200 46800 1 FJST} {1453557600 43200 0 FJT} {1477144800 46800 1 FJST} {1485007200 43200 0 FJT} @@ -27,9 +27,9 @@ set TZData(:Pacific/Fiji) { {1516456800 43200 0 FJT} {1540044000 46800 1 FJST} {1547906400 43200 0 FJT} - {1571493600 46800 1 FJST} + {1572098400 46800 1 FJST} {1579356000 43200 0 FJT} - {1602943200 46800 1 FJST} + {1603548000 46800 1 FJST} {1611410400 43200 0 FJT} {1634997600 46800 1 FJST} {1642860000 43200 0 FJT} @@ -37,11 +37,11 @@ set TZData(:Pacific/Fiji) { {1674309600 43200 0 FJT} {1697896800 46800 1 FJST} {1705759200 43200 0 FJT} - {1729346400 46800 1 FJST} + {1729951200 46800 1 FJST} {1737208800 43200 0 FJT} - {1760796000 46800 1 FJST} + {1761400800 46800 1 FJST} {1768658400 43200 0 FJT} - {1792245600 46800 1 FJST} + {1792850400 46800 1 FJST} {1800712800 43200 0 FJT} {1824300000 46800 1 FJST} {1832162400 43200 0 FJT} @@ -49,9 +49,9 @@ set TZData(:Pacific/Fiji) { {1863612000 43200 0 FJT} {1887199200 46800 1 FJST} {1895061600 43200 0 FJT} - {1918648800 46800 1 FJST} + {1919253600 46800 1 FJST} {1926511200 43200 0 FJT} - {1950098400 46800 1 FJST} + {1950703200 46800 1 FJST} {1957960800 43200 0 FJT} {1982152800 46800 1 FJST} {1990015200 43200 0 FJT} @@ -61,9 +61,9 @@ set TZData(:Pacific/Fiji) { {2052914400 43200 0 FJT} {2076501600 46800 1 FJST} {2084364000 43200 0 FJT} - {2107951200 46800 1 FJST} + {2108556000 46800 1 FJST} {2115813600 43200 0 FJT} - {2139400800 46800 1 FJST} + {2140005600 46800 1 FJST} {2147868000 43200 0 FJT} {2171455200 46800 1 FJST} {2179317600 43200 0 FJT} @@ -71,11 +71,11 @@ set TZData(:Pacific/Fiji) { {2210767200 43200 0 FJT} {2234354400 46800 1 FJST} {2242216800 43200 0 FJT} - {2265804000 46800 1 FJST} + {2266408800 46800 1 FJST} {2273666400 43200 0 FJT} - {2297253600 46800 1 FJST} + {2297858400 46800 1 FJST} {2305116000 43200 0 FJT} - {2328703200 46800 1 FJST} + {2329308000 46800 1 FJST} {2337170400 43200 0 FJT} {2360757600 46800 1 FJST} {2368620000 43200 0 FJT} @@ -83,9 +83,9 @@ set TZData(:Pacific/Fiji) { {2400069600 43200 0 FJT} {2423656800 46800 1 FJST} {2431519200 43200 0 FJT} - {2455106400 46800 1 FJST} + {2455711200 46800 1 FJST} {2462968800 43200 0 FJT} - {2486556000 46800 1 FJST} + {2487160800 46800 1 FJST} {2495023200 43200 0 FJT} {2518610400 46800 1 FJST} {2526472800 43200 0 FJT} @@ -93,11 +93,11 @@ set TZData(:Pacific/Fiji) { {2557922400 43200 0 FJT} {2581509600 46800 1 FJST} {2589372000 43200 0 FJT} - {2612959200 46800 1 FJST} + {2613564000 46800 1 FJST} {2620821600 43200 0 FJT} - {2644408800 46800 1 FJST} + {2645013600 46800 1 FJST} {2652271200 43200 0 FJT} - {2675858400 46800 1 FJST} + {2676463200 46800 1 FJST} {2684325600 43200 0 FJT} {2707912800 46800 1 FJST} {2715775200 43200 0 FJT} @@ -105,9 +105,9 @@ set TZData(:Pacific/Fiji) { {2747224800 43200 0 FJT} {2770812000 46800 1 FJST} {2778674400 43200 0 FJT} - {2802261600 46800 1 FJST} + {2802866400 46800 1 FJST} {2810124000 43200 0 FJT} - {2833711200 46800 1 FJST} + {2834316000 46800 1 FJST} {2841573600 43200 0 FJT} {2865765600 46800 1 FJST} {2873628000 43200 0 FJT} @@ -117,9 +117,9 @@ set TZData(:Pacific/Fiji) { {2936527200 43200 0 FJT} {2960114400 46800 1 FJST} {2967976800 43200 0 FJT} - {2991564000 46800 1 FJST} + {2992168800 46800 1 FJST} {2999426400 43200 0 FJT} - {3023013600 46800 1 FJST} + {3023618400 46800 1 FJST} {3031480800 43200 0 FJT} {3055068000 46800 1 FJST} {3062930400 43200 0 FJT} @@ -127,11 +127,11 @@ set TZData(:Pacific/Fiji) { {3094380000 43200 0 FJT} {3117967200 46800 1 FJST} {3125829600 43200 0 FJT} - {3149416800 46800 1 FJST} + {3150021600 46800 1 FJST} {3157279200 43200 0 FJT} - {3180866400 46800 1 FJST} + {3181471200 46800 1 FJST} {3188728800 43200 0 FJT} - {3212316000 46800 1 FJST} + {3212920800 46800 1 FJST} {3220783200 43200 0 FJT} {3244370400 46800 1 FJST} {3252232800 43200 0 FJT} @@ -139,9 +139,9 @@ set TZData(:Pacific/Fiji) { {3283682400 43200 0 FJT} {3307269600 46800 1 FJST} {3315132000 43200 0 FJT} - {3338719200 46800 1 FJST} + {3339324000 46800 1 FJST} {3346581600 43200 0 FJT} - {3370168800 46800 1 FJST} + {3370773600 46800 1 FJST} {3378636000 43200 0 FJT} {3402223200 46800 1 FJST} {3410085600 43200 0 FJT} @@ -149,11 +149,11 @@ set TZData(:Pacific/Fiji) { {3441535200 43200 0 FJT} {3465122400 46800 1 FJST} {3472984800 43200 0 FJT} - {3496572000 46800 1 FJST} + {3497176800 46800 1 FJST} {3504434400 43200 0 FJT} - {3528021600 46800 1 FJST} + {3528626400 46800 1 FJST} {3535884000 43200 0 FJT} - {3559471200 46800 1 FJST} + {3560076000 46800 1 FJST} {3567938400 43200 0 FJT} {3591525600 46800 1 FJST} {3599388000 43200 0 FJT} @@ -161,9 +161,9 @@ set TZData(:Pacific/Fiji) { {3630837600 43200 0 FJT} {3654424800 46800 1 FJST} {3662287200 43200 0 FJT} - {3685874400 46800 1 FJST} + {3686479200 46800 1 FJST} {3693736800 43200 0 FJT} - {3717324000 46800 1 FJST} + {3717928800 46800 1 FJST} {3725186400 43200 0 FJT} {3749378400 46800 1 FJST} {3757240800 43200 0 FJT} @@ -173,9 +173,9 @@ set TZData(:Pacific/Fiji) { {3820140000 43200 0 FJT} {3843727200 46800 1 FJST} {3851589600 43200 0 FJT} - {3875176800 46800 1 FJST} + {3875781600 46800 1 FJST} {3883039200 43200 0 FJT} - {3906626400 46800 1 FJST} + {3907231200 46800 1 FJST} {3915093600 43200 0 FJT} {3938680800 46800 1 FJST} {3946543200 43200 0 FJT} @@ -183,9 +183,9 @@ set TZData(:Pacific/Fiji) { {3977992800 43200 0 FJT} {4001580000 46800 1 FJST} {4009442400 43200 0 FJT} - {4033029600 46800 1 FJST} + {4033634400 46800 1 FJST} {4040892000 43200 0 FJT} - {4064479200 46800 1 FJST} + {4065084000 46800 1 FJST} {4072341600 43200 0 FJT} - {4095928800 46800 1 FJST} + {4096533600 46800 1 FJST} } diff --git a/library/tzdata/Pacific/Johnston b/library/tzdata/Pacific/Johnston index 7f9fee4..21ab39a 100644 --- a/library/tzdata/Pacific/Johnston +++ b/library/tzdata/Pacific/Johnston @@ -1,5 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Pacific/Johnston) { - {-9223372036854775808 -36000 0 HST} +if {![info exists TZData(Pacific/Honolulu)]} { + LoadTimeZoneFile Pacific/Honolulu } +set TZData(:Pacific/Johnston) $TZData(:Pacific/Honolulu) -- cgit v0.12 From ed5a6c598b93838fa631c454cc0bb1af031d3c88 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 6 Oct 2013 13:21:10 +0000 Subject: Factor out some knowledge of immediate index encoding. --- generic/tclCompCmdsGR.c | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index c5a0126..c5dddcb 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,6 +27,8 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); + +#define INDEX_END (-2) /* *---------------------------------------------------------------------- @@ -65,8 +67,8 @@ GetIndexFromToken( result = TCL_ERROR; } } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); - if (result == TCL_OK && idx > -2) { + result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx); + if (result == TCL_OK && idx > INDEX_END) { result = TCL_ERROR; } } @@ -1077,7 +1079,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2 /* == "end" */, envPtr); + TclEmitInt4( INDEX_END, envPtr); return TCL_OK; } @@ -1295,7 +1297,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); } return TCL_OK; } @@ -1440,14 +1442,14 @@ TclCompileLinsertCmd( /* * There are four main cases. If there are no values to insert, this is * just a confirm-listiness check. If the index is '0', this is a prepend. - * If the index is 'end' (== -2), this is an append. Otherwise, this is a - * splice (== split, insert values as list, concat-3). + * If the index is 'end' (== INDEX_END), this is an append. Otherwise, + * this is a splice (== split, insert values as list, concat-3). */ CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); return TCL_OK; } @@ -1460,7 +1462,7 @@ TclCompileLinsertCmd( if (idx == 0 /*start*/) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == -2 /*end*/) { + } else if (idx == INDEX_END /*end*/) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { if (idx < 0) { @@ -1471,7 +1473,7 @@ TclCompileLinsertCmd( TclEmitInt4( idx-1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -1533,13 +1535,13 @@ TclCompileLreplaceCmd( CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 4) { if (idx1 == 0) { - if (idx2 == -2) { + if (idx2 == INDEX_END) { goto dropAll; } idx1 = idx2 + 1; - idx2 = -2; + idx2 = INDEX_END; goto dropEnd; - } else if (idx2 == -2) { + } else if (idx2 == INDEX_END) { idx2 = idx1 - 1; idx1 = 0; goto dropEnd; @@ -1560,13 +1562,13 @@ TclCompileLreplaceCmd( TclEmitInstInt4( INST_LIST, i - 4, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (idx1 == 0) { - if (idx2 == -2) { + if (idx2 == INDEX_END) { goto replaceAll; } idx1 = idx2 + 1; - idx2 = -2; + idx2 = INDEX_END; goto replaceHead; - } else if (idx2 == -2) { + } else if (idx2 == INDEX_END) { idx2 = idx1 - 1; idx1 = 0; goto replaceTail; @@ -1620,7 +1622,7 @@ TclCompileLreplaceCmd( TclEmitInt4( idx1 - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); goto done; @@ -1669,7 +1671,7 @@ TclCompileLreplaceCmd( TclEmitInt4( idx1 - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( INDEX_END, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); -- cgit v0.12 From b64a70d3402ce6bbee1a32e8bb48e16144f3744d Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 6 Oct 2013 19:17:20 +0000 Subject: [3381085] Improved way of detecting what version of the documentation to build. Set the HTML_VERSION environment variable to override the (sensible) default. --- unix/Makefile.in | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 505f7e0..74dd150 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2076,6 +2076,9 @@ alldist: dist # build of this HTML documentation that has already been placed online. As # such, this rule is not guaranteed to work well on all systems; it only needs # to function on those of the Tcl/Tk maintainers. +# +# Also note that the 8.6 tool build requires an installed 8.6 native Tcl +# interpreter in order to be able to run. #-------------------------------------------------------------------------- html: ${NATIVE_TCLSH} @@ -2088,9 +2091,12 @@ html-tk: ${NATIVE_TCLSH} $(BUILD_HTML) --tk @EXTRA_BUILD_HTML@ +# You'd better have these programs or you will have problems creating Makefile +# from Makefile.in in the first place... +HTML_VERSION = `basename $(TOP_DIR) | sed s/tcl//` BUILD_HTML = \ @${NATIVE_TCLSH} $(TOOL_DIR)/tcltk-man2html.tcl \ - --htmldir="$(HTML_INSTALL_DIR)" \ + --useversion=$(HTML_VERSION) --htmldir="$(HTML_INSTALL_DIR)" \ --srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS) #-------------------------------------------------------------------------- -- cgit v0.12 From 4e6df409a8a45c4356447e304a5300a6324c3c09 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Oct 2013 19:27:50 +0000 Subject: First attempt to fix bug [d4e464ae48]: tcl 8.5.15/8.61 breaks python make check on darwin --- unix/tclUnixNotfy.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index ec721ca..f41ef68 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -202,7 +202,7 @@ static Tcl_ThreadId notifierThread; #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); -#ifdef HAVE_PTHREAD_ATFORK +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) static int atForkInit = 0; static void AtForkPrepare(void); static void AtForkParent(void); @@ -282,7 +282,7 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); -#ifdef HAVE_PTHREAD_ATFORK +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) /* * Install pthread_atfork handlers to reinitialize the notifier in the * child of a fork. @@ -296,7 +296,7 @@ Tcl_InitNotifier(void) } atForkInit = 1; } -#endif +#endif /* HAVE_PTHREAD_ATFORK */ /* * Check if my process id changed, e.g. I was forked * In this case, restart the notifier thread and close the @@ -1273,7 +1273,7 @@ NotifierThreadProc( TclpThreadExit (0); } -#ifdef HAVE_PTHREAD_ATFORK +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) /* *---------------------------------------------------------------------- * -- cgit v0.12 From 784987f7c11d9990ed7e2db04d85d42f177bdefd Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 8 Oct 2013 09:02:50 +0000 Subject: Working towards better handling of stack balance with break and continue exceptions. --- generic/tclAssembly.c | 1 + generic/tclCompCmds.c | 4 +- generic/tclCompCmdsSZ.c | 4 +- generic/tclCompExpr.c | 4 +- generic/tclCompile.c | 150 +++++++++++++++++++++++++++++++++++++++++++++++- generic/tclCompile.h | 1 + generic/tclEnsemble.c | 4 +- 7 files changed, 156 insertions(+), 12 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 946c729..08da075 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1450,6 +1450,7 @@ AssembleOneLine( goto cleanup; } + // FIXME - use TclEmitInvoke BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); break; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7e6b6da..942d74c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -269,7 +269,7 @@ TclCompileArraySetCmd( if (isDataValid && !isDataEven) { PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); goto done; } @@ -354,7 +354,7 @@ TclCompileArraySetCmd( TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); TclAdjustStackDepth(-1, envPtr); fwd = CurrentOffset(envPtr) - offsetFwd; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 44cb66e..a5ec731 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1965,7 +1965,7 @@ TclCompileThrowCmd( OP( LIST_LENGTH); OP1( JUMP_FALSE1, 16); OP4( LIST, 2); - OP44( RETURN_IMM, 1, 0); + OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); OP( POP); OP( POP); @@ -1974,7 +1974,7 @@ TclCompileThrowCmd( PUSH( "type must be non-empty list"); PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}"); } - OP44( RETURN_IMM, 1, 0); + OP44( RETURN_IMM, TCL_ERROR, 0); return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index d8e4d9f..94c1bd6 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2335,9 +2335,9 @@ CompileExprTree( */ if (numWords < 255) { - TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords); } else { - TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d15ef3a..a5b0bd8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1738,9 +1738,9 @@ TclCompileInvocation( } if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); } } @@ -1802,7 +1802,7 @@ CompileExpanded( * stack-neutral in general. */ - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED); envPtr->expandCount--; TclAdjustStackDepth(1 - wordIdx, envPtr); } @@ -3901,6 +3901,150 @@ TclFixupForwardJump( return 1; /* the jump was grown */ } +void +TclEmitInvoke( + CompileEnv *envPtr, + int opcode, + ...) +{ + va_list argList; + ExceptionRange *rangePtr; + ExceptionAux *auxBreakPtr, *auxContinuePtr; + int arg1, arg2, wordCount = 0, loopRange, predictedDepth; + + /* + * Parse the arguments. + */ + + va_start(argList, opcode); + switch (opcode) { + case INST_INVOKE_STK1: + wordCount = arg1 = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_STK4: + wordCount = arg1 = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_REPLACE: + arg1 = va_arg(argList, int); + arg2 = va_arg(argList, int); + wordCount = arg1 + arg2 - 1; + break; + default: + Tcl_Panic("unexpected opcode"); + case INST_INVOKE_EXPANDED: + wordCount = arg1 = arg2 = 0; + break; + } + va_end(argList); + + /* + * Determine if we need to handle break and continue exceptions with a + * special handling exception range (so that we can correctly unwind the + * stack). + */ + + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxBreakPtr = NULL; + } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount + && auxBreakPtr->expandTarget == envPtr->expandCount) { + auxBreakPtr = NULL; + } + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, + &auxContinuePtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxContinuePtr = NULL; + } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount + && auxContinuePtr->expandTarget == envPtr->expandCount) { + auxContinuePtr = NULL; + } + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + fprintf(stderr,"loop call(%s,d=%d/%d(%d/%d),t=%d/%d(%d))\n", + tclInstructionTable[opcode].name, + (auxBreakPtr?auxBreakPtr->stackDepth:-1), + (auxContinuePtr?auxContinuePtr->stackDepth:-1), + envPtr->currStackDepth, + wordCount, + (auxBreakPtr?auxBreakPtr->expandTarget:-1), + (auxContinuePtr?auxContinuePtr->expandTarget:-1), + envPtr->expandCount); + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, loopRange); + } + predictedDepth = envPtr->currStackDepth - wordCount; + + /* + * Issue the invoke itself. + */ + + switch (opcode) { + case INST_INVOKE_STK1: + TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr); + break; + case INST_INVOKE_STK4: + TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr); + break; + case INST_INVOKE_EXPANDED: + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + break; + case INST_INVOKE_REPLACE: + TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); + TclEmitInt1(arg2, envPtr); + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + break; + } + + /* + * If we're generating a special wrapper exception range, we need to + * finish that up now. + */ + + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + int savedStackDepth = envPtr->currStackDepth; + int savedExpandCount = envPtr->expandCount; + JumpFixup nonTrapFixup; + int off; + + ExceptionRangeEnds(envPtr, loopRange); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); + fprintf(stderr,"loop call(d=%d,t=%d|%p,%p)\n",savedStackDepth-1,savedExpandCount,auxBreakPtr,auxContinuePtr); + + /* + * Careful! When generating these stack unwinding sequences, the depth + * of stack in the cases where they are taken is not the same as if + * the exception is not taken. + */ + + if (auxBreakPtr != NULL) { + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + assert(envPtr->currStackDepth == predictedDepth); + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + off = CurrentOffset(envPtr); + TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); + fprintf(stderr,"popped(break):%ld\n",CurrentOffset(envPtr) - off); + TclAddLoopBreakFixup(envPtr, auxBreakPtr); + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + if (auxContinuePtr != NULL) { + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + assert(envPtr->currStackDepth == predictedDepth); + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + off = CurrentOffset(envPtr); + TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); + fprintf(stderr,"popped(continue):%ld\n",CurrentOffset(envPtr) - off); + TclAddLoopContinueFixup(envPtr, auxContinuePtr); + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); + } +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5660055..a39e0f1 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1021,6 +1021,7 @@ MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr); +MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index ad11785..9bb7a0c 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3179,9 +3179,7 @@ CompileToInvokedCommand( * Do the replacing dispatch. */ - TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); - TclEmitInt1(numWords+1, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); } /* -- cgit v0.12 From 891ebfad72cbbda3e8be4ddba83efc541e6cce03 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Oct 2013 21:57:26 +0000 Subject: Update to Unicode 6.3 tables --- generic/regc_locale.c | 22 +++--- generic/tclUniData.c | 196 +++++++++++++++++++++++++------------------------- 2 files changed, 110 insertions(+), 108 deletions(-) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index dd1c01c..69459f1 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -118,7 +118,7 @@ static const struct cname { * Unicode character-class tables. */ -typedef struct crange { +typedef struct { chr start; chr end; } crange; @@ -260,7 +260,7 @@ static const chr alphaCharTable[] = { static const crange controlRangeTable[] = { {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, - {0x202a, 0x202e}, {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, + {0x202a, 0x202e}, {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} #if TCL_UTF_MAX > 4 ,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd} @@ -270,7 +270,7 @@ static const crange controlRangeTable[] = { #define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange)) static const chr controlCharTable[] = { - 0xad, 0x6dd, 0x70f, 0xfeff + 0xad, 0x61c, 0x6dd, 0x70f, 0x180e, 0xfeff #if TCL_UTF_MAX > 4 ,0x110bd, 0xe0001 #endif @@ -316,12 +316,13 @@ static const crange punctRangeTable[] = { {0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad}, {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, - {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db}, - {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003}, - {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7}, - {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f}, - {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, - {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65} + {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, + {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, + {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, + {0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, + {0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, + {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, + {0xff5f, 0xff65} #if TCL_UTF_MAX > 4 ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10b39, 0x10b3f}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x12470, 0x12473} @@ -361,7 +362,8 @@ static const crange spaceRangeTable[] = { #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x3000 + 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x2060, + 0x3000, 0xfeff }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 5c88639..a0d4ccc 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -624,7 +624,7 @@ static const unsigned char groupMap[] = { 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 0, 7, 7, 7, 3, 3, - 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 0, + 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 17, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, @@ -792,118 +792,118 @@ static const unsigned char groupMap[] = { 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 3, 85, 3, 3, 3, 4, 15, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, - 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 2, 0, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, + 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 17, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, + 86, 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, + 116, 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, 86, - 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, 116, - 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, 116, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, - 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, + 15, 15, 15, 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, 116, 116, - 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 86, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, - 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116, - 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, 116, 116, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, 15, 15, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, 116, 116, - 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, 116, 116, - 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, + 116, 86, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, + 86, 86, 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, + 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, + 0, 86, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, + 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, + 86, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 86, 116, 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, + 116, 116, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, + 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, + 116, 116, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, + 116, 116, 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, + 116, 116, 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, + 86, 86, 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, 86, - 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, 21, - 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, 124, - 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, 124, - 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, - 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, 123, - 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, - 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, 123, - 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, 123, - 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, 126, - 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, 123, - 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, 123, - 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, - 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, - 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, 133, - 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, 136, - 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, 137, - 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, 138, - 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, 140, - 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17, - 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3, - 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, - 17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18, - 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100, - 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100, - 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100, - 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21, - 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, 147, - 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, - 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, - 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, 18, - 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, - 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, + 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, + 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, + 21, 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, + 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, + 124, 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, + 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, + 123, 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, + 123, 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, + 123, 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, + 123, 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, + 126, 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, + 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, + 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, + 131, 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, + 131, 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, + 133, 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, + 136, 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, + 137, 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, + 138, 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, + 140, 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, + 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, + 3, 3, 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, + 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, + 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, + 100, 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, + 100, 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, + 100, 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, + 21, 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, + 147, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, + 148, 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, + 149, 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, + 18, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, + 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, - 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, + 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -- cgit v0.12 From 43a91548b31101b95bc2b2e29ada872bb3d9590e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Oct 2013 14:13:51 +0000 Subject: Fix for bug [f51efe99a7]: MinGW build fails on current checkin. And a new test-case which makes the problem visible on UNIX as well. --- generic/tclOO.h | 5 +- generic/tclOODecls.h | 2 + generic/tclOOStubLib.c | 2 + tests/load.test | 6 +++ unix/dltest/Makefile.in | 13 ++++- unix/dltest/pkgooa.c | 138 ++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 161 insertions(+), 5 deletions(-) create mode 100644 unix/dltest/pkgooa.c diff --git a/generic/tclOO.h b/generic/tclOO.h index 41be168..a6e8a22 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -37,13 +37,12 @@ extern "C" { #endif -#if (defined(USE_TCLOO_STUBS) || defined(USE_TCL_STUBS)) extern const char *TclOOInitializeStubs( Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) \ TclOOInitializeStubs((interp), TCLOO_VERSION) -#else -#define Tcl_OOInitStubs(interp) (TCLOO_PATCHLEVEL) +#ifndef USE_TCL_STUBS +# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) #endif /* diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index c2a5615..e483df6 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -10,6 +10,8 @@ # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS +# undef USE_TCLOO_STUBS +# define USE_TCLOO_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 921aced..a9fa212 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -27,6 +27,8 @@ const TclOOIntStubs *tclOOIntStubsPtr = NULL; *---------------------------------------------------------------------- */ +#undef TclOOInitializeStubs + MODULE_SCOPE const char * TclOOInitializeStubs( Tcl_Interp *interp, diff --git a/tests/load.test b/tests/load.test index cded85d..9536271 100644 --- a/tests/load.test +++ b/tests/load.test @@ -215,6 +215,12 @@ test load-10.1 {load from vfs} \ -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ -result {0 {}} \ -cleanup {testsimplefilesystem 0; cd $dir; unset dir} + +test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ + [list $dll $loaded] { + load [file join $testDir pkgooa$ext] + list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] +} {1 pkgooa_stubsok} # cleanup unset ext diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 01589d9..f64b6d5 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -25,11 +25,11 @@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -I${BUILD_DIR}/.. -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} +all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} pkgooa${SHLIB_SUFFIX} @if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi @touch ../dltest.marker -dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} +dltest_suffix: pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgd${DLTEST_SUFFIX} pkge${DLTEST_SUFFIX} pkgua${DLTEST_SUFFIX} pkgooa${DLTEST_SUFFIX} @touch ../dltest.marker pkga.o: $(SRC_DIR)/pkga.c @@ -50,6 +50,9 @@ pkge.o: $(SRC_DIR)/pkge.c pkgua.o: $(SRC_DIR)/pkgua.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c +pkgooa.o: $(SRC_DIR)/pkgooa.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c + pkga${SHLIB_SUFFIX}: pkga.o ${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${SHLIB_LD_LIBS} @@ -68,6 +71,9 @@ pkge${SHLIB_SUFFIX}: pkge.o pkgua${SHLIB_SUFFIX}: pkgua.o ${SHLIB_LD} -o pkgua${SHLIB_SUFFIX} pkgua.o ${SHLIB_LD_LIBS} +pkgooa${SHLIB_SUFFIX}: pkgooa.o + ${SHLIB_LD} -o pkgooa${SHLIB_SUFFIX} pkgooa.o ${SHLIB_LD_LIBS} + pkga${DLTEST_SUFFIX}: pkga.o ${DLTEST_LD} -o pkga${DLTEST_SUFFIX} pkga.o ${SHLIB_LD_LIBS} @@ -86,6 +92,9 @@ pkge${DLTEST_SUFFIX}: pkge.o pkgua${DLTEST_SUFFIX}: pkgua.o ${DLTEST_LD} -o pkgua${DLTEST_SUFFIX} pkgua.o ${SHLIB_LD_LIBS} +pkgooa${DLTEST_SUFFIX}: pkgooa.o + ${DLTEST_LD} -o pkgooa${DLTEST_SUFFIX} pkgooa.o ${SHLIB_LD_LIBS} + clean: rm -f *.o lib.exp ../dltest.marker @if test "$(SHLIB_SUFFIX)" != ""; then \ diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c new file mode 100644 index 0000000..bdac9db --- /dev/null +++ b/unix/dltest/pkgooa.c @@ -0,0 +1,138 @@ +/* + * pkgooa.c -- + * + * This file contains a simple Tcl package "pkgooa" that is intended for + * testing the Tcl dynamic loading facilities. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#undef STATIC_BUILD +#include "tclOO.h" +#include + +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Pkgooa_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgooa_StubsOKObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + + +/* + *---------------------------------------------------------------------- + * + * Pkgooa_StubsOKObjCmd -- + * + * This procedure is invoked to process the "pkgooa_stubsok" Tcl command. + * It gives 1 if stubs are used correctly, 0 if stubs are not OK. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgooa_StubsOKObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_CopyObjectInstance == tclOOStubsPtr->tcl_CopyObjectInstance)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgooa_Init -- + * + * This is a package initialization procedure, which is called by Tcl + * when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Object copyObjectInstance(Tcl_Interp *interp, + Tcl_Object source, const char *name, const char *nameSpace) +{ + Tcl_Object result; + result = Tcl_CopyObjectInstance(interp, source, name, nameSpace); + if (result == NULL) { + Tcl_AppendResult(interp, "ERROR: copy failed."); + } + return result; +} + +static TclOOStubs stubsCopy = { + TCL_STUB_MAGIC, + NULL, + copyObjectInstance + /* more entries here, but those are not + * needed for this test-case. */ +}; + +EXTERN int +Pkgooa_Init( + Tcl_Interp *interp) /* Interpreter in which the package is to be + * made available. */ +{ + int code; + + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_OOInitStubs(interp) == NULL) { + return TCL_ERROR; + } + + /* Test case for Bug [f51efe99a7]. + * + * Let tclOOStubsPtr point to an alternate stub table + * (with only a single function, that's enough for + * this test). This way, the function "pkgooa_stubsok" + * can check whether the TclOO function calls really + * use the stub table, or only pretend to. + * + * On platforms without backlinking (Windows, Cygwin, + * AIX), this code doesn't even compile without using + * stubs, but on UNIX ELF systems, the problem is + * less visible. + */ + + tclOOStubsPtr = &stubsCopy; + + code = Tcl_PkgProvide(interp, "Pkgooa", "1.0"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateObjCommand(interp, "pkgooa_stubsok", Pkgooa_StubsOKObjCmd, NULL, NULL); + return TCL_OK; +} -- cgit v0.12 From 7d1b223f7df36d45707d0c6325c3c5665b324724 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 10 Oct 2013 21:24:15 +0000 Subject: [98c8b3ec12] Use constraint to work around failing test; it's just a bug in the underlying library, and one that appears fixed in later versions. Not our fault if some OSes don't update. (It's also in a very esoteric spot.) --- tests/zlib.test | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/tests/zlib.test b/tests/zlib.test index 0712929..4e51ebb 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -16,6 +16,13 @@ if {"::tcltest" ni [namespace children]} { } testConstraint zlib [llength [info commands zlib]] +testConstraint recentZlib 0 +catch { + # Work around a bug in some versions of zlib; known to manifest on at + # least Mac OS X Mountain Lion... + testConstraint recentZlib \ + [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6] +} test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { zlib @@ -269,7 +276,7 @@ test zlib-8.9 {transformation and fconfigure} -setup { } -result {3064818174 358 358} test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide -} -constraints zlib -body { +} -constraints {zlib recentZlib} -body { zlib push deflate $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary -- cgit v0.12 From 1fa1578500c58be8eed071fcbdce604c32b418cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Oct 2013 10:26:35 +0000 Subject: Even though TCLOO_PATCHLEVEL is equal to TCLOO_VERSION, using "patchlevel" is more appropriate in those two places. --- generic/tclOO.c | 2 +- tests/oo.test | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index cb22de6..529640f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -271,7 +271,7 @@ TclOOInit( return TCL_ERROR; } - return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_VERSION, + return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, (ClientData) &tclOOStubs); } diff --git a/tests/oo.test b/tests/oo.test index 37bbadb..d63e931 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -101,7 +101,7 @@ test oo-0.8 {leak in variable management} -setup { test oo-0.9 {various types of presence of the TclOO package} { list [lsearch -nocase -all -inline [package names] tcloo] \ [package present TclOO] [package versions TclOO] -} [list TclOO $::oo::version $::oo::version] +} [list TclOO $::oo::patchlevel $::oo::patchlevel] test oo-1.1 {basic test of OO functionality: no classes} { set result {} -- cgit v0.12 From 2dc26cc732ba64065c0bf64d8c63a2c82c539999 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Oct 2013 10:45:08 +0000 Subject: Allow loading of pkgooa.so in Tcl 8.5 for (regression) test purposes. Better error messages in stead of crashes in some (hypothetical) error situations. --- unix/dltest/pkgooa.c | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index bdac9db..c0c1605 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -106,12 +106,29 @@ Pkgooa_Init( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + /* Any TclOO extension which uses stubs, calls + * both Tcl_InitStubs and Tcl_OOInitStubs() and + * does not use any Tcl 8.6 features should be + * loadable in Tcl 8.5 as well, provided the + * TclOO extension (for Tcl 8.5) is installed. + * This worked in Tcl 8.6.0, and is expected + * to keep working in all future Tcl 8.x releases. + */ + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + return TCL_ERROR; + } + if (tclStubsPtr == NULL) { + Tcl_AppendResult(interp, "Tcl stubs are not inialized, " + "did you compile using -DUSE_TCL_STUBS? "); return TCL_ERROR; } if (Tcl_OOInitStubs(interp) == NULL) { return TCL_ERROR; } + if (tclOOStubsPtr == NULL) { + Tcl_AppendResult(interp, "TclOO stubs are not inialized"); + return TCL_ERROR; + } /* Test case for Bug [f51efe99a7]. * -- cgit v0.12 From 18620aebd7623aaa3031162500c392cf2fa6ade7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 Oct 2013 12:09:22 +0000 Subject: Stop crashing in interactive testing. (The unknown and history mechanisms tend to exercise some parts of the bytecode compiler very well.) --- generic/tclCompile.c | 49 ++++++++++++++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a5b0bd8..74a9c8c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3911,6 +3911,7 @@ TclEmitInvoke( ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; int arg1, arg2, wordCount = 0, loopRange, predictedDepth; + int breakRange = -1, continueRange = -1; /* * Parse the arguments. @@ -3943,6 +3944,9 @@ TclEmitInvoke( * Determine if we need to handle break and continue exceptions with a * special handling exception range (so that we can correctly unwind the * stack). + * + * These must be done separately; they can be different (especially for + * calls from inside a [for] increment clause). */ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); @@ -3951,7 +3955,10 @@ TclEmitInvoke( } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount && auxBreakPtr->expandTarget == envPtr->expandCount) { auxBreakPtr = NULL; + } else { + breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; } + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxContinuePtr); if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { @@ -3959,17 +3966,11 @@ TclEmitInvoke( } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount && auxContinuePtr->expandTarget == envPtr->expandCount) { auxContinuePtr = NULL; + } else { + continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; } + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - fprintf(stderr,"loop call(%s,d=%d/%d(%d/%d),t=%d/%d(%d))\n", - tclInstructionTable[opcode].name, - (auxBreakPtr?auxBreakPtr->stackDepth:-1), - (auxContinuePtr?auxContinuePtr->stackDepth:-1), - envPtr->currStackDepth, - wordCount, - (auxBreakPtr?auxBreakPtr->expandTarget:-1), - (auxContinuePtr?auxContinuePtr->expandTarget:-1), - envPtr->expandCount); loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); ExceptionRangeStarts(envPtr, loopRange); } @@ -4005,11 +4006,17 @@ TclEmitInvoke( int savedStackDepth = envPtr->currStackDepth; int savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; - int off; + ExceptionAux *exceptAux = envPtr->exceptAuxArrayPtr + loopRange; + + if (auxBreakPtr != NULL) { + auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; + } + if (auxContinuePtr != NULL) { + auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange; + } ExceptionRangeEnds(envPtr, loopRange); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); - fprintf(stderr,"loop call(d=%d,t=%d|%p,%p)\n",savedStackDepth-1,savedExpandCount,auxBreakPtr,auxContinuePtr); /* * Careful! When generating these stack unwinding sequences, the depth @@ -4018,25 +4025,29 @@ TclEmitInvoke( */ if (auxBreakPtr != NULL) { - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + TclAdjustStackDepth(-1, envPtr); assert(envPtr->currStackDepth == predictedDepth); + exceptAux->stackDepth = auxBreakPtr->stackDepth; + exceptAux->expandTarget = auxBreakPtr->expandTarget; + ExceptionRangeTarget(envPtr, loopRange, breakOffset); - off = CurrentOffset(envPtr); - TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); - fprintf(stderr,"popped(break):%ld\n",CurrentOffset(envPtr) - off); + TclCleanupStackForBreakContinue(envPtr, exceptAux); TclAddLoopBreakFixup(envPtr, auxBreakPtr); + envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; } if (auxContinuePtr != NULL) { - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + TclAdjustStackDepth(-1, envPtr); assert(envPtr->currStackDepth == predictedDepth); + exceptAux->stackDepth = auxContinuePtr->stackDepth; + exceptAux->expandTarget = auxContinuePtr->expandTarget; + ExceptionRangeTarget(envPtr, loopRange, continueOffset); - off = CurrentOffset(envPtr); - TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); - fprintf(stderr,"popped(continue):%ld\n",CurrentOffset(envPtr) - off); + TclCleanupStackForBreakContinue(envPtr, exceptAux); TclAddLoopContinueFixup(envPtr, auxContinuePtr); + envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; } -- cgit v0.12 From 62cb43456456d34b7a1b738feb2d2114915aff3c Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 Oct 2013 13:34:01 +0000 Subject: update comments --- generic/tclCompCmdsGR.c | 1 + generic/tclCompile.c | 21 +++++++++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 43ea3d3..3efcba7 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2480,6 +2480,7 @@ TclCompileReturnCmd( * emit the INST_RETURN_IMM instruction with code and level as operands. */ + // TODO: when (code==TCL_BREAK || code==TCL_CONTINUE)&&(level==0&&size==0), check for stack balance and jump opportunities CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 74a9c8c..68b7649 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3901,6 +3901,27 @@ TclFixupForwardJump( return 1; /* the jump was grown */ } +/* + *---------------------------------------------------------------------- + * + * TclEmitInvoke -- + * + * Emit one of the invoke-related instructions, wrapping it if necessary + * in code that ensures that any break or continue operation passing + * through it gets the stack unwinding correct, converting it into an + * internal jump if in an appropriate context. + * + * Results: + * None + * + * Side effects: + * Issues the jump with all correct stack management. May create another + * loop exception range; pointers to ExceptionRange and ExceptionAux + * structures should not be held across this call. + * + *---------------------------------------------------------------------- + */ + void TclEmitInvoke( CompileEnv *envPtr, -- cgit v0.12 From 9adfa74f671acd5bcc33247b07176d117eda3357 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 Oct 2013 13:57:27 +0000 Subject: Added the tests I want to pass... --- tests/for.test | 126 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 126 insertions(+) diff --git a/tests/for.test b/tests/for.test index 8936682..6a18abe 100644 --- a/tests/for.test +++ b/tests/for.test @@ -942,6 +942,132 @@ test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} expr {$end - $tmp} }} } 0 +test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code break}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code continue}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} { + return -code continue + }}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From d02f468b979104d4c98a39347be7960486530e1c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Oct 2013 08:11:59 +0000 Subject: Fix comment in tclOO.decls: tclOOStubLib.c is not generated by "make genstubs". In pkgooa.c, check whether the internal TclOO stub table is initialized correctly as well, some internal simplifications and improved comments. --- generic/tclOO.decls | 3 +-- unix/dltest/pkgooa.c | 48 ++++++++++++++++-------------------------------- 2 files changed, 17 insertions(+), 34 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 4f1987c..5d6f2c2 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -3,8 +3,7 @@ # This file contains the declarations for all supported public functions # that are exported by the TclOO package that is embedded within the Tcl # library via the stubs table. This file is used to generate the -# tclOODecls.h, tclOOIntDecls.h, tclOOStubInit.c, and tclOOStubLib.c -# files. +# tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files. # # Copyright (c) 2008-2013 by Donal K. Fellows. # diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index c0c1605..7b14ca0 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -11,24 +11,8 @@ */ #undef STATIC_BUILD -#include "tclOO.h" +#include "tclOOInt.h" #include - -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Pkgooa_Init declaration is in the source file itself, which is only - * accessed when we are building a library. - */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT - -/* - * Prototypes for procedures defined later in this file: - */ - -static int Pkgooa_StubsOKObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - /* *---------------------------------------------------------------------- @@ -80,26 +64,22 @@ Pkgooa_StubsOKObjCmd( *---------------------------------------------------------------------- */ -static Tcl_Object copyObjectInstance(Tcl_Interp *interp, - Tcl_Object source, const char *name, const char *nameSpace) -{ - Tcl_Object result; - result = Tcl_CopyObjectInstance(interp, source, name, nameSpace); - if (result == NULL) { - Tcl_AppendResult(interp, "ERROR: copy failed."); - } - return result; -} - static TclOOStubs stubsCopy = { TCL_STUB_MAGIC, NULL, - copyObjectInstance - /* more entries here, but those are not - * needed for this test-case. */ + /* It doesn't really matter what implementation of + * Tcl_CopyObjectInstance is put in the "pseudo" + * stub table, since the test-case never actually + * calls this function. All that matters is that it's + * a function with a different memory address than + * the real Tcl_CopyObjectInstance function in Tcl. */ + (Tcl_Object (*) (Tcl_Interp *, Tcl_Object, const char *, + const char *t)) Pkgooa_StubsOKObjCmd + /* More entries could be here, but those are not used + * for this test-case. So, being NULL is OK. */ }; -EXTERN int +extern DLLEXPORT int Pkgooa_Init( Tcl_Interp *interp) /* Interpreter in which the package is to be * made available. */ @@ -129,6 +109,10 @@ Pkgooa_Init( Tcl_AppendResult(interp, "TclOO stubs are not inialized"); return TCL_ERROR; } + if (tclOOIntStubsPtr == NULL) { + Tcl_AppendResult(interp, "TclOO internal stubs are not inialized"); + return TCL_ERROR; + } /* Test case for Bug [f51efe99a7]. * -- cgit v0.12 From 71bcf95b719518cd64e068921561bcd2a503598e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Oct 2013 08:34:48 +0000 Subject: Tcl_SetResult -> Tcl_SetObjResult in two places (for Cygwin64 only). --- generic/tclStubInit.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 782bbdf..3f1c27b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -234,9 +234,8 @@ static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); result = TCL_ERROR; } } @@ -251,9 +250,8 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); result = TCL_ERROR; } } -- cgit v0.12 From 21e6601f4971f249f7681508432b98605729fb9d Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 15 Oct 2013 00:27:56 +0000 Subject: Do jump generation at places where INST_RETURN_IMM might occur. --- generic/tclCompCmdsGR.c | 18 +++++++++++++- generic/tclCompile.c | 6 +---- generic/tclOptimize.c | 18 +++++++++++++- tests/compile.test | 64 +++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 99 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3efcba7..5513b01 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2480,7 +2480,6 @@ TclCompileReturnCmd( * emit the INST_RETURN_IMM instruction with code and level as operands. */ - // TODO: when (code==TCL_BREAK || code==TCL_CONTINUE)&&(level==0&&size==0), check for stack balance and jump opportunities CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; @@ -2522,6 +2521,23 @@ CompileReturnInternal( int level, Tcl_Obj *returnOpts) { + if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) { + ExceptionRange *rangePtr; + ExceptionAux *exceptAux; + + rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + TclCleanupStackForBreakContinue(envPtr, exceptAux); + if (code == TCL_BREAK) { + TclAddLoopBreakFixup(envPtr, exceptAux); + } else { + TclAddLoopContinueFixup(envPtr, exceptAux); + } + Tcl_DecrRefCount(returnOpts); + return; + } + } + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(op, code, envPtr); TclEmitInt4(level, envPtr); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 68b7649..427ccab 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3931,8 +3931,7 @@ TclEmitInvoke( va_list argList; ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; - int arg1, arg2, wordCount = 0, loopRange, predictedDepth; - int breakRange = -1, continueRange = -1; + int arg1, arg2, wordCount = 0, loopRange, breakRange, continueRange; /* * Parse the arguments. @@ -3995,7 +3994,6 @@ TclEmitInvoke( loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); ExceptionRangeStarts(envPtr, loopRange); } - predictedDepth = envPtr->currStackDepth - wordCount; /* * Issue the invoke itself. @@ -4047,7 +4045,6 @@ TclEmitInvoke( if (auxBreakPtr != NULL) { TclAdjustStackDepth(-1, envPtr); - assert(envPtr->currStackDepth == predictedDepth); exceptAux->stackDepth = auxBreakPtr->stackDepth; exceptAux->expandTarget = auxBreakPtr->expandTarget; @@ -4061,7 +4058,6 @@ TclEmitInvoke( if (auxContinuePtr != NULL) { TclAdjustStackDepth(-1, envPtr); - assert(envPtr->currStackDepth == predictedDepth); exceptAux->stackDepth = auxContinuePtr->stackDepth; exceptAux->expandTarget = auxContinuePtr->expandTarget; diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index b7f4173..3b16e6e 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -344,21 +344,28 @@ AdvanceJumps( CompileEnv *envPtr) { unsigned char *currentInstPtr; + Tcl_HashTable jumps; for (currentInstPtr = envPtr->codeStart ; currentInstPtr < envPtr->codeNext-1 ; currentInstPtr += AddrLength(currentInstPtr)) { - int offset, delta; + int offset, delta, isNew; switch (*currentInstPtr) { case INST_JUMP1: case INST_JUMP_TRUE1: case INST_JUMP_FALSE1: offset = TclGetInt1AtPtr(currentInstPtr + 1); + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); for (delta=0 ; offset+delta != 0 ;) { if (offset + delta < -128 || offset + delta > 127) { break; } + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt1AtPtr(currentInstPtr + 1); + break; + } offset += delta; switch (*(currentInstPtr + offset)) { case INST_NOP: @@ -373,13 +380,21 @@ AdvanceJumps( } break; } + Tcl_DeleteHashTable(&jumps); TclStoreInt1AtPtr(offset, currentInstPtr + 1); continue; case INST_JUMP4: case INST_JUMP_TRUE4: case INST_JUMP_FALSE4: + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); + Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew); for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt4AtPtr(currentInstPtr + 1); + break; + } switch (*(currentInstPtr + offset)) { case INST_NOP: offset += InstLength(INST_NOP); @@ -393,6 +408,7 @@ AdvanceJumps( } break; } + Tcl_DeleteHashTable(&jumps); TclStoreInt4AtPtr(offset, currentInstPtr + 1); continue; } diff --git a/tests/compile.test b/tests/compile.test index 51db0a2..36e24de 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -713,6 +713,70 @@ test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { apply {{} {list [if 1]}} } -returnCodes error -match glob -result * +test compile-20.1 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + return -code continue -level 0 + } + } + return +} {} +test compile-20.2 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + while 1 { + return -code break -level 0 + } + } + } + return +} {} + +test compile-21.1 {stack balance management} { + apply {{} { + set result {} + while 1 { + lappend result a + lappend result [list b [break]] + lappend result c + } + return $result + }} +} a +test compile-21.2 {stack balance management} { + apply {{} { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [list b [continue] c] + lappend result c + } + return $result + }} +} {1 2 3 4 5 6 7 8 9 10} +test compile-21.3 {stack balance management} { + apply {args { + set result {} + while 1 { + lappend result a + lappend result [concat {*}$args [break]] + lappend result c + } + return $result + }} P Q R S T +} a +test compile-21.4 {stack balance management} { + apply {args { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [concat {*}$args [continue] c] + lappend result c + } + return $result + }} P Q R S T +} {1 2 3 4 5 6 7 8 9 10} + # TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup -- cgit v0.12 From d0041f33437e9af324059ed08c7f158fbb1fef19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Oct 2013 21:09:19 +0000 Subject: -I${BUILD_DIR}/.. doesn't work when BUILD_DIR != "unix". Reported by Matthias Kraft --- unix/dltest/Makefile.in | 2 +- unix/dltest/pkgooa.c | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index f64b6d5..25b9376 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -22,7 +22,7 @@ LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ -CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -I${BUILD_DIR}/.. -DTCL_MEM_DEBUG \ +CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} pkgua${SHLIB_SUFFIX} pkgooa${SHLIB_SUFFIX} diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 7b14ca0..78af376 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -11,7 +11,7 @@ */ #undef STATIC_BUILD -#include "tclOOInt.h" +#include "tclOO.h" #include /* @@ -64,6 +64,8 @@ Pkgooa_StubsOKObjCmd( *---------------------------------------------------------------------- */ +extern void *tclOOIntStubsPtr; + static TclOOStubs stubsCopy = { TCL_STUB_MAGIC, NULL, -- cgit v0.12 From 19365e8ffd408a387d99496423bd1d1ef04e492a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Oct 2013 09:28:11 +0000 Subject: Fix execute permission on many files which shouldn't have it. --- generic/tclStrToD.c | 0 library/encoding/tis-620.enc | 0 library/msgs/af.msg | 0 library/msgs/af_za.msg | 0 library/msgs/ar.msg | 0 library/msgs/ar_in.msg | 0 library/msgs/ar_jo.msg | 0 library/msgs/ar_lb.msg | 0 library/msgs/ar_sy.msg | 0 library/msgs/be.msg | 0 library/msgs/bg.msg | 0 library/msgs/bn.msg | 0 library/msgs/bn_in.msg | 0 library/msgs/ca.msg | 0 library/msgs/cs.msg | 0 library/msgs/da.msg | 0 library/msgs/de.msg | 0 library/msgs/de_at.msg | 0 library/msgs/de_be.msg | 0 library/msgs/el.msg | 0 library/msgs/en_au.msg | 0 library/msgs/en_be.msg | 0 library/msgs/en_bw.msg | 0 library/msgs/en_ca.msg | 0 library/msgs/en_gb.msg | 0 library/msgs/en_hk.msg | 0 library/msgs/en_ie.msg | 0 library/msgs/en_in.msg | 0 library/msgs/en_nz.msg | 0 library/msgs/en_ph.msg | 0 library/msgs/en_sg.msg | 0 library/msgs/en_za.msg | 0 library/msgs/en_zw.msg | 0 library/msgs/eo.msg | 0 library/msgs/es.msg | 0 library/msgs/es_ar.msg | 0 library/msgs/es_bo.msg | 0 library/msgs/es_cl.msg | 0 library/msgs/es_co.msg | 0 library/msgs/es_cr.msg | 0 library/msgs/es_do.msg | 0 library/msgs/es_ec.msg | 0 library/msgs/es_gt.msg | 0 library/msgs/es_hn.msg | 0 library/msgs/es_mx.msg | 0 library/msgs/es_ni.msg | 0 library/msgs/es_pa.msg | 0 library/msgs/es_pe.msg | 0 library/msgs/es_pr.msg | 0 library/msgs/es_py.msg | 0 library/msgs/es_sv.msg | 0 library/msgs/es_uy.msg | 0 library/msgs/es_ve.msg | 0 library/msgs/et.msg | 0 library/msgs/eu.msg | 0 library/msgs/eu_es.msg | 0 library/msgs/fa.msg | 0 library/msgs/fa_in.msg | 0 library/msgs/fa_ir.msg | 0 library/msgs/fi.msg | 0 library/msgs/fo.msg | 0 library/msgs/fo_fo.msg | 0 library/msgs/fr.msg | 0 library/msgs/fr_be.msg | 0 library/msgs/fr_ca.msg | 0 library/msgs/fr_ch.msg | 0 library/msgs/ga.msg | 0 library/msgs/ga_ie.msg | 0 library/msgs/gl.msg | 0 library/msgs/gl_es.msg | 0 library/msgs/gv.msg | 0 library/msgs/gv_gb.msg | 0 library/msgs/he.msg | 0 library/msgs/hi.msg | 0 library/msgs/hi_in.msg | 0 library/msgs/hr.msg | 0 library/msgs/hu.msg | 0 library/msgs/id.msg | 0 library/msgs/id_id.msg | 0 library/msgs/is.msg | 0 library/msgs/it.msg | 0 library/msgs/it_ch.msg | 0 library/msgs/ja.msg | 0 library/msgs/kl.msg | 0 library/msgs/kl_gl.msg | 0 library/msgs/ko.msg | 0 library/msgs/ko_kr.msg | 0 library/msgs/kok.msg | 0 library/msgs/kok_in.msg | 0 library/msgs/kw.msg | 0 library/msgs/kw_gb.msg | 0 library/msgs/lt.msg | 0 library/msgs/lv.msg | 0 library/msgs/mk.msg | 0 library/msgs/mr.msg | 0 library/msgs/mr_in.msg | 0 library/msgs/ms.msg | 0 library/msgs/ms_my.msg | 0 library/msgs/mt.msg | 0 library/msgs/nb.msg | 0 library/msgs/nl.msg | 0 library/msgs/nl_be.msg | 0 library/msgs/nn.msg | 0 library/msgs/pl.msg | 0 library/msgs/pt.msg | 0 library/msgs/pt_br.msg | 0 library/msgs/ro.msg | 0 library/msgs/ru.msg | 0 library/msgs/ru_ua.msg | 0 library/msgs/sh.msg | 0 library/msgs/sk.msg | 0 library/msgs/sl.msg | 0 library/msgs/sq.msg | 0 library/msgs/sr.msg | 0 library/msgs/sv.msg | 0 library/msgs/sw.msg | 0 library/msgs/ta.msg | 0 library/msgs/ta_in.msg | 0 library/msgs/te.msg | 0 library/msgs/te_in.msg | 0 library/msgs/th.msg | 0 library/msgs/tr.msg | 0 library/msgs/uk.msg | 0 library/msgs/vi.msg | 0 library/msgs/zh.msg | 0 library/msgs/zh_cn.msg | 0 library/msgs/zh_hk.msg | 0 library/msgs/zh_sg.msg | 0 library/msgs/zh_tw.msg | 0 library/tzdata/Africa/Asmara | 0 library/tzdata/America/Atikokan | 0 library/tzdata/America/Blanc-Sablon | 0 library/tzdata/America/Indiana/Petersburg | 0 library/tzdata/America/Indiana/Tell_City | 0 library/tzdata/America/Indiana/Vincennes | 0 library/tzdata/America/Indiana/Winamac | 0 library/tzdata/America/Moncton | 0 library/tzdata/America/North_Dakota/New_Salem | 0 library/tzdata/America/Resolute | 0 library/tzdata/Atlantic/Faroe | 0 library/tzdata/Australia/Eucla | 0 library/tzdata/Europe/Guernsey | 0 library/tzdata/Europe/Isle_of_Man | 0 library/tzdata/Europe/Jersey | 0 library/tzdata/Europe/Podgorica | 0 library/tzdata/Europe/Volgograd | 0 tools/encoding/ebcdic.txt | 0 tools/encoding/tis-620.txt | 0 148 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 generic/tclStrToD.c mode change 100755 => 100644 library/encoding/tis-620.enc mode change 100755 => 100644 library/msgs/af.msg mode change 100755 => 100644 library/msgs/af_za.msg mode change 100755 => 100644 library/msgs/ar.msg mode change 100755 => 100644 library/msgs/ar_in.msg mode change 100755 => 100644 library/msgs/ar_jo.msg mode change 100755 => 100644 library/msgs/ar_lb.msg mode change 100755 => 100644 library/msgs/ar_sy.msg mode change 100755 => 100644 library/msgs/be.msg mode change 100755 => 100644 library/msgs/bg.msg mode change 100755 => 100644 library/msgs/bn.msg mode change 100755 => 100644 library/msgs/bn_in.msg mode change 100755 => 100644 library/msgs/ca.msg mode change 100755 => 100644 library/msgs/cs.msg mode change 100755 => 100644 library/msgs/da.msg mode change 100755 => 100644 library/msgs/de.msg mode change 100755 => 100644 library/msgs/de_at.msg mode change 100755 => 100644 library/msgs/de_be.msg mode change 100755 => 100644 library/msgs/el.msg mode change 100755 => 100644 library/msgs/en_au.msg mode change 100755 => 100644 library/msgs/en_be.msg mode change 100755 => 100644 library/msgs/en_bw.msg mode change 100755 => 100644 library/msgs/en_ca.msg mode change 100755 => 100644 library/msgs/en_gb.msg mode change 100755 => 100644 library/msgs/en_hk.msg mode change 100755 => 100644 library/msgs/en_ie.msg mode change 100755 => 100644 library/msgs/en_in.msg mode change 100755 => 100644 library/msgs/en_nz.msg mode change 100755 => 100644 library/msgs/en_ph.msg mode change 100755 => 100644 library/msgs/en_sg.msg mode change 100755 => 100644 library/msgs/en_za.msg mode change 100755 => 100644 library/msgs/en_zw.msg mode change 100755 => 100644 library/msgs/eo.msg mode change 100755 => 100644 library/msgs/es.msg mode change 100755 => 100644 library/msgs/es_ar.msg mode change 100755 => 100644 library/msgs/es_bo.msg mode change 100755 => 100644 library/msgs/es_cl.msg mode change 100755 => 100644 library/msgs/es_co.msg mode change 100755 => 100644 library/msgs/es_cr.msg mode change 100755 => 100644 library/msgs/es_do.msg mode change 100755 => 100644 library/msgs/es_ec.msg mode change 100755 => 100644 library/msgs/es_gt.msg mode change 100755 => 100644 library/msgs/es_hn.msg mode change 100755 => 100644 library/msgs/es_mx.msg mode change 100755 => 100644 library/msgs/es_ni.msg mode change 100755 => 100644 library/msgs/es_pa.msg mode change 100755 => 100644 library/msgs/es_pe.msg mode change 100755 => 100644 library/msgs/es_pr.msg mode change 100755 => 100644 library/msgs/es_py.msg mode change 100755 => 100644 library/msgs/es_sv.msg mode change 100755 => 100644 library/msgs/es_uy.msg mode change 100755 => 100644 library/msgs/es_ve.msg mode change 100755 => 100644 library/msgs/et.msg mode change 100755 => 100644 library/msgs/eu.msg mode change 100755 => 100644 library/msgs/eu_es.msg mode change 100755 => 100644 library/msgs/fa.msg mode change 100755 => 100644 library/msgs/fa_in.msg mode change 100755 => 100644 library/msgs/fa_ir.msg mode change 100755 => 100644 library/msgs/fi.msg mode change 100755 => 100644 library/msgs/fo.msg mode change 100755 => 100644 library/msgs/fo_fo.msg mode change 100755 => 100644 library/msgs/fr.msg mode change 100755 => 100644 library/msgs/fr_be.msg mode change 100755 => 100644 library/msgs/fr_ca.msg mode change 100755 => 100644 library/msgs/fr_ch.msg mode change 100755 => 100644 library/msgs/ga.msg mode change 100755 => 100644 library/msgs/ga_ie.msg mode change 100755 => 100644 library/msgs/gl.msg mode change 100755 => 100644 library/msgs/gl_es.msg mode change 100755 => 100644 library/msgs/gv.msg mode change 100755 => 100644 library/msgs/gv_gb.msg mode change 100755 => 100644 library/msgs/he.msg mode change 100755 => 100644 library/msgs/hi.msg mode change 100755 => 100644 library/msgs/hi_in.msg mode change 100755 => 100644 library/msgs/hr.msg mode change 100755 => 100644 library/msgs/hu.msg mode change 100755 => 100644 library/msgs/id.msg mode change 100755 => 100644 library/msgs/id_id.msg mode change 100755 => 100644 library/msgs/is.msg mode change 100755 => 100644 library/msgs/it.msg mode change 100755 => 100644 library/msgs/it_ch.msg mode change 100755 => 100644 library/msgs/ja.msg mode change 100755 => 100644 library/msgs/kl.msg mode change 100755 => 100644 library/msgs/kl_gl.msg mode change 100755 => 100644 library/msgs/ko.msg mode change 100755 => 100644 library/msgs/ko_kr.msg mode change 100755 => 100644 library/msgs/kok.msg mode change 100755 => 100644 library/msgs/kok_in.msg mode change 100755 => 100644 library/msgs/kw.msg mode change 100755 => 100644 library/msgs/kw_gb.msg mode change 100755 => 100644 library/msgs/lt.msg mode change 100755 => 100644 library/msgs/lv.msg mode change 100755 => 100644 library/msgs/mk.msg mode change 100755 => 100644 library/msgs/mr.msg mode change 100755 => 100644 library/msgs/mr_in.msg mode change 100755 => 100644 library/msgs/ms.msg mode change 100755 => 100644 library/msgs/ms_my.msg mode change 100755 => 100644 library/msgs/mt.msg mode change 100755 => 100644 library/msgs/nb.msg mode change 100755 => 100644 library/msgs/nl.msg mode change 100755 => 100644 library/msgs/nl_be.msg mode change 100755 => 100644 library/msgs/nn.msg mode change 100755 => 100644 library/msgs/pl.msg mode change 100755 => 100644 library/msgs/pt.msg mode change 100755 => 100644 library/msgs/pt_br.msg mode change 100755 => 100644 library/msgs/ro.msg mode change 100755 => 100644 library/msgs/ru.msg mode change 100755 => 100644 library/msgs/ru_ua.msg mode change 100755 => 100644 library/msgs/sh.msg mode change 100755 => 100644 library/msgs/sk.msg mode change 100755 => 100644 library/msgs/sl.msg mode change 100755 => 100644 library/msgs/sq.msg mode change 100755 => 100644 library/msgs/sr.msg mode change 100755 => 100644 library/msgs/sv.msg mode change 100755 => 100644 library/msgs/sw.msg mode change 100755 => 100644 library/msgs/ta.msg mode change 100755 => 100644 library/msgs/ta_in.msg mode change 100755 => 100644 library/msgs/te.msg mode change 100755 => 100644 library/msgs/te_in.msg mode change 100755 => 100644 library/msgs/th.msg mode change 100755 => 100644 library/msgs/tr.msg mode change 100755 => 100644 library/msgs/uk.msg mode change 100755 => 100644 library/msgs/vi.msg mode change 100755 => 100644 library/msgs/zh.msg mode change 100755 => 100644 library/msgs/zh_cn.msg mode change 100755 => 100644 library/msgs/zh_hk.msg mode change 100755 => 100644 library/msgs/zh_sg.msg mode change 100755 => 100644 library/msgs/zh_tw.msg mode change 100755 => 100644 library/tzdata/Africa/Asmara mode change 100755 => 100644 library/tzdata/America/Atikokan mode change 100755 => 100644 library/tzdata/America/Blanc-Sablon mode change 100755 => 100644 library/tzdata/America/Indiana/Petersburg mode change 100755 => 100644 library/tzdata/America/Indiana/Tell_City mode change 100755 => 100644 library/tzdata/America/Indiana/Vincennes mode change 100755 => 100644 library/tzdata/America/Indiana/Winamac mode change 100755 => 100644 library/tzdata/America/Moncton mode change 100755 => 100644 library/tzdata/America/North_Dakota/New_Salem mode change 100755 => 100644 library/tzdata/America/Resolute mode change 100755 => 100644 library/tzdata/Atlantic/Faroe mode change 100755 => 100644 library/tzdata/Australia/Eucla mode change 100755 => 100644 library/tzdata/Europe/Guernsey mode change 100755 => 100644 library/tzdata/Europe/Isle_of_Man mode change 100755 => 100644 library/tzdata/Europe/Jersey mode change 100755 => 100644 library/tzdata/Europe/Podgorica mode change 100755 => 100644 library/tzdata/Europe/Volgograd mode change 100755 => 100644 tools/encoding/ebcdic.txt mode change 100755 => 100644 tools/encoding/tis-620.txt diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c old mode 100755 new mode 100644 diff --git a/library/encoding/tis-620.enc b/library/encoding/tis-620.enc old mode 100755 new mode 100644 diff --git a/library/msgs/af.msg b/library/msgs/af.msg old mode 100755 new mode 100644 diff --git a/library/msgs/af_za.msg b/library/msgs/af_za.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar.msg b/library/msgs/ar.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_in.msg b/library/msgs/ar_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_jo.msg b/library/msgs/ar_jo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_lb.msg b/library/msgs/ar_lb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_sy.msg b/library/msgs/ar_sy.msg old mode 100755 new mode 100644 diff --git a/library/msgs/be.msg b/library/msgs/be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bg.msg b/library/msgs/bg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bn.msg b/library/msgs/bn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bn_in.msg b/library/msgs/bn_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ca.msg b/library/msgs/ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/cs.msg b/library/msgs/cs.msg old mode 100755 new mode 100644 diff --git a/library/msgs/da.msg b/library/msgs/da.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de.msg b/library/msgs/de.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de_at.msg b/library/msgs/de_at.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de_be.msg b/library/msgs/de_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/el.msg b/library/msgs/el.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_au.msg b/library/msgs/en_au.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_be.msg b/library/msgs/en_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_bw.msg b/library/msgs/en_bw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ca.msg b/library/msgs/en_ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_gb.msg b/library/msgs/en_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_hk.msg b/library/msgs/en_hk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ie.msg b/library/msgs/en_ie.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_in.msg b/library/msgs/en_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_nz.msg b/library/msgs/en_nz.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ph.msg b/library/msgs/en_ph.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_sg.msg b/library/msgs/en_sg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_za.msg b/library/msgs/en_za.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_zw.msg b/library/msgs/en_zw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eo.msg b/library/msgs/eo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es.msg b/library/msgs/es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ar.msg b/library/msgs/es_ar.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_bo.msg b/library/msgs/es_bo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_cl.msg b/library/msgs/es_cl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_co.msg b/library/msgs/es_co.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_cr.msg b/library/msgs/es_cr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_do.msg b/library/msgs/es_do.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ec.msg b/library/msgs/es_ec.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_gt.msg b/library/msgs/es_gt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_hn.msg b/library/msgs/es_hn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_mx.msg b/library/msgs/es_mx.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ni.msg b/library/msgs/es_ni.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pa.msg b/library/msgs/es_pa.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pe.msg b/library/msgs/es_pe.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pr.msg b/library/msgs/es_pr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_py.msg b/library/msgs/es_py.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_sv.msg b/library/msgs/es_sv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_uy.msg b/library/msgs/es_uy.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ve.msg b/library/msgs/es_ve.msg old mode 100755 new mode 100644 diff --git a/library/msgs/et.msg b/library/msgs/et.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eu.msg b/library/msgs/eu.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eu_es.msg b/library/msgs/eu_es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa.msg b/library/msgs/fa.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa_in.msg b/library/msgs/fa_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa_ir.msg b/library/msgs/fa_ir.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fi.msg b/library/msgs/fi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fo.msg b/library/msgs/fo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fo_fo.msg b/library/msgs/fo_fo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr.msg b/library/msgs/fr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_be.msg b/library/msgs/fr_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_ca.msg b/library/msgs/fr_ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_ch.msg b/library/msgs/fr_ch.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ga.msg b/library/msgs/ga.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ga_ie.msg b/library/msgs/ga_ie.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gl.msg b/library/msgs/gl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gl_es.msg b/library/msgs/gl_es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gv.msg b/library/msgs/gv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gv_gb.msg b/library/msgs/gv_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/he.msg b/library/msgs/he.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hi.msg b/library/msgs/hi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hi_in.msg b/library/msgs/hi_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hr.msg b/library/msgs/hr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hu.msg b/library/msgs/hu.msg old mode 100755 new mode 100644 diff --git a/library/msgs/id.msg b/library/msgs/id.msg old mode 100755 new mode 100644 diff --git a/library/msgs/id_id.msg b/library/msgs/id_id.msg old mode 100755 new mode 100644 diff --git a/library/msgs/is.msg b/library/msgs/is.msg old mode 100755 new mode 100644 diff --git a/library/msgs/it.msg b/library/msgs/it.msg old mode 100755 new mode 100644 diff --git a/library/msgs/it_ch.msg b/library/msgs/it_ch.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kl.msg b/library/msgs/kl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kl_gl.msg b/library/msgs/kl_gl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ko.msg b/library/msgs/ko.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ko_kr.msg b/library/msgs/ko_kr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kok.msg b/library/msgs/kok.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kok_in.msg b/library/msgs/kok_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kw.msg b/library/msgs/kw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kw_gb.msg b/library/msgs/kw_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/lt.msg b/library/msgs/lt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/lv.msg b/library/msgs/lv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mk.msg b/library/msgs/mk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mr.msg b/library/msgs/mr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mr_in.msg b/library/msgs/mr_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ms.msg b/library/msgs/ms.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ms_my.msg b/library/msgs/ms_my.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mt.msg b/library/msgs/mt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nb.msg b/library/msgs/nb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nl.msg b/library/msgs/nl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nl_be.msg b/library/msgs/nl_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nn.msg b/library/msgs/nn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pl.msg b/library/msgs/pl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pt.msg b/library/msgs/pt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pt_br.msg b/library/msgs/pt_br.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ro.msg b/library/msgs/ro.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ru.msg b/library/msgs/ru.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ru_ua.msg b/library/msgs/ru_ua.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sh.msg b/library/msgs/sh.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sk.msg b/library/msgs/sk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sl.msg b/library/msgs/sl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sq.msg b/library/msgs/sq.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sr.msg b/library/msgs/sr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sv.msg b/library/msgs/sv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sw.msg b/library/msgs/sw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ta.msg b/library/msgs/ta.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ta_in.msg b/library/msgs/ta_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/te.msg b/library/msgs/te.msg old mode 100755 new mode 100644 diff --git a/library/msgs/te_in.msg b/library/msgs/te_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/th.msg b/library/msgs/th.msg old mode 100755 new mode 100644 diff --git a/library/msgs/tr.msg b/library/msgs/tr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/uk.msg b/library/msgs/uk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/vi.msg b/library/msgs/vi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh.msg b/library/msgs/zh.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_cn.msg b/library/msgs/zh_cn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_hk.msg b/library/msgs/zh_hk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_sg.msg b/library/msgs/zh_sg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_tw.msg b/library/msgs/zh_tw.msg old mode 100755 new mode 100644 diff --git a/library/tzdata/Africa/Asmara b/library/tzdata/Africa/Asmara old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Atikokan b/library/tzdata/America/Atikokan old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Blanc-Sablon b/library/tzdata/America/Blanc-Sablon old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Petersburg b/library/tzdata/America/Indiana/Petersburg old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Tell_City b/library/tzdata/America/Indiana/Tell_City old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Vincennes b/library/tzdata/America/Indiana/Vincennes old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Winamac b/library/tzdata/America/Indiana/Winamac old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Moncton b/library/tzdata/America/Moncton old mode 100755 new mode 100644 diff --git a/library/tzdata/America/North_Dakota/New_Salem b/library/tzdata/America/North_Dakota/New_Salem old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Resolute b/library/tzdata/America/Resolute old mode 100755 new mode 100644 diff --git a/library/tzdata/Atlantic/Faroe b/library/tzdata/Atlantic/Faroe old mode 100755 new mode 100644 diff --git a/library/tzdata/Australia/Eucla b/library/tzdata/Australia/Eucla old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Guernsey b/library/tzdata/Europe/Guernsey old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Isle_of_Man b/library/tzdata/Europe/Isle_of_Man old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Jersey b/library/tzdata/Europe/Jersey old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Podgorica b/library/tzdata/Europe/Podgorica old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Volgograd b/library/tzdata/Europe/Volgograd old mode 100755 new mode 100644 diff --git a/tools/encoding/ebcdic.txt b/tools/encoding/ebcdic.txt old mode 100755 new mode 100644 diff --git a/tools/encoding/tis-620.txt b/tools/encoding/tis-620.txt old mode 100755 new mode 100644 -- cgit v0.12 From c00bdffb6aa0fca3575ef0ab1a07813f696f1839 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 18 Oct 2013 07:08:46 +0000 Subject: Tackle evalStk by reusing existing machinery. --- generic/tclCompCmds.c | 2 +- generic/tclCompile.c | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 942d74c..25201eb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -620,7 +620,7 @@ TclCompileCatchCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_EVAL_STK, envPtr); + TclEmitInvoke(envPtr, INST_EVAL_STK); } /* Stack at this point: * nonsimple: script result diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 427ccab..f91c2fd 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2458,7 +2458,7 @@ TclCompileCmdWord( */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitInvoke(envPtr, INST_EVAL_STK); } } @@ -3954,6 +3954,7 @@ TclEmitInvoke( break; default: Tcl_Panic("unexpected opcode"); + case INST_EVAL_STK: case INST_INVOKE_EXPANDED: wordCount = arg1 = arg2 = 0; break; @@ -4009,6 +4010,9 @@ TclEmitInvoke( case INST_INVOKE_EXPANDED: TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); break; + case INST_EVAL_STK: + TclEmitOpcode(INST_EVAL_STK, envPtr); + break; case INST_INVOKE_REPLACE: TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); TclEmitInt1(arg2, envPtr); -- cgit v0.12 From 3e798bfe4700fd510a0daf3944429c75596786da Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 Oct 2013 11:20:46 +0000 Subject: Improve coverage of [error] compilation. --- generic/tclCompCmds.c | 43 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 36 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 25201eb..c55635a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2135,19 +2135,48 @@ TclCompileErrorCmd( { /* * General syntax: [error message ?errorInfo? ?errorCode?] - * However, we only deal with the case where there is just a message. */ - Tcl_Token *messageTokenPtr; + + Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ - if (parsePtr->numWords != 2) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } - messageTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushStringLiteral(envPtr, "-code error -level 0"); - CompileWord(envPtr, messageTokenPtr, interp, 1); - TclEmitOpcode(INST_RETURN_STK, envPtr); + /* + * Handle the message. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Construct the options. Note that -code and -level are not here. + */ + + if (parsePtr->numWords == 2) { + PushStringLiteral(envPtr, ""); + } else { + PushStringLiteral(envPtr, "-errorinfo"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST, 2, envPtr); + } else { + PushStringLiteral(envPtr, "-errorcode"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + TclEmitInstInt4( INST_LIST, 4, envPtr); + } + } + + /* + * Issue the error via 'returnImm error 0'. + */ + + TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr); + TclEmitInt4( 0, envPtr); return TCL_OK; } -- cgit v0.12 From 674d5acbcfa7bfb12b407c88bd4bf67ae1b1d0ac Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 Oct 2013 12:29:06 +0000 Subject: Added missing exception range finalize. --- generic/tclCompile.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f91c2fd..89b9011 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -4073,6 +4073,7 @@ TclEmitInvoke( envPtr->expandCount = savedExpandCount; } + TclFinalizeLoopExceptionRange(envPtr, loopRange); TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); } } -- cgit v0.12 From acfb2a50369dae9afcf444519e5d3875812d5a3b Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 19 Oct 2013 14:11:28 +0000 Subject: Fix handling of 'invokeExpanded' and start to do 'returnStk'. --- generic/tclCompCmdsGR.c | 4 +- generic/tclCompile.c | 27 ++++++++--- tests/for.test | 116 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 138 insertions(+), 9 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 5513b01..fbd370b 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2367,7 +2367,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } @@ -2509,7 +2509,7 @@ TclCompileReturnCmd( * Issue the RETURN itself. */ - TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 89b9011..ae6e56c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1802,9 +1802,7 @@ CompileExpanded( * stack-neutral in general. */ - TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); } static int @@ -3931,7 +3929,8 @@ TclEmitInvoke( va_list argList; ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; - int arg1, arg2, wordCount = 0, loopRange, breakRange, continueRange; + int arg1, arg2, wordCount = 0, expandCount = 0; + int loopRange, breakRange, continueRange; /* * Parse the arguments. @@ -3955,8 +3954,17 @@ TclEmitInvoke( default: Tcl_Panic("unexpected opcode"); case INST_EVAL_STK: + wordCount = 1; + arg1 = arg2 = 0; + break; + case INST_RETURN_STK: + wordCount = 2; + arg1 = arg2 = 0; + break; case INST_INVOKE_EXPANDED: - wordCount = arg1 = arg2 = 0; + wordCount = arg1 = va_arg(argList, int); + arg2 = 0; + expandCount = 1; break; } va_end(argList); @@ -3974,7 +3982,7 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxBreakPtr = NULL; } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount - && auxBreakPtr->expandTarget == envPtr->expandCount) { + && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { auxBreakPtr = NULL; } else { breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; @@ -3985,7 +3993,7 @@ TclEmitInvoke( if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { auxContinuePtr = NULL; } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount - && auxContinuePtr->expandTarget == envPtr->expandCount) { + && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { auxContinuePtr = NULL; } else { continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; @@ -4009,10 +4017,15 @@ TclEmitInvoke( break; case INST_INVOKE_EXPANDED: TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - arg1, envPtr); break; case INST_EVAL_STK: TclEmitOpcode(INST_EVAL_STK, envPtr); break; + case INST_RETURN_STK: + TclEmitOpcode(INST_RETURN_STK, envPtr); + break; case INST_INVOKE_REPLACE: TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); TclEmitInt1(arg2, envPtr); diff --git a/tests/for.test b/tests/for.test index 6a18abe..8abd270 100644 --- a/tests/for.test +++ b/tests/for.test @@ -1068,6 +1068,122 @@ test for-7.16 {Bug 3614226: ensure that continue from invoked command only clean expr {$end - $tmp} }} } 0 +test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 39e314ad912cdbd29ba3e01673b1097b40118f8b Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 20 Oct 2013 18:11:35 +0000 Subject: And the last bits that need fixing; the code is still less efficient than desired but should now not crash. --- generic/tclAssembly.c | 35 +++++++++++++++++++++++++++++++---- generic/tclCompCmds.c | 4 ++-- generic/tclCompCmdsGR.c | 6 +++++- generic/tclCompCmdsSZ.c | 12 +++++++----- 4 files changed, 45 insertions(+), 12 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 08da075..fc51457 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -246,6 +246,8 @@ static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, int opnd, int count); static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, int param, int count); +static void BBEmitInvoke1or4(AssemblyEnv* assemEnvPtr, int tblIdx, + int param, int count); static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, int count); static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); @@ -679,10 +681,13 @@ BBEmitInstInt4( /* *----------------------------------------------------------------------------- * - * BBEmitInst1or4 -- + * BBEmitInst1or4, BBEmitInvoke1or4 -- * * Emits a 1- or 4-byte operation according to the magnitude of the - * operand + * operand. The Invoke variant generates wrapping stack-balance + * management if necessary (which is not normally required in assembled + * code, as loop exception ranges, expansions, breaks and continues can't + * be issued currently). * *----------------------------------------------------------------------------- */ @@ -714,6 +719,29 @@ BBEmitInst1or4( TclUpdateAtCmdStart(op, envPtr); BBUpdateStackReqs(bbPtr, tblIdx, count); } + +static void +BBEmitInvoke1or4( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Index in TalInstructionTable of op */ + int param, /* Variable-length parameter */ + int count) /* Arity if variadic */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + int op = TalInstructionTable[tblIdx].tclInstCode; + + if (param <= 0xff) { + op >>= 8; + } else { + op &= 0xff; + } + TclEmitInvoke(envPtr, op, param); + TclUpdateAtCmdStart(op, envPtr); + BBUpdateStackReqs(bbPtr, tblIdx, count); +} /* *----------------------------------------------------------------------------- @@ -1450,8 +1478,7 @@ AssembleOneLine( goto cleanup; } - // FIXME - use TclEmitInvoke - BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); + BBEmitInvoke1or4(assemEnvPtr, tblIdx, opnd, opnd); break; case ASSEM_JUMP: diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c55635a..9c43bfe 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1675,7 +1675,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", @@ -2033,7 +2033,7 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); } - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); /* * Prepare for the start of the next command. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fbd370b..d00327d 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2381,6 +2381,10 @@ TclCompileReturnCmd( * Scan through the return options. If any are unknown at compile time, * there is no value in bytecompiling. Save the option values known in an * objv array for merging into a return options dictionary. + * + * TODO: There is potential for improvement if all option keys are known + * at compile time and all option values relating to '-code' and '-level' + * are known at compile time. */ for (objc = 0; objc < numOptionWords; objc++) { @@ -2388,7 +2392,7 @@ TclCompileReturnCmd( Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { /* - * Non-literal, so punt to run-time. + * Non-literal, so punt to run-time assembly of the dictionary. */ for (; objc>=0 ; objc--) { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index a5ec731..754238f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -99,6 +99,8 @@ const AuxDataType tclJumptableInfoType = { if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} +#define INVOKE(name) \ + TclEmitInvoke(envPtr,INST_##name) /* *---------------------------------------------------------------------- @@ -873,7 +875,7 @@ TclSubstCompile( OP( END_CATCH); OP( RETURN_CODE_BRANCH); - /* ERROR -> reraise it */ + /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ OP( RETURN_STK); OP( NOP); @@ -2396,7 +2398,7 @@ IssueTryClausesInstructions( TclAdjustStackDepth(-1, envPtr); FIXJUMP1( dontChangeOptions); OP4( REVERSE, 2); - OP( RETURN_STK); + INVOKE( RETURN_STK); } JUMP4( JUMP, addrsToFix[i]); @@ -2415,7 +2417,7 @@ IssueTryClausesInstructions( OP( POP); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); + INVOKE( RETURN_STK); /* * Fix all the jumps from taken clauses to here (which is the end of the @@ -2724,7 +2726,7 @@ IssueTryClausesFinallyInstructions( FIXJUMP1( finalOK); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2783,7 +2785,7 @@ IssueTryFinallyInstructions( OP1( JUMP1, 7); FIXJUMP1( jumpOK); OP4( REVERSE, 2); - OP( RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } -- cgit v0.12 From 30cd4b442c047d01653b1c217b0364eb6b5c8101 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 Oct 2013 14:35:02 +0000 Subject: silence compiler warnings --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ae6e56c..a150fc2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3930,7 +3930,7 @@ TclEmitInvoke( ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; int arg1, arg2, wordCount = 0, expandCount = 0; - int loopRange, breakRange, continueRange; + int loopRange = 0, breakRange = 0, continueRange = 0; /* * Parse the arguments. -- cgit v0.12 From fff622bfb179b6e2fb8d95991ae911a0f056774d Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 09:18:19 +0000 Subject: corrected trace printing --- generic/tclExecute.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8470389..6357008 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5272,13 +5272,13 @@ TEBCresume( trim2 = 0; } if (trim1 == 0 && trim2 == 0) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - valuePtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), valuePtr); NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - objResultPtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } case INST_STRTRIM_LEFT: @@ -5288,13 +5288,13 @@ TEBCresume( string1 = TclGetStringFromObj(valuePtr, &length); trim1 = TclTrimLeft(string1, length, string2, length2); if (trim1 == 0) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - valuePtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), valuePtr); NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1); - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", valuePtr, value2Ptr), - objResultPtr); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } case INST_STRTRIM_RIGHT: @@ -5304,9 +5304,13 @@ TEBCresume( string1 = TclGetStringFromObj(valuePtr, &length); trim2 = TclTrimRight(string1, length, string2, length2); if (trim2 == 0) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), valuePtr); NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1, length-trim2); + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } } -- cgit v0.12 From 545698c7c06b1e3d1956d77508ecaf251163fb22 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 14:29:03 +0000 Subject: Fix problems in for.test --- generic/tclCompile.c | 136 +++++++++++++++++++++++---------------------------- 1 file changed, 62 insertions(+), 74 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a150fc2..dcd74f1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1755,7 +1755,6 @@ CompileExpanded( int wordIdx = 0; DefineLineInformation; - StartExpanding(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1787,19 +1786,17 @@ CompileExpanded( } /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. + * The stack depth during argument expansion can only be managed at + * runtime, as the number of elements in the expanded lists is not known + * at compile time. We adjust here the stack depth estimate so that it is + * correct after the command with expanded arguments returns. * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). + * The end effect of this command's invocation is that all the words of + * the command are popped from the stack, and the result is pushed: the + * stack top changes by (1-wordIdx). * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. + * Note that the estimates are not correct while the command is being + * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); @@ -1816,8 +1813,8 @@ CompileCmdCompileProc( DefineLineInformation; /* - * Emit of the INST_START_CMD instruction is controlled by - * the value of envPtr->atCmdStart: + * Emit of the INST_START_CMD instruction is controlled by the value of + * envPtr->atCmdStart: * * atCmdStart == 2 : We are not using the INST_START_CMD instruction. * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. @@ -1848,9 +1845,10 @@ CompileCmdCompileProc( if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* - * We successfully compiled a command. Increment the number - * of commands that start at the currently active INST_START_CMD. + * We successfully compiled a command. Increment the number of + * commands that start at the currently active INST_START_CMD. */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; unsigned char *startPtr = incrPtr - 5; @@ -1866,9 +1864,9 @@ CompileCmdCompileProc( envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ /* - * Throw out any line information generated by the failed - * compile attempt. + * Throw out any line information generated by the failed compile attempt. */ + while (mapPtr->nuloc - 1 > eclIndex) { mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); @@ -1876,11 +1874,11 @@ CompileCmdCompileProc( } /* - * Reset the index of next command. - * Toss out any from failed nested partial compiles. + * Reset the index of next command. Toss out any from failed nested + * partial compiles. */ - envPtr->numCommands = mapPtr->nuloc; + envPtr->numCommands = mapPtr->nuloc; return TCL_ERROR; } @@ -1912,11 +1910,10 @@ CompileCommandTokens( parsePtr->commandStart - envPtr->source, startCodeOffset); /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. + * TIP #280. Scan the words and compute the extended location information. + * The map first contain full per-word line information for use by the + * compiler. This is later replaced by a reduced form which signals + * non-literal words, stored in 'wlines'. */ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, @@ -1938,8 +1935,8 @@ CompileCommandTokens( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if (cmdPtr) { /* - * Found a command. Test the ways we can be told - * not to attempt to compile it. + * Found a command. Test the ways we can be told not to attempt + * to compile it. */ if ((cmdPtr->compileProc == NULL) || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) @@ -1983,8 +1980,8 @@ CompileCommandTokens( (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now + * TIP #280: Free full form of per-word line data and insert the reduced + * form now */ envPtr->line = cmdLine; @@ -2069,20 +2066,20 @@ TclCompileScript( if (parse.numWords == 0) { /* - * The "command" parsed has no words. In this case - * we can skip the rest of the loop body. With no words, - * clearly CompileCommandTokens() has nothing to do. Since - * the parser aggressively sucks up leading comment and white - * space, including newlines, parse.commandStart must be - * pointing at either the end of script, or a command-terminating - * semi-colon. In either case, the TclAdvance*() calls have - * nothing to do. Finally, when no words are parsed, no - * tokens have been allocated at parse.tokenPtr so there's - * also nothing for Tcl_FreeParse() to do. + * The "command" parsed has no words. In this case we can skip + * the rest of the loop body. With no words, clearly + * CompileCommandTokens() has nothing to do. Since the parser + * aggressively sucks up leading comment and white space, + * including newlines, parse.commandStart must be pointing at + * either the end of script, or a command-terminating semi-colon. + * In either case, the TclAdvance*() calls have nothing to do. + * Finally, when no words are parsed, no tokens have been + * allocated at parse.tokenPtr so there's also nothing for + * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that parse.numWords > 0, - * with the implication the CCT() always generates bytecode. + * can be written with an assumption that parse.numWords > 0, with + * the implication the CCT() always generates bytecode. */ continue; } @@ -2101,23 +2098,25 @@ TclCompileScript( if (lastCmdIdx == -1) { /* - * Compiling the script yielded no bytecode. The script must be - * all whitespace, comments, and empty commands. Such scripts - * are defined to successfully produce the empty string result, - * so we emit the simple bytecode that makes that happen. + * Compiling the script yielded no bytecode. The script must be all + * whitespace, comments, and empty commands. Such scripts are defined + * to successfully produce the empty string result, so we emit the + * simple bytecode that makes that happen. */ + PushStringLiteral(envPtr, ""); } else { /* * We compiled at least one command to bytecode. The routine * CompileCommandTokens() follows the bytecode of each compiled - * command with an INST_POP, so that stack balance is maintained - * when several commands are in sequence. (The result of each - * command is thrown away before moving on to the next command). - * For the last command compiled, we need to undo that INST_POP - * so that the result of the last command becomes the result of - * the script. The code here removes that trailing INST_POP. + * command with an INST_POP, so that stack balance is maintained when + * several commands are in sequence. (The result of each command is + * thrown away before moving on to the next command). For the last + * command compiled, we need to undo that INST_POP so that the result + * of the last command becomes the result of the script. The code + * here removes that trailing INST_POP. */ + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; @@ -3353,9 +3352,9 @@ TclAddLoopContinueFixup( * * TclCleanupStackForBreakContinue -- * - * Ditch the extra elements from the auxiliary stack and the main - * stack. How to do this exactly depends on whether there are any - * elements on the auxiliary stack to pop. + * Ditch the extra elements from the auxiliary stack and the main stack. + * How to do this exactly depends on whether there are any elements on + * the auxiliary stack to pop. * * --------------------------------------------------------------------- */ @@ -3369,23 +3368,16 @@ TclCleanupStackForBreakContinue( int toPop = envPtr->expandCount - auxPtr->expandTarget; if (toPop > 0) { - while (toPop > 0) { + while (toPop --> 0) { TclEmitOpcode(INST_EXPAND_DROP, envPtr); - toPop--; } TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, envPtr); - toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } - } else { - toPop = envPtr->currStackDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } + envPtr->currStackDepth = auxPtr->expandTargetDepth; + } + toPop = envPtr->currStackDepth - auxPtr->stackDepth; + while (toPop --> 0) { + TclEmitOpcode(INST_POP, envPtr); } envPtr->currStackDepth = savedStackDepth; } @@ -4062,11 +4054,9 @@ TclEmitInvoke( if (auxBreakPtr != NULL) { TclAdjustStackDepth(-1, envPtr); - exceptAux->stackDepth = auxBreakPtr->stackDepth; - exceptAux->expandTarget = auxBreakPtr->expandTarget; ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclCleanupStackForBreakContinue(envPtr, exceptAux); + TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); TclAddLoopBreakFixup(envPtr, auxBreakPtr); envPtr->currStackDepth = savedStackDepth; @@ -4075,11 +4065,9 @@ TclEmitInvoke( if (auxContinuePtr != NULL) { TclAdjustStackDepth(-1, envPtr); - exceptAux->stackDepth = auxContinuePtr->stackDepth; - exceptAux->expandTarget = auxContinuePtr->expandTarget; ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclCleanupStackForBreakContinue(envPtr, exceptAux); + TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); TclAddLoopContinueFixup(envPtr, auxContinuePtr); envPtr->currStackDepth = savedStackDepth; -- cgit v0.12 From 1356c7f642888ace1fe24f64ea003567fc6a8fdd Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 17:34:55 +0000 Subject: Fix for assemble.test; problem was a total assumption failure caused by way that the assembler works. --- generic/tclAssembly.c | 34 +++------------------------------- 1 file changed, 3 insertions(+), 31 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index fc51457..03177b9 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -246,8 +246,6 @@ static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, int opnd, int count); static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, int param, int count); -static void BBEmitInvoke1or4(AssemblyEnv* assemEnvPtr, int tblIdx, - int param, int count); static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, int count); static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); @@ -681,13 +679,10 @@ BBEmitInstInt4( /* *----------------------------------------------------------------------------- * - * BBEmitInst1or4, BBEmitInvoke1or4 -- + * BBEmitInst1or4 -- * * Emits a 1- or 4-byte operation according to the magnitude of the - * operand. The Invoke variant generates wrapping stack-balance - * management if necessary (which is not normally required in assembled - * code, as loop exception ranges, expansions, breaks and continues can't - * be issued currently). + * operand. * *----------------------------------------------------------------------------- */ @@ -719,29 +714,6 @@ BBEmitInst1or4( TclUpdateAtCmdStart(op, envPtr); BBUpdateStackReqs(bbPtr, tblIdx, count); } - -static void -BBEmitInvoke1or4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int param, /* Variable-length parameter */ - int count) /* Arity if variadic */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode; - - if (param <= 0xff) { - op >>= 8; - } else { - op &= 0xff; - } - TclEmitInvoke(envPtr, op, param); - TclUpdateAtCmdStart(op, envPtr); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} /* *----------------------------------------------------------------------------- @@ -1478,7 +1450,7 @@ AssembleOneLine( goto cleanup; } - BBEmitInvoke1or4(assemEnvPtr, tblIdx, opnd, opnd); + BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); break; case ASSEM_JUMP: -- cgit v0.12 From 1c8937d85be2f327d881c29e203c46df34b9da08 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Oct 2013 18:55:02 +0000 Subject: [3556215]: Made [scan] match [format] better in what it accepts as a format string, by allowing uppercase %X, %E and %G. --- doc/scan.n | 4 ++-- generic/tclScan.c | 6 ++++++ tests/scan.test | 17 +++++++++++++---- 3 files changed, 21 insertions(+), 6 deletions(-) diff --git a/doc/scan.n b/doc/scan.n index ca096da..4ee9a59 100644 --- a/doc/scan.n +++ b/doc/scan.n @@ -96,7 +96,7 @@ The input substring must be an octal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. .TP 10 -\fBx\fR +\fBx\fR or \fBX\fR The input substring must be a hexadecimal integer. It is read in and the integer value is stored in the variable, truncated as required by the size modifier value. @@ -126,7 +126,7 @@ substring may be a white-space character. The input substring consists of all the characters up to the next white-space character; the characters are copied to the variable. .TP 10 -\fBe\fR or \fBf\fR or \fBg\fR +\fBe\fR or \fBf\fR or \fBg\fR or \fBE\fR or \fBG\fR The input substring must be a floating-point number consisting of an optional sign, a string of decimal digits possibly containing a decimal point, and an optional exponent consisting diff --git a/generic/tclScan.c b/generic/tclScan.c index d83c8c9..229f3fa 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -398,11 +398,14 @@ ValidateFormat( */ case 'd': case 'e': + case 'E': case 'f': case 'g': + case 'G': case 'i': case 'o': case 'x': + case 'X': break; case 'u': if (flags & SCAN_BIG) { @@ -727,6 +730,7 @@ Tcl_ScanObjCmd( parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; break; case 'x': + case 'X': op = 'i'; parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY; break; @@ -738,7 +742,9 @@ Tcl_ScanObjCmd( case 'f': case 'e': + case 'E': case 'g': + case 'G': op = 'f'; break; diff --git a/tests/scan.test b/tests/scan.test index d7b72d5..109746f 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -280,6 +280,12 @@ test scan-4.48 {Tcl_ScanObjCmd, float scanning} { test scan-4.49 {Tcl_ScanObjCmd, float scanning} { list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z } {3 0.1 0.2 3.0} +test scan-4.49-uc-1 {Tcl_ScanObjCmd, float scanning} { + list [scan {0.5*0.75} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} +test scan-4.49-uc-2 {Tcl_ScanObjCmd, float scanning} { + list [scan {5e-1*75E-2} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} test scan-4.50 {Tcl_ScanObjCmd, float scanning} { list [scan {1234567890a} %f x] $x } {1 1234567890.0} @@ -359,6 +365,9 @@ test scan-4.63 {scanning of large and negative hex integers} { list [scan $scanstring {%x %x %x} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} +test scan-4.64 {scanning of hex with %X} { + scan "123 abc f78" %X%X%X +} {291 2748 3960} # clean up from last two tests @@ -515,14 +524,14 @@ test scan-8.4 {error conditions} { list [catch {scan a %O x} msg] $msg } {1 {bad scan conversion character "O"}} test scan-8.5 {error conditions} { - list [catch {scan a %X x} msg] $msg -} {1 {bad scan conversion character "X"}} + list [catch {scan a %B x} msg] $msg +} {1 {bad scan conversion character "B"}} test scan-8.6 {error conditions} { list [catch {scan a %F x} msg] $msg } {1 {bad scan conversion character "F"}} test scan-8.7 {error conditions} { - list [catch {scan a %E x} msg] $msg -} {1 {bad scan conversion character "E"}} + list [catch {scan a %p x} msg] $msg +} {1 {bad scan conversion character "p"}} test scan-8.8 {error conditions} { list [catch {scan a "%d %d" a} msg] $msg } {1 {different numbers of variable names and field specifiers}} -- cgit v0.12 From 2c5855aae434efce2ba3a202651709aaa5bb1ce3 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 23 Oct 2013 08:33:40 +0000 Subject: Stack depth calculation correction. --- generic/tclCompCmdsGR.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 2aaca31..a02f0a8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1616,6 +1616,7 @@ TclCompileLreplaceCmd( Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); @@ -1665,6 +1666,7 @@ TclCompileLreplaceCmd( Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); + TclAdjustStackDepth(-1, envPtr); } TclEmitOpcode( INST_DUP, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); -- cgit v0.12 From cb8dc8b181dfb98f074698fc7eade5f9dfdbefff Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Oct 2013 15:32:58 +0000 Subject: silence compiler warning --- generic/tclCompile.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index dcd74f1..3c8e4ef 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -4034,7 +4034,6 @@ TclEmitInvoke( int savedStackDepth = envPtr->currStackDepth; int savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; - ExceptionAux *exceptAux = envPtr->exceptAuxArrayPtr + loopRange; if (auxBreakPtr != NULL) { auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; -- cgit v0.12 From bb5a05a1e626246d6baeabd22e419a4eee18ff66 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 24 Oct 2013 07:21:14 +0000 Subject: First step in compiling [concat]: the trivial cases. --- generic/tclBasic.c | 2 +- generic/tclCompCmds.c | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ 3 files changed, 90 insertions(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9f40932..8d77cc5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -211,7 +211,7 @@ static const CmdInfo builtInCmds[] = { {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, - {"concat", Tcl_ConcatObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9c43bfe..9508d00 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -55,6 +55,13 @@ const AuxDataType tclDictUpdateInfoType = { FreeDictUpdateInfo, /* freeProc */ PrintDictUpdateInfo /* printProc */ }; + +/* + * The definition of what whitespace is stripped when [concat]enating. Must be + * kept in synch with tclUtil.c + */ + +#define CONCAT_WS " \f\v\r\t\n" /* *---------------------------------------------------------------------- @@ -748,6 +755,85 @@ TclCompileCatchCmd( /* *---------------------------------------------------------------------- * + * TclCompileConcatCmd -- + * + * Procedure called to compile the "concat" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "concat" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileConcatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Obj *objPtr, *listObj; + Tcl_Token *tokenPtr; + int i; + + if (parsePtr->numWords == 1) { + /* + * [concat] without arguments just pushes an empty object. + */ + + PushStringLiteral(envPtr, ""); + return TCL_OK; + } + + /* + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. + */ + + listObj = Tcl_NewObj(); + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + objPtr = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(listObj); + listObj = NULL; + break; + } + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); + } + if (listObj != NULL) { + Tcl_Obj **objs; + const char *bytes; + int len; + + Tcl_ListObjGetElements(NULL, listObj, &len, &objs); + objPtr = Tcl_ConcatObj(len, objs); + Tcl_DecrRefCount(listObj); + bytes = Tcl_GetStringFromObj(objPtr, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(objPtr); + return TCL_OK; + } + + /* + * General case: runtime concat. + */ + + // TODO + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. diff --git a/generic/tclInt.h b/generic/tclInt.h index 6fe07f8..cc8469b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3434,6 +3434,9 @@ MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 0eb7f82a5693d837a2065a788ea14a0d07c3c716 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Oct 2013 12:57:19 +0000 Subject: Fix [3eb2ec1449]: Allow upper case scheme names in url. http -> 2.7.13 --- library/http/http.tcl | 21 ++++++++++++--------- library/http/pkgIndex.tcl | 2 +- tests/http.test | 4 ++-- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 19 insertions(+), 16 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 98d2c5d..4c99f62 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.4 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.7.12 +package provide http 2.7.13 namespace eval http { # Allow resourcing to not clobber existing data @@ -107,7 +107,7 @@ proc http::Log {args} {} proc http::register {proto port command} { variable urlTypes - set urlTypes($proto) [list $port $command] + set urlTypes([string tolower $proto]) [list $port $command] } # http::unregister -- @@ -121,11 +121,12 @@ proc http::register {proto port command} { proc http::unregister {proto} { variable urlTypes - if {![info exists urlTypes($proto)]} { + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { return -code error "unsupported url type \"$proto\"" } - set old $urlTypes($proto) - unset urlTypes($proto) + set old $urlTypes($lower) + unset urlTypes($lower) return $old } @@ -505,12 +506,13 @@ proc http::geturl {url args} { if {$proto eq ""} { set proto http } - if {![info exists urlTypes($proto)]} { + set lower [string tolower $proto] + if {![info exists urlTypes($lower)]} { unset $token return -code error "Unsupported URL type \"$proto\"" } - set defport [lindex $urlTypes($proto) 0] - set defcmd [lindex $urlTypes($proto) 1] + set defport [lindex $urlTypes($lower) 0] + set defcmd [lindex $urlTypes($lower) 1] if {$port eq ""} { set port $defport @@ -641,7 +643,8 @@ proc http::Connected { token proto phost srvurl} { set host [lindex [split $state(socketinfo) :] 0] set port [lindex [split $state(socketinfo) :] 1] - set defport [lindex $urlTypes($proto) 0] + set lower [string tolower $proto] + set defport [lindex $urlTypes($lower) 0] # Send data in cr-lf format, but accept any line terminators diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 0157b3c..be8b883 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,4 +1,4 @@ # Tcl package index file, version 1.1 if {![package vsatisfies [package provide Tcl] 8.4]} {return} -package ifneeded http 2.7.12 [list tclPkgSetup $dir http 2.7.12 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.7.13 [list tclPkgSetup $dir http 2.7.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/tests/http.test b/tests/http.test index c974990..81e16a1 100644 --- a/tests/http.test +++ b/tests/http.test @@ -120,7 +120,7 @@ test http-3.2 {http::geturl} { set err } {Unsupported URL: http:junk} set url //[info hostname]:$port -set badurl //[info hostname]:6666 +set badurl //[info hostname]:[expr $port+1] test http-3.3 {http::geturl} { set token [http::geturl $url] http::data $token @@ -130,7 +130,7 @@ test http-3.3 {http::geturl} { " set tail /a/b/c set url //[info hostname]:$port/a/b/c -set fullurl http://user:pass@[info hostname]:$port/a/b/c +set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c set binurl //[info hostname]:$port/binary set posturl //[info hostname]:$port/post set badposturl //[info hostname]:$port/droppost diff --git a/unix/Makefile.in b/unix/Makefile.in index f6c4424..7c567d3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -766,8 +766,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.7.12 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.12.tm; + @echo "Installing package http 2.7.13 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.13.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 2d97807..7d9e844 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -642,8 +642,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.7.12 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.12.tm; + @echo "Installing package http 2.7.13 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.13.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From fdfd431637d67d40a0af98bfe92a2771a2852e94 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Oct 2013 07:50:08 +0000 Subject: Change name of instruction to make way for future changes. --- generic/tclAssembly.c | 3 ++- generic/tclCompCmds.c | 4 ++-- generic/tclCompCmdsSZ.c | 12 ++++++------ generic/tclCompile.c | 10 +++++----- generic/tclCompile.h | 2 +- generic/tclExecute.c | 2 +- generic/tclOptimize.c | 6 +++--- 7 files changed, 20 insertions(+), 19 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 4c0777d..f709acb 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -349,7 +349,7 @@ static const TalInstDesc TalInstructionTable[] = { {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, - {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, @@ -453,6 +453,7 @@ static const TalInstDesc TalInstructionTable[] = { {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, + {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9508d00..a1ccd39 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1825,7 +1825,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); } if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -3212,7 +3212,7 @@ TclCompileFormatCmd( * Do the concatenation, which produces the result. */ - TclEmitInstInt1(INST_CONCAT1, i, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); } else { /* * EVIL HACK! Force there to be a string representation in the case diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 5f7fad3..646adf3 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -867,7 +867,7 @@ TclSubstCompile( /* * Tricky point! If the first token does not result in a *guaranteed* push * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it - * is possible to get to an INST_CONCAT1 or INST_DONE without enough + * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for * identifying a script that could trigger this case. */ @@ -932,11 +932,11 @@ TclSubstCompile( } while (count > 255) { - OP1( CONCAT1, 255); + OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { - OP1( CONCAT1, count); + OP1( STR_CONCAT1, count); count = 1; } @@ -1056,7 +1056,7 @@ TclSubstCompile( (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { - OP1(CONCAT1, count); + OP1(STR_CONCAT1, count); count = 1; } @@ -1069,11 +1069,11 @@ TclSubstCompile( } while (count > 255) { - OP1( CONCAT1, 255); + OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { - OP1( CONCAT1, count); + OP1( STR_CONCAT1, count); } Tcl_FreeParse(&parse); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cfc6b2e..48a5456 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -63,7 +63,7 @@ InstructionDesc const tclInstructionTable[] = { /* Pop the topmost stack object */ {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; = */ @@ -2400,11 +2400,11 @@ TclCompileTokens( */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); } /* @@ -2535,11 +2535,11 @@ TclCompileExprWords( } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index db77eb1..62c41ea 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -512,7 +512,7 @@ typedef struct ByteCode { #define INST_PUSH4 2 #define INST_POP 3 #define INST_DUP 4 -#define INST_CONCAT1 5 +#define INST_STR_CONCAT1 5 #define INST_INVOKE_STK1 6 #define INST_INVOKE_STK4 7 #define INST_EVAL_STK 8 diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6357008..ab7a3f5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2563,7 +2563,7 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_CONCAT1: { + case INST_STR_CONCAT1: { int appendLen = 0; char *bytes, *p; Tcl_Obj **currPtr; diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 3b16e6e..3196b83 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -191,7 +191,7 @@ TrimUnreachable( * ConvertZeroEffectToNOP -- * * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also - * replace PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an + * replace PUSH empty/STR_CONCAT and TRY_CVT_NUMERIC (when followed by an * operation that guarantees the check for arithmeticity) and eliminate * LNOT when we can invert the following JUMP condition. * @@ -227,7 +227,7 @@ ConvertZeroEffectToNOP( case INST_PUSH1: if (nextInst == INST_POP) { blank = size + InstLength(nextInst); - } else if (nextInst == INST_CONCAT1 + } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt1AtPtr(currentInstPtr + 1)); @@ -242,7 +242,7 @@ ConvertZeroEffectToNOP( case INST_PUSH4: if (nextInst == INST_POP) { blank = size + 1; - } else if (nextInst == INST_CONCAT1 + } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt4AtPtr(currentInstPtr + 1)); -- cgit v0.12 From ab8249dfc3c847de69ae379bb7849bdb7346db40 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Oct 2013 08:25:02 +0000 Subject: General [concat] compilation. --- generic/tclAssembly.c | 5 ++++- generic/tclCompCmds.c | 12 ++++++++++-- generic/tclCompile.c | 6 +++++- generic/tclCompile.h | 4 +++- generic/tclExecute.c | 11 +++++++++++ 5 files changed, 33 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index f709acb..b805c63 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -350,6 +350,7 @@ static const TalInstDesc TalInstructionTable[] = { {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, + {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, @@ -497,6 +498,7 @@ static const unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP4, /* 34-35 */ INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ + INST_LIST, /* 79 */ INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ @@ -507,7 +509,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ - INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT /* 166-168 */ + INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT, /* 166-168 */ + INST_CONCAT_STK /* 169 */ }; /* diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a1ccd39..2f6cb96 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -779,10 +779,12 @@ TclCompileConcatCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + DefineLineInformation; /* TIP #280 */ Tcl_Obj *objPtr, *listObj; Tcl_Token *tokenPtr; int i; + /* TODO: Consider compiling expansion case. */ if (parsePtr->numWords == 1) { /* * [concat] without arguments just pushes an empty object. @@ -827,8 +829,14 @@ TclCompileConcatCmd( * General case: runtime concat. */ - // TODO - return TCL_ERROR; + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + + TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); + + return TCL_OK; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 48a5456..280bf64 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -561,6 +561,11 @@ InstructionDesc const tclInstructionTable[] = { * pushes the resulting string. * Stack: ... string charset => ... trimmedString */ + {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd + * is number of values to concatenate. + * Operation: push concat(stk1 stk2 ... stktop) */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -4050,7 +4055,6 @@ TclEmitInvoke( int savedStackDepth = envPtr->currStackDepth; int savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; - ExceptionAux *exceptAux = envPtr->exceptAuxArrayPtr + loopRange; if (auxBreakPtr != NULL) { auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 62c41ea..4ae754c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -773,8 +773,10 @@ typedef struct ByteCode { #define INST_STRTRIM_LEFT 167 #define INST_STRTRIM_RIGHT 168 +#define INST_CONCAT_STK 169 + /* The last opcode */ -#define LAST_INST_OPCODE 168 +#define LAST_INST_OPCODE 169 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ab7a3f5..cb6afaf 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2712,6 +2712,17 @@ TEBCresume( NEXT_INST_V(2, opnd, 1); } + case INST_CONCAT_STK: + /* + * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, + * and then decrement their ref counts. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + case INST_EXPAND_START: /* * Push an element to the auxObjList. This records the current -- cgit v0.12 From 2fb0507a00743b52c4e5d679639bfb6cbc8b69b6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 27 Oct 2013 08:28:43 +0000 Subject: [53a917d6c9]: Correction to macro for determining how to deprecate things. Thanks to Raphael Kubo da Costa for the patch. --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 1b120fb..ab54078 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -168,7 +168,7 @@ extern "C" { */ #if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1))) -# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5)) +# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 5)) # define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg))) # else # define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__)) -- cgit v0.12 From c6fdd0f07eb9197e59da6170e89c7beafd0a43e0 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 28 Oct 2013 09:23:30 +0000 Subject: [01b77111e5]: Small fixes relating to this bug. In particular, the package name mapping was not being distributed, and there were some small problems with what the mappings were and how they were applied. Also prevented external URLs from ending with a '.'; that's vanishingly rare... --- pkgs/package.list.txt | 11 +++++++- tools/tcltk-man2html-utils.tcl | 2 +- tools/tcltk-man2html.tcl | 9 +++++-- unix/Makefile.in | 57 +++++++++++++++++++++--------------------- 4 files changed, 47 insertions(+), 32 deletions(-) diff --git a/pkgs/package.list.txt b/pkgs/package.list.txt index a13b0fb..0d5dcf8 100644 --- a/pkgs/package.list.txt +++ b/pkgs/package.list.txt @@ -9,7 +9,10 @@ itcl {[incr Tcl]} Itcl {[incr Tcl]} # SQLite -sqlite SQLite +Sqlite SQLite3 +sqlite SQLite3 +Sqlite3 SQLite3 +sqlite3 SQLite3 # Thread Thread Thread @@ -20,7 +23,13 @@ tdbc TDBC Tdbc TDBC TDBC TDBC # Drivers for TDBC +Tdbcmysql tdbc::mysql tdbcmysql tdbc::mysql +Tdbcodbc tdbc::odbc tdbcodbc tdbc::odbc +Tdbcpostgres tdbc::postgres tdbcpostgres tdbc::postgres +Tdbcsqlite3 tdbc::sqlite3 tdbcsqlite3 tdbc::sqlite3 +Tdbcsqlite tdbc::sqlite3 +tdbcsqlite tdbc::sqlite3 diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index d02bcb6..bdd0079 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -900,7 +900,7 @@ proc insert-cross-references {text} { append result [string range $text 0 [expr {$off-1}]] regexp -indices -start $off {http://[\w/.]+} $text range set url [string range $text {*}$range] - append result "" $url "" + append result "$url" set text [string range $text[set text ""] \ [expr {[lindex $range 1]+1}] end] continue diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index f392bce..89e8e5c 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -470,6 +470,7 @@ proc plus-pkgs {type args} { continue } } + set dir [string trimright $dir "0123456789-."] switch $type { n { set title "$name Package Commands" @@ -647,10 +648,12 @@ try { append appdir "$tkdir" } + apply {{} { + global packageBuildList tcltkdir tcldir build_tcl # When building docs for Tcl, try to build docs for bundled packages too set packageBuildList {} - if {$build_tcl} { + if {$build_tcl} { set pkgsDir [file join $tcltkdir $tcldir pkgs] set subdirs [glob -nocomplain -types d -tails -directory $pkgsDir *] @@ -693,7 +696,8 @@ try { foreach line [split [read $f] \n] { if {[string trim $line] eq ""} continue if {[string match #* $line]} continue - lappend packageDirNameMap {*}$line + lassign $line dir name + lappend packageDirNameMap $dir $name } } finally { close $f @@ -714,6 +718,7 @@ try { lset packageBuildList $idx+1 [dict get $packageDirNameMap $n] } } + }} # # Invoke the scraper/converter engine. diff --git a/unix/Makefile.in b/unix/Makefile.in index bc396e2..093fb40 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1950,6 +1950,7 @@ $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ +EOLFIX=$(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH} rm -rf $(DISTDIR) mkdir -p $(DISTDIR)/unix @@ -1965,7 +1966,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M $(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - mkdir $(DISTDIR)/generic + @mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic @@ -1973,7 +1974,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) - mkdir $(DISTDIR)/library + @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library for i in http1.0 http opt msgcat reg dde tcltest platform; \ @@ -1981,31 +1982,32 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; - mkdir $(DISTDIR)/library/encoding + @mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding - mkdir $(DISTDIR)/library/msgs + @mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs - ( cd $(TOP_DIR); \ + @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata + @( cd $(TOP_DIR); \ find library/tzdata -name CVS -prune -o -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) - mkdir $(DISTDIR)/doc + @mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc - mkdir $(DISTDIR)/compat + @mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \ $(COMPAT_DIR)/README $(DISTDIR)/compat - mkdir $(DISTDIR)/compat/zlib + @mkdir $(DISTDIR)/compat/zlib ( cd $(COMPAT_DIR)/zlib; \ find . -name CVS -prune -o -type f -print ) \ | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) - mkdir $(DISTDIR)/tests + @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests - mkdir $(DISTDIR)/win + @mkdir $(DISTDIR)/win cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \ $(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \ @@ -2014,49 +2016,48 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/*.bat + @$(EOLFIX) -crlf $(DISTDIR)/win/*.bat cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/makefile.* + @$(EOLFIX) -crlf $(DISTDIR)/win/makefile.* cp -p $(TOP_DIR)/win/rules.vc $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/rules.vc + @$(EOLFIX) -crlf $(DISTDIR)/win/rules.vc cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/coffbase.txt + @$(EOLFIX) -crlf $(DISTDIR)/win/coffbase.txt cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.hpj.in cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds* + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.ds* cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win - mkdir $(DISTDIR)/macosx + @mkdir $(DISTDIR)/macosx cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \ $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx - mkdir $(DISTDIR)/macosx/Tcl.xcode + @mkdir $(DISTDIR)/macosx/Tcl.xcode cp -p $(MAC_OSX_DIR)/Tcl.xcode/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcode/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcode - mkdir $(DISTDIR)/macosx/Tcl.xcodeproj + @mkdir $(DISTDIR)/macosx/Tcl.xcodeproj cp -p $(MAC_OSX_DIR)/Tcl.xcodeproj/project.pbxproj \ $(MAC_OSX_DIR)/Tcl.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tcl.xcodeproj - mkdir $(DISTDIR)/unix/dltest + @mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ - $(UNIX_DIR)/dltest/README \ - $(DISTDIR)/unix/dltest - mkdir $(DISTDIR)/tools + $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest + @mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools - $(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in - mkdir $(DISTDIR)/libtommath - cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h \ - $(DISTDIR)/libtommath - mkdir $(DISTDIR)/pkgs + @$(EOLFIX) -crlf $(DISTDIR)/tools/tcl.hpj.in + @mkdir $(DISTDIR)/libtommath + cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath + @mkdir $(DISTDIR)/pkgs cp $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs + cp $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null`; do \ tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ done -- cgit v0.12 From 9948d29038eeaaed7e7f3a5d39b22b5462f2c825 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Oct 2013 10:55:37 +0000 Subject: Bump tcltest version to 2.3.6 (should have been done just before the 8.5.15 release, just as in Tcl 8.6.1). Don't fix eol-style for Makefile.in in "make dist", if the file system is case-insensitive/case-preserving. --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 89 ++++++++++++++++++++++++++++---------------- win/Makefile.in | 4 +- 4 files changed, 60 insertions(+), 37 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 4b0a9bc..60a9485 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d6e6487..c30d2e4 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.5 + variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 7c567d3..210d90b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -308,7 +308,7 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ bn_mp_radix_size.o bn_mp_radix_smap.o \ bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_set_int.o \ - bn_mp_shrink.o \ + bn_mp_shrink.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \ @@ -540,6 +540,10 @@ DTRACE_SRC = $(GENERIC_DIR)/tclDTrace.d SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \ $(STUB_SRCS) @PLAT_SRCS@ +#-------------------------------------------------------------------------- +# Start of rules +#-------------------------------------------------------------------------- + all: binaries libraries doc binaries: ${LIB_FILE} $(STUB_LIB_FILE) ${TCL_EXE} @@ -719,11 +723,11 @@ install-binaries: binaries done; @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ - @chmod 555 "$(DLL_INSTALL_DIR)"/$(LIB_FILE) + @chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)" @echo "Installing ${TCL_EXE} as $(BIN_INSTALL_DIR)/tclsh$(VERSION)@EXEEXT@" - @$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)"/tclsh$(VERSION)@EXEEXT@ + @$(INSTALL_PROGRAM) ${TCL_EXE} "$(BIN_INSTALL_DIR)/tclsh$(VERSION)@EXEEXT@" @echo "Installing tclConfig.sh to $(CONFIG_INSTALL_DIR)/" - @$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)"/tclConfig.sh + @$(INSTALL_DATA) tclConfig.sh "$(CONFIG_INSTALL_DIR)/tclConfig.sh" @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ @@ -775,8 +779,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; @@ -854,10 +858,12 @@ install-doc: doc @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done + @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done + @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ @@ -902,6 +908,10 @@ distclean: clean depend: makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) +#-------------------------------------------------------------------------- +# Rules for how to compile C files +#-------------------------------------------------------------------------- + # Test binaries. The rules for tclTestInit.o and xtTestInit.o are complicated # because they are compiled from tclAppInit.c. Can't use the "-o" option # because this doesn't work on some strange compilers (e.g. UnixWare). @@ -1134,7 +1144,7 @@ tclPkg.o: $(GENERIC_DIR)/tclPkg.c # prefix/exec_prefix but all the different paths individually. tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c - $(CC) -c $(CC_SWITCHES) \ + $(CC) -c $(CC_SWITCHES) \ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR)\"" \ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR)\"" \ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR)\"" \ @@ -1475,11 +1485,13 @@ $(DTRACE_HDR): $(DTRACE_SRC) $(DTRACE_OBJ): $(DTRACE_SRC) $(TCL_OBJS) $(DTRACE) -G $(DTRACE_SWITCHES) -o $@ -s $(DTRACE_SRC) $(TCL_OBJS) +#-------------------------------------------------------------------------- # The following targets are not completely general. They are provide purely # for documentation purposes so people who are interested in the Xt based # notifier can modify them to suit their own installation. +#-------------------------------------------------------------------------- -xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ +xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ @DL_OBJS@ ${BUILD_DLTEST} ${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ @DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \ @@ -1493,10 +1505,12 @@ tclXtTest.o: $(UNIX_DIR)/tclXtTest.c $(CC) -c $(APP_CC_SWITCHES) -I/usr/openwin/include \ $(UNIX_DIR)/tclXtTest.c +#-------------------------------------------------------------------------- # Compat binaries, these must be compiled for use in a shared library even # though they may be placed in a static executable or library. Since they are # included in both the tcl library and the stub library, they need to be # relocatable. +#-------------------------------------------------------------------------- fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c @@ -1525,8 +1539,10 @@ strtoul.o: $(COMPAT_DIR)/strtoul.c waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c +#-------------------------------------------------------------------------- # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive +#-------------------------------------------------------------------------- tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) -DSTATIC_BUILD $(GENERIC_DIR)/tclStubLib.c @@ -1600,6 +1616,10 @@ checkexports: $(TCL_LIB_FILE) | awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \ | sort -n | grep -E -v '^[Tt]cl' || true +#-------------------------------------------------------------------------- +# Distribution building rules +#-------------------------------------------------------------------------- + # # Target to create a Tcl RPM for Linux. Requires that you be on a Linux # system. @@ -1633,6 +1653,7 @@ $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ +EOLFIX=$(NATIVE_TCLSH) $(TOOL_DIR)/eolFix.tcl dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure genstubs rm -rf $(DISTDIR) mkdir -p $(DISTDIR)/unix @@ -1647,7 +1668,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in chmod 775 $(DISTDIR)/unix/ldAix - mkdir $(DISTDIR)/generic + @mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic @@ -1655,7 +1676,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) - mkdir $(DISTDIR)/library + @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library for i in http1.0 http opt msgcat reg dde tcltest platform; \ @@ -1663,26 +1684,27 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; - mkdir $(DISTDIR)/library/encoding + @mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding - mkdir $(DISTDIR)/library/msgs + @mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs - ( cd $(TOP_DIR); \ + @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata + @( cd $(TOP_DIR); \ find library/tzdata -name CVS -prune -o -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) - mkdir $(DISTDIR)/doc + @mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc - mkdir $(DISTDIR)/compat + @mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \ $(COMPAT_DIR)/README $(DISTDIR)/compat - mkdir $(DISTDIR)/tests + @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests - mkdir $(DISTDIR)/win + @mkdir $(DISTDIR)/win cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \ $(TOP_DIR)/win/tclConfig.sh.in \ @@ -1691,45 +1713,45 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(MAC_OSX_DIR)/configure cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/*.bat + @$(EOLFIX) -crlf $(DISTDIR)/win/*.bat cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/makefile.* + @$(EOLFIX) -crlf $(DISTDIR)/win/makefile.bc $(DISTDIR)/win/makefile.vc cp -p $(TOP_DIR)/win/rules.vc $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/rules.vc + @$(EOLFIX) -crlf $(DISTDIR)/win/rules.vc cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/coffbase.txt + @$(EOLFIX) -crlf $(DISTDIR)/win/coffbase.txt cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.hpj.in cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds* + @$(EOLFIX) -crlf $(DISTDIR)/win/tcl.ds* cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win - mkdir $(DISTDIR)/macosx + @mkdir $(DISTDIR)/macosx cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \ $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx - mkdir $(DISTDIR)/macosx/Tcl.pbproj + @mkdir $(DISTDIR)/macosx/Tcl.pbproj cp -p $(MAC_OSX_DIR)/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj - mkdir $(DISTDIR)/macosx/Tcl.xcode + @mkdir $(DISTDIR)/macosx/Tcl.xcode cp -p $(MAC_OSX_DIR)/Tcl.xcode/*.pbx* $(DISTDIR)/macosx/Tcl.xcode - mkdir $(DISTDIR)/macosx/Tcl.xcodeproj + @mkdir $(DISTDIR)/macosx/Tcl.xcodeproj cp -p $(TOP_DIR)/macosx/Tcl.xcodeproj/*.pbx* $(DISTDIR)/macosx/Tcl.xcodeproj - mkdir $(DISTDIR)/unix/dltest + @mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README \ $(DISTDIR)/unix/dltest - mkdir $(DISTDIR)/tools + @mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/tcl.wse.in $(TOOL_DIR)/*.bmp \ $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools - $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \ + @$(EOLFIX)-crlf $(DISTDIR)/tools/tcl.hpj.in \ $(DISTDIR)/tools/tcl.wse.in - mkdir $(DISTDIR)/libtommath + @mkdir $(DISTDIR)/libtommath cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h \ $(DISTDIR)/libtommath @@ -1738,12 +1760,12 @@ alldist: dist cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \ gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME) -# +#-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool # workspace. It depends on the Tcl & Tk being in directories called tcl8.* & # tk8.* up two directories from the TOOL_DIR. -# +#-------------------------------------------------------------------------- html: ${TCL_EXE} $(BUILD_HTML) @@ -1839,4 +1861,5 @@ package-generate: pkgtrans -s . $(PACKAGE).`arch` $(PACKAGE) rm -rf $(PACKAGE) +#-------------------------------------------------------------------------- # DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/win/Makefile.in b/win/Makefile.in index 7d9e844..e0b2f26 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -651,8 +651,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 5873d26c7268ee5af9f31c126c64b4350736c458 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Oct 2013 08:15:36 +0000 Subject: Workaround for [414d10346b]: tcl 8.5.15/8.6.1(threaded build) hangs in exec on HP-UX --- unix/tclUnixNotfy.c | 6 +++--- unix/tclUnixTest.c | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index f41ef68..8e59044 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -202,7 +202,7 @@ static Tcl_ThreadId notifierThread; #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); -#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux) static int atForkInit = 0; static void AtForkPrepare(void); static void AtForkParent(void); @@ -282,7 +282,7 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); -#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux) /* * Install pthread_atfork handlers to reinitialize the notifier in the * child of a fork. @@ -1273,7 +1273,7 @@ NotifierThreadProc( TclpThreadExit (0); } -#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) +#if defined(HAVE_PTHREAD_ATFORK) && !defined(__APPLE__) && !defined(__hpux) /* *---------------------------------------------------------------------- * diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index bb16f3b..0747c2d 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -574,12 +574,11 @@ TestforkObjCmd( "Cannot fork", NULL); return TCL_ERROR; } -#if !defined(HAVE_PTHREAD_ATFORK) - /* Only needed when pthread_atfork is not present. */ + /* Only needed when pthread_atfork is not present, + * should not hurt otherwise. */ if (pid==0) { Tcl_InitNotifier(); } -#endif Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); return TCL_OK; } -- cgit v0.12 From 3b3f0179aee2dce77bfef12308c53429523675bc Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 29 Oct 2013 20:07:56 +0000 Subject: Now do [string toupper], [string tolower] and [string totitle]. Only handles the no-indices case; that's the only case anyone actually commonly uses. --- generic/tclAssembly.c | 14 ++-- generic/tclCmdMZ.c | 6 +- generic/tclCompCmdsGR.c | 2 +- generic/tclCompCmdsSZ.c | 171 +++++++++++++++++++++++++++++++++++------------- generic/tclCompile.c | 13 ++++ generic/tclCompile.h | 12 ++-- generic/tclExecute.c | 55 +++++++++++++++- generic/tclInt.h | 9 +++ 8 files changed, 221 insertions(+), 61 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b805c63..cd0a42d 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -453,6 +453,9 @@ static const TalInstDesc TalInstructionTable[] = { | INST_STORE_ARRAY4), 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, + {"strLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, + {"strTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, + {"strUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, @@ -464,9 +467,9 @@ static const TalInstDesc TalInstructionTable[] = { {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, - {"strtrim", ASSEM_1BYTE, INST_STRTRIM, 2, 1}, - {"strtrimLeft", ASSEM_1BYTE, INST_STRTRIM_LEFT, 2, 1}, - {"strtrimRight", ASSEM_1BYTE, INST_STRTRIM_RIGHT, 2, 1}, + {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, + {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, + {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, @@ -509,8 +512,9 @@ static const unsigned char NonThrowingByteCodes[] = { INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ INST_RESOLVE_COMMAND, /* 154 */ - INST_STRTRIM, INST_STRTRIM_LEFT, INST_STRTRIM_RIGHT, /* 166-168 */ - INST_CONCAT_STK /* 169 */ + INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ + INST_CONCAT_STK, /* 169 */ + INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */ }; /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2b5e995..da8ffe3 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3341,9 +3341,9 @@ TclInitStringCmd( {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, + {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, + {"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0}, {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index a02f0a8..50fb8e9 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -33,7 +33,7 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp, /* *---------------------------------------------------------------------- * - * TclCompileLinsertCmd -- + * GetIndexFromToken -- * * Parse a token and get the encoded version of the index (as understood * by TEBC), assuming it is at all knowable at compile time. Only handles diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 646adf3..ca4b316 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -101,6 +101,59 @@ const AuxDataType tclJumptableInfoType = { if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) + +#define INDEX_END (-2) + +/* + *---------------------------------------------------------------------- + * + * GetIndexFromToken -- + * + * Parse a token and get the encoded version of the index (as understood + * by TEBC), assuming it is at all knowable at compile time. Only handles + * indices that are integers or 'end' or 'end-integer'. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * Sets *index to the index value if successful. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetIndexFromToken( + Tcl_Token *tokenPtr, + int *index) +{ + Tcl_Obj *tmpObj = Tcl_NewObj(); + int result, idx; + + if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + Tcl_DecrRefCount(tmpObj); + return TCL_ERROR; + } + + result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx); + if (result == TCL_OK && idx > INDEX_END) { + result = TCL_ERROR; + } + } + Tcl_DecrRefCount(tmpObj); + + if (result == TCL_OK) { + *index = idx; + } + + return result; +} /* *---------------------------------------------------------------------- @@ -565,8 +618,7 @@ TclCompileStringRangeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; - Tcl_Obj *tmpObj; - int idx1, idx2, result; + int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; @@ -576,50 +628,13 @@ TclCompileStringRangeCmd( toTokenPtr = TokenAfter(fromTokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * Parse the two indices. */ - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { - if (idx1 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { - if (idx1 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) { goto nonConstantIndices; } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { - if (idx2 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { - if (idx2 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) { goto nonConstantIndices; } @@ -698,7 +713,7 @@ TclCompileStringTrimLCmd( } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); } - OP( STRTRIM_LEFT); + OP( STR_TRIM_LEFT); return TCL_OK; } @@ -726,7 +741,7 @@ TclCompileStringTrimRCmd( } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); } - OP( STRTRIM_RIGHT); + OP( STR_TRIM_RIGHT); return TCL_OK; } @@ -754,7 +769,73 @@ TclCompileStringTrimCmd( } else { PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); } - OP( STRTRIM); + OP( STR_TRIM); + return TCL_OK; +} + +int +TclCompileStringToUpperCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_UPPER); + return TCL_OK; +} + +int +TclCompileStringToLowerCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_LOWER); + return TCL_OK; +} + +int +TclCompileStringToTitleCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_TITLE); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 280bf64..48165e6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -566,6 +566,19 @@ InstructionDesc const tclInstructionTable[] = { * is number of values to concatenate. * Operation: push concat(stk1 stk2 ... stktop) */ + {"strUpper", 1, 0, 0, {OPERAND_NONE}}, + /* [string toupper] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strLower", 1, 0, 0, {OPERAND_NONE}}, + /* [string tolower] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strTitle", 1, 0, 0, {OPERAND_NONE}}, + /* [string totitle] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 4ae754c..1d21d39 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -769,14 +769,18 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 /* For compilation of [string trim] and related */ -#define INST_STRTRIM 166 -#define INST_STRTRIM_LEFT 167 -#define INST_STRTRIM_RIGHT 168 +#define INST_STR_TRIM 166 +#define INST_STR_TRIM_LEFT 167 +#define INST_STR_TRIM_RIGHT 168 #define INST_CONCAT_STK 169 +#define INST_STR_UPPER 170 +#define INST_STR_LOWER 171 +#define INST_STR_TITLE 172 + /* The last opcode */ -#define LAST_INST_OPCODE 169 +#define LAST_INST_OPCODE 172 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index cb6afaf..3889ce0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5002,6 +5002,55 @@ TEBCresume( TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); + case INST_STR_UPPER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.25s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToUpper(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToUpper(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_LOWER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.25s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToLower(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToLower(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_TITLE: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.25s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToTitle(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToTitle(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -5271,7 +5320,7 @@ TEBCresume( const char *string1, *string2; int trim1, trim2; - case INST_STRTRIM: + case INST_STR_TRIM: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); @@ -5292,7 +5341,7 @@ TEBCresume( O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } - case INST_STRTRIM_LEFT: + case INST_STR_TRIM_LEFT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); @@ -5308,7 +5357,7 @@ TEBCresume( O2S(valuePtr), O2S(value2Ptr)), objResultPtr); NEXT_INST_F(1, 2, 1); } - case INST_STRTRIM_RIGHT: + case INST_STR_TRIM_RIGHT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); diff --git a/generic/tclInt.h b/generic/tclInt.h index cc8469b..6806302 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3620,6 +3620,15 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToTitleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToUpperCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From b5f69350e3ff6666d6077535041901c8d04b3617 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Oct 2013 11:44:37 +0000 Subject: Windows dll's should be executable. --- compat/zlib/win32/zlib1.dll | Bin compat/zlib/win64/zlib1.dll | Bin 2 files changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 compat/zlib/win32/zlib1.dll mode change 100644 => 100755 compat/zlib/win64/zlib1.dll diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll old mode 100644 new mode 100755 diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll old mode 100644 new mode 100755 -- cgit v0.12 From 49f8bb2d42c970325160658862b0a7f0e2cd066a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Nov 2013 10:02:58 +0000 Subject: Put extern "C" guards around all stub table struct definitions, so it is usable for C++ compilers as well without the danger of modifying the calling convention. For tclDecls.h it was no problem, because tcl.h already contains those guards. But for the other *Decls.h files (e.g. tclTomMathDecls.h) it was not correct. --- generic/tclDecls.h | 8 +++++--- generic/tclIntDecls.h | 8 +++++--- generic/tclIntPlatDecls.h | 8 +++++--- generic/tclPlatDecls.h | 8 +++++--- generic/tclTomMathDecls.h | 8 +++++--- tools/genStubs.tcl | 5 +++-- 6 files changed, 28 insertions(+), 17 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4ca9f68..b11c0d8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -31,6 +31,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -4131,10 +4135,8 @@ typedef struct TclStubs { void (*tclUnusedStubEntry) (void); /* 630 */ } TclStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclStubs *tclStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 1dc797a..e4e85ad 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -50,6 +50,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -1309,10 +1313,8 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ } TclIntStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclIntStubs *tclIntStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1e68c9c..80dd2ad 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -37,6 +37,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -533,10 +537,8 @@ typedef struct TclIntPlatStubs { #endif /* MACOSX */ } TclIntPlatStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclIntPlatStubs *tclIntPlatStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 8652e8d..ef23c84 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -36,6 +36,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -87,10 +91,8 @@ typedef struct TclPlatStubs { #endif /* MACOSX */ } TclPlatStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclPlatStubs *tclPlatStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 04a23f3..056ad85 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -134,6 +134,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -538,10 +542,8 @@ typedef struct TclTomMathStubs { int (*tclBN_mp_cnt_lsb) (mp_int *a); /* 63 */ } TclTomMathStubs; -#ifdef __cplusplus -extern "C" { -#endif extern TclTomMathStubs *tclTomMathStubsPtr; + #ifdef __cplusplus } #endif diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index c7dbe93..37205b2 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -991,6 +991,8 @@ proc genStubs::emitHeader {name} { append text "#define ${CAPName}_STUBS_REVISION $revision\n" } + append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n" + emitDeclarations $name text if {[info exists hooks($name)]} { @@ -1014,8 +1016,7 @@ proc genStubs::emitHeader {name} { append text "} ${capName}Stubs;\n\n" - append text "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" - append text "extern ${capName}Stubs *${name}StubsPtr;\n" + append text "extern ${capName}Stubs *${name}StubsPtr;\n\n" append text "#ifdef __cplusplus\n}\n#endif\n" emitMacros $name text -- cgit v0.12 From cda2a285e3db35f852210c948e5ccff1e69806f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 5 Nov 2013 12:36:17 +0000 Subject: Fix [426679ef7d]: Having man.macros after .TH breaks rendering on OpenBSD and possibly others. --- doc/Access.3 | 2 +- doc/AddErrInfo.3 | 2 +- doc/Alloc.3 | 2 +- doc/AllowExc.3 | 2 +- doc/AppInit.3 | 2 +- doc/AssocData.3 | 2 +- doc/Async.3 | 2 +- doc/BackgdErr.3 | 2 +- doc/Backslash.3 | 2 +- doc/BoolObj.3 | 2 +- doc/ByteArrObj.3 | 2 +- doc/CallDel.3 | 2 +- doc/ChnlStack.3 | 2 +- doc/CmdCmplt.3 | 2 +- doc/Concat.3 | 2 +- doc/CrtChannel.3 | 2 +- doc/CrtChnlHdlr.3 | 2 +- doc/CrtCloseHdlr.3 | 2 +- doc/CrtCommand.3 | 2 +- doc/CrtFileHdlr.3 | 2 +- doc/CrtInterp.3 | 2 +- doc/CrtMathFnc.3 | 2 +- doc/CrtObjCmd.3 | 2 +- doc/CrtSlave.3 | 2 +- doc/CrtTimerHdlr.3 | 2 +- doc/CrtTrace.3 | 2 +- doc/DString.3 | 2 +- doc/DetachPids.3 | 2 +- doc/DictObj.3 | 2 +- doc/DoOneEvent.3 | 2 +- doc/DoWhenIdle.3 | 2 +- doc/DoubleObj.3 | 2 +- doc/DumpActiveMemory.3 | 2 +- doc/Encoding.3 | 2 +- doc/Ensemble.3 | 2 +- doc/Environment.3 | 2 +- doc/Eval.3 | 2 +- doc/Exit.3 | 2 +- doc/ExprLong.3 | 2 +- doc/ExprLongObj.3 | 2 +- doc/FileSystem.3 | 2 +- doc/FindExec.3 | 2 +- doc/GetCwd.3 | 2 +- doc/GetHostName.3 | 2 +- doc/GetIndex.3 | 2 +- doc/GetInt.3 | 2 +- doc/GetOpnFl.3 | 2 +- doc/GetStdChan.3 | 2 +- doc/GetTime.3 | 2 +- doc/GetVersion.3 | 2 +- doc/Hash.3 | 2 +- doc/Init.3 | 2 +- doc/InitStubs.3 | 2 +- doc/IntObj.3 | 2 +- doc/Interp.3 | 2 +- doc/Limit.3 | 2 +- doc/LinkVar.3 | 2 +- doc/ListObj.3 | 2 +- doc/Namespace.3 | 2 +- doc/Notifier.3 | 2 +- doc/Object.3 | 2 +- doc/ObjectType.3 | 2 +- doc/OpenFileChnl.3 | 2 +- doc/OpenTcp.3 | 2 +- doc/Panic.3 | 2 +- doc/ParseCmd.3 | 2 +- doc/PkgRequire.3 | 2 +- doc/Preserve.3 | 2 +- doc/PrintDbl.3 | 2 +- doc/RecEvalObj.3 | 2 +- doc/RecordEval.3 | 2 +- doc/RegConfig.3 | 2 +- doc/RegExp.3 | 2 +- doc/SaveResult.3 | 2 +- doc/SetChanErr.3 | 2 +- doc/SetErrno.3 | 2 +- doc/SetRecLmt.3 | 2 +- doc/SetResult.3 | 2 +- doc/SetVar.3 | 2 +- doc/Signal.3 | 2 +- doc/Sleep.3 | 2 +- doc/SourceRCFile.3 | 2 +- doc/SplitList.3 | 2 +- doc/SplitPath.3 | 2 +- doc/StaticPkg.3 | 2 +- doc/StdChannels.3 | 2 +- doc/StrMatch.3 | 2 +- doc/StringObj.3 | 2 +- doc/SubstObj.3 | 2 +- doc/TCL_MEM_DEBUG.3 | 2 +- doc/Tcl.n | 2 +- doc/Tcl_Main.3 | 2 +- doc/Thread.3 | 2 +- doc/ToUpper.3 | 2 +- doc/TraceCmd.3 | 2 +- doc/TraceVar.3 | 2 +- doc/Translate.3 | 2 +- doc/UniCharIsAlpha.3 | 2 +- doc/UpVar.3 | 2 +- doc/Utf.3 | 2 +- doc/WrongNumArgs.3 | 2 +- doc/after.n | 2 +- doc/append.n | 2 +- doc/apply.n | 2 +- doc/array.n | 2 +- doc/bgerror.n | 2 +- doc/binary.n | 2 +- doc/break.n | 2 +- doc/case.n | 2 +- doc/catch.n | 2 +- doc/cd.n | 2 +- doc/chan.n | 2 +- doc/clock.n | 2 +- doc/close.n | 2 +- doc/concat.n | 2 +- doc/continue.n | 2 +- doc/dde.n | 2 +- doc/dict.n | 2 +- doc/encoding.n | 2 +- doc/eof.n | 2 +- doc/error.n | 2 +- doc/eval.n | 2 +- doc/exec.n | 2 +- doc/exit.n | 2 +- doc/expr.n | 2 +- doc/fblocked.n | 2 +- doc/fconfigure.n | 2 +- doc/fcopy.n | 2 +- doc/file.n | 2 +- doc/fileevent.n | 2 +- doc/filename.n | 2 +- doc/flush.n | 2 +- doc/for.n | 2 +- doc/foreach.n | 2 +- doc/format.n | 2 +- doc/gets.n | 2 +- doc/glob.n | 2 +- doc/global.n | 2 +- doc/history.n | 2 +- doc/http.n | 2 +- doc/if.n | 2 +- doc/incr.n | 2 +- doc/info.n | 2 +- doc/interp.n | 2 +- doc/join.n | 2 +- doc/lappend.n | 2 +- doc/lassign.n | 2 +- doc/library.n | 2 +- doc/lindex.n | 2 +- doc/linsert.n | 2 +- doc/list.n | 2 +- doc/llength.n | 2 +- doc/load.n | 2 +- doc/lrange.n | 2 +- doc/lrepeat.n | 2 +- doc/lreplace.n | 2 +- doc/lreverse.n | 2 +- doc/lsearch.n | 2 +- doc/lset.n | 2 +- doc/lsort.n | 2 +- doc/mathfunc.n | 2 +- doc/mathop.n | 2 +- doc/memory.n | 2 +- doc/msgcat.n | 2 +- doc/namespace.n | 2 +- doc/open.n | 2 +- doc/package.n | 2 +- doc/packagens.n | 2 +- doc/pid.n | 2 +- doc/pkgMkIndex.n | 2 +- doc/platform.n | 2 +- doc/platform_shell.n | 2 +- doc/proc.n | 2 +- doc/puts.n | 2 +- doc/pwd.n | 2 +- doc/re_syntax.n | 2 +- doc/read.n | 2 +- doc/refchan.n | 2 +- doc/regexp.n | 2 +- doc/registry.n | 2 +- doc/regsub.n | 2 +- doc/rename.n | 2 +- doc/return.n | 2 +- doc/safe.n | 2 +- doc/scan.n | 2 +- doc/seek.n | 2 +- doc/set.n | 2 +- doc/socket.n | 2 +- doc/source.n | 2 +- doc/split.n | 2 +- doc/string.n | 2 +- doc/subst.n | 2 +- doc/switch.n | 2 +- doc/tclsh.1 | 2 +- doc/tcltest.n | 2 +- doc/tclvars.n | 2 +- doc/tell.n | 2 +- doc/time.n | 2 +- doc/tm.n | 2 +- doc/trace.n | 2 +- doc/unknown.n | 2 +- doc/unload.n | 2 +- doc/unset.n | 2 +- doc/update.n | 2 +- doc/uplevel.n | 2 +- doc/upvar.n | 2 +- doc/variable.n | 2 +- doc/vwait.n | 2 +- doc/while.n | 2 +- 209 files changed, 209 insertions(+), 209 deletions(-) diff --git a/doc/Access.3 b/doc/Access.3 index 98d6635..b77e5fa 100644 --- a/doc/Access.3 +++ b/doc/Access.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Access, Tcl_Stat \- check file permissions and other attributes diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index 136a16f..577b6c7 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options diff --git a/doc/Alloc.3 b/doc/Alloc.3 index ca4f949..585704a 100644 --- a/doc/Alloc.3 +++ b/doc/Alloc.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory diff --git a/doc/AllowExc.3 b/doc/AllowExc.3 index ae595f1..2343e66 100644 --- a/doc/AllowExc.3 +++ b/doc/AllowExc.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AllowExceptions \- allow all exceptions in next script evaluation diff --git a/doc/AppInit.3 b/doc/AppInit.3 index 0473090..6a329e2 100644 --- a/doc/AppInit.3 +++ b/doc/AppInit.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AppInit \- perform application-specific initialization diff --git a/doc/AssocData.3 b/doc/AssocData.3 index e4c7bab..c402057 100644 --- a/doc/AssocData.3 +++ b/doc/AssocData.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetAssocData 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations of string keys and user specified data with Tcl interpreters diff --git a/doc/Async.3 b/doc/Async.3 index c4439a4..d7a5147 100644 --- a/doc/Async.3 +++ b/doc/Async.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events diff --git a/doc/BackgdErr.3 b/doc/BackgdErr.3 index 1e46b03..4291167 100644 --- a/doc/BackgdErr.3 +++ b/doc/BackgdErr.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_BackgroundError 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_BackgroundError \- report Tcl error that occurred in background processing diff --git a/doc/Backslash.3 b/doc/Backslash.3 index 8b399fc..f121c7c 100644 --- a/doc/Backslash.3 +++ b/doc/Backslash.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Backslash \- parse a backslash sequence diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index 395d159..f10ae88 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_BooleanObj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 738da32..c031d53 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl objects as a arrays of bytes diff --git a/doc/CallDel.3 b/doc/CallDel.3 index 8e6445b..0f53b2e 100644 --- a/doc/CallDel.3 +++ b/doc/CallDel.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CallWhenDeleted 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted diff --git a/doc/ChnlStack.3 b/doc/ChnlStack.3 index 8ac5a0d..16dc745 100644 --- a/doc/ChnlStack.3 +++ b/doc/ChnlStack.3 @@ -3,8 +3,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -.so man.macros .TH Tcl_StackChannel 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CmdCmplt.3 b/doc/CmdCmplt.3 index eeae039..25b372e 100644 --- a/doc/CmdCmplt.3 +++ b/doc/CmdCmplt.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CommandComplete \- Check for unmatched braces in a Tcl command diff --git a/doc/Concat.3 b/doc/Concat.3 index c38bf82..58a0fb6 100644 --- a/doc/Concat.3 +++ b/doc/Concat.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Concat \- concatenate a collection of strings diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 212a239..21b5c37 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -4,8 +4,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -.so man.macros .TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CrtChnlHdlr.3 b/doc/CrtChnlHdlr.3 index f5fd1bd..affd7e2 100644 --- a/doc/CrtChnlHdlr.3 +++ b/doc/CrtChnlHdlr.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateChannelHandler 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CrtCloseHdlr.3 b/doc/CrtCloseHdlr.3 index c8804b1..9406ece 100644 --- a/doc/CrtCloseHdlr.3 +++ b/doc/CrtCloseHdlr.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateCloseHandler 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/CrtCommand.3 b/doc/CrtCommand.3 index fcc04d5..748ff2d 100644 --- a/doc/CrtCommand.3 +++ b/doc/CrtCommand.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateCommand \- implement new commands in C diff --git a/doc/CrtFileHdlr.3 b/doc/CrtFileHdlr.3 index 5627bd4..e35020c 100644 --- a/doc/CrtFileHdlr.3 +++ b/doc/CrtFileHdlr.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateFileHandler 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices (Unix only) diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3 index 957e742..ab44fc6 100644 --- a/doc/CrtInterp.3 +++ b/doc/CrtInterp.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters diff --git a/doc/CrtMathFnc.3 b/doc/CrtMathFnc.3 index 9629912..0f101d7 100644 --- a/doc/CrtMathFnc.3 +++ b/doc/CrtMathFnc.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index a05efc2..005bf97 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C diff --git a/doc/CrtSlave.3 b/doc/CrtSlave.3 index 3863373..8457d21 100644 --- a/doc/CrtSlave.3 +++ b/doc/CrtSlave.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands diff --git a/doc/CrtTimerHdlr.3 b/doc/CrtTimerHdlr.3 index e948728..39702b1 100644 --- a/doc/CrtTimerHdlr.3 +++ b/doc/CrtTimerHdlr.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateTimerHandler 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateTimerHandler, Tcl_DeleteTimerHandler \- call a procedure at a given time diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 076f47b..ec83c91 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced diff --git a/doc/DString.3 b/doc/DString.3 index a85b1cf..0e571d2 100644 --- a/doc/DString.3 +++ b/doc/DString.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings diff --git a/doc/DetachPids.3 b/doc/DetachPids.3 index 0535cd8..39a51d3 100644 --- a/doc/DetachPids.3 +++ b/doc/DetachPids.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DetachPids 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DetachPids, Tcl_ReapDetachedProcs, Tcl_WaitPid \- manage child processes in background diff --git a/doc/DictObj.3 b/doc/DictObj.3 index 74b8dd1..badba69 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DictObj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/DoOneEvent.3 b/doc/DoOneEvent.3 index 9bdf926..6f08b34 100644 --- a/doc/DoOneEvent.3 +++ b/doc/DoOneEvent.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DoOneEvent 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DoOneEvent \- wait for events and invoke event handlers diff --git a/doc/DoWhenIdle.3 b/doc/DoWhenIdle.3 index bfc19fb..501378e 100644 --- a/doc/DoWhenIdle.3 +++ b/doc/DoWhenIdle.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DoWhenIdle 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DoWhenIdle, Tcl_CancelIdleCall \- invoke a procedure when there are no pending events diff --git a/doc/DoubleObj.3 b/doc/DoubleObj.3 index 12818b0..a2496d9 100644 --- a/doc/DoubleObj.3 +++ b/doc/DoubleObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl objects as floating-point values diff --git a/doc/DumpActiveMemory.3 b/doc/DumpActiveMemory.3 index 1f6cb46..f4d78d1 100644 --- a/doc/DumpActiveMemory.3 +++ b/doc/DumpActiveMemory.3 @@ -3,8 +3,8 @@ '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH "Tcl_DumpActiveMemory" 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_DumpActiveMemory, Tcl_InitMemory, Tcl_ValidateAllMemory \- Validated memory allocation interface diff --git a/doc/Encoding.3 b/doc/Encoding.3 index a940a5b..c14338d 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings diff --git a/doc/Ensemble.3 b/doc/Ensemble.3 index bc743c2..3cf3143 100644 --- a/doc/Ensemble.3 +++ b/doc/Ensemble.3 @@ -6,8 +6,8 @@ '\" '\" This documents the C API introduced in TIP#235 '\" -.so man.macros .TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsembleSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands diff --git a/doc/Environment.3 b/doc/Environment.3 index 3753f43..dee693b 100644 --- a/doc/Environment.3 +++ b/doc/Environment.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_PutEnv \- procedures to manipulate the environment diff --git a/doc/Eval.3 b/doc/Eval.3 index f232cad..92dce7c 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts diff --git a/doc/Exit.3 b/doc/Exit.3 index aa69b47..1738dbe 100644 --- a/doc/Exit.3 +++ b/doc/Exit.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Exit 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_ExitThread, Tcl_FinalizeThread, Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler, Tcl_SetExitProc \- end the application or thread (and invoke exit handlers) diff --git a/doc/ExprLong.3 b/doc/ExprLong.3 index ef93284..33d68ba 100644 --- a/doc/ExprLong.3 +++ b/doc/ExprLong.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression diff --git a/doc/ExprLongObj.3 b/doc/ExprLongObj.3 index c8a564d..9dd7f0b 100644 --- a/doc/ExprLongObj.3 +++ b/doc/ExprLongObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index c4a28c2..7954ac8 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem diff --git a/doc/FindExec.3 b/doc/FindExec.3 index 0e225e9..af9d9ad 100644 --- a/doc/FindExec.3 +++ b/doc/FindExec.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_FindExecutable 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_FindExecutable, Tcl_GetNameOfExecutable \- identify or return the name of the binary file containing the application diff --git a/doc/GetCwd.3 b/doc/GetCwd.3 index 964e237..58abcde 100644 --- a/doc/GetCwd.3 +++ b/doc/GetCwd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetCwd 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetCwd, Tcl_Chdir \- manipulate the current working directory diff --git a/doc/GetHostName.3 b/doc/GetHostName.3 index 28f3a4f..8aed0dc 100644 --- a/doc/GetHostName.3 +++ b/doc/GetHostName.3 @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH Tcl_GetHostName 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetHostName \- get the name of the local host diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 45d4e9c..88cd98b 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords diff --git a/doc/GetInt.3 b/doc/GetInt.3 index f77d337..4e9d636 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean diff --git a/doc/GetOpnFl.3 b/doc/GetOpnFl.3 index 38aa976..86d1b94 100644 --- a/doc/GetOpnFl.3 +++ b/doc/GetOpnFl.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetOpenFile 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetOpenFile \- Return a FILE* for a channel registered in the given interpreter (Unix only) diff --git a/doc/GetStdChan.3 b/doc/GetStdChan.3 index 045d15a..a7d9501 100644 --- a/doc/GetStdChan.3 +++ b/doc/GetStdChan.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/GetTime.3 b/doc/GetTime.3 index 14a9e8c..a617451 100644 --- a/doc/GetTime.3 +++ b/doc/GetTime.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetTime 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetTime, Tcl_SetTimeProc, Tcl_QueryTimeProc \- get date and time diff --git a/doc/GetVersion.3 b/doc/GetVersion.3 index 47034d0..89f63d5 100644 --- a/doc/GetVersion.3 +++ b/doc/GetVersion.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_GetVersion 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_GetVersion \- get the version of the library at runtime diff --git a/doc/Hash.3 b/doc/Hash.3 index 78b8459..6babe0d 100644 --- a/doc/Hash.3 +++ b/doc/Hash.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables diff --git a/doc/Init.3 b/doc/Init.3 index f421479..33c27a3 100644 --- a/doc/Init.3 +++ b/doc/Init.3 @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH Tcl_Init 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Init \- find and source initialization script diff --git a/doc/InitStubs.3 b/doc/InitStubs.3 index fe10a59..f4be477 100644 --- a/doc/InitStubs.3 +++ b/doc/InitStubs.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_InitStubs \- initialize the Tcl stubs mechanism diff --git a/doc/IntObj.3 b/doc/IntObj.3 index 5cf677d..e228bdb 100644 --- a/doc/IntObj.3 +++ b/doc/IntObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl objects as integer values diff --git a/doc/Interp.3 b/doc/Interp.3 index 0b1de03..10aadb7 100644 --- a/doc/Interp.3 +++ b/doc/Interp.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Interp \- client-visible fields of interpreter structures diff --git a/doc/Limit.3 b/doc/Limit.3 index 928ebe1..a113b74 100644 --- a/doc/Limit.3 +++ b/doc/Limit.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_LimitCheck 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_LimitAddHandler, Tcl_LimitCheck, Tcl_LimitExceeded, Tcl_LimitGetCommands, Tcl_LimitGetGranularity, Tcl_LimitGetTime, Tcl_LimitReady, Tcl_LimitRemoveHandler, Tcl_LimitSetCommands, Tcl_LimitSetGranularity, Tcl_LimitSetTime, Tcl_LimitTypeEnabled, Tcl_LimitTypeExceeded, Tcl_LimitTypeReset, Tcl_LimitTypeSet \- manage and check resource limits on interpreters diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index 6361fb4..9c13008 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 443eafe..c0cc109 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl objects as lists diff --git a/doc/Namespace.3 b/doc/Namespace.3 index 5477329..4b37c2b 100644 --- a/doc/Namespace.3 +++ b/doc/Namespace.3 @@ -7,8 +7,8 @@ '\" Note that some of these functions do not seem to belong, but they '\" were all introduced with the same TIP (#139) '\" -.so man.macros .TH Tcl_Namespace 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_AppendExportList, Tcl_CreateNamespace, Tcl_DeleteNamespace, Tcl_Export, Tcl_FindCommand, Tcl_FindNamespace, Tcl_ForgetImport, Tcl_GetCurrentNamespace, Tcl_GetGlobalNamespace, Tcl_GetNamespaceUnknownHandler, Tcl_Import, Tcl_SetNamespaceUnknownHandler \- manipulate namespaces diff --git a/doc/Notifier.3 b/doc/Notifier.3 index 7858a8c..9edf069 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Notifier 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces diff --git a/doc/Object.3 b/doc/Object.3 index 4817b9b..4df6c1a 100644 --- a/doc/Object.3 +++ b/doc/Object.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 974ea6c..0a5de3d 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl object types diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 0d722f6..10c92f6 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/OpenTcp.3 b/doc/OpenTcp.3 index 98d8cb0..ec7edcd 100644 --- a/doc/OpenTcp.3 +++ b/doc/OpenTcp.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_OpenTcpClient 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/Panic.3 b/doc/Panic.3 index b53ca11..454d313 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -2,8 +2,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/ParseCmd.3 b/doc/ParseCmd.3 index b5fc6d0..ff1be23 100644 --- a/doc/ParseCmd.3 +++ b/doc/ParseCmd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3 index 810947d..b7d0e6e 100644 --- a/doc/PkgRequire.3 +++ b/doc/PkgRequire.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_PkgRequire, Tcl_PkgRequireEx, Tcl_PkgRequireProc, Tcl_PkgPresent, Tcl_PkgPresentEx, Tcl_PkgProvide, Tcl_PkgProvideEx \- package version control diff --git a/doc/Preserve.3 b/doc/Preserve.3 index 2b3edc0..5b808cd 100644 --- a/doc/Preserve.3 +++ b/doc/Preserve.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Preserve 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Preserve, Tcl_Release, Tcl_EventuallyFree \- avoid freeing storage while it is being used diff --git a/doc/PrintDbl.3 b/doc/PrintDbl.3 index 279b4d5..508b230 100644 --- a/doc/PrintDbl.3 +++ b/doc/PrintDbl.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_PrintDouble 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_PrintDouble \- Convert floating value to string diff --git a/doc/RecEvalObj.3 b/doc/RecEvalObj.3 index 2eed471..f0bb183 100644 --- a/doc/RecEvalObj.3 +++ b/doc/RecEvalObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RecordAndEvalObj 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RecordAndEvalObj \- save command on history list before evaluating diff --git a/doc/RecordEval.3 b/doc/RecordEval.3 index a8f3087..f4a403e 100644 --- a/doc/RecordEval.3 +++ b/doc/RecordEval.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RecordAndEval \- save command on history list before evaluating diff --git a/doc/RegConfig.3 b/doc/RegConfig.3 index 19c0bb0..7f99b8f 100644 --- a/doc/RegConfig.3 +++ b/doc/RegConfig.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RegisterConfig 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/RegExp.3 b/doc/RegExp.3 index 0ac091c..c337cf8 100644 --- a/doc/RegExp.3 +++ b/doc/RegExp.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 index f47500e..74da9f4 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveResult.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- save and restore an interpreter's state diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3 index 13bd94a..aded11e 100644 --- a/doc/SetChanErr.3 +++ b/doc/SetChanErr.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/SetErrno.3 b/doc/SetErrno.3 index 1735952..21648b1 100644 --- a/doc/SetErrno.3 +++ b/doc/SetErrno.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetErrno 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetErrno, Tcl_GetErrno, Tcl_ErrnoId, Tcl_ErrnoMsg \- manipulate errno to store and retrieve error codes diff --git a/doc/SetRecLmt.3 b/doc/SetRecLmt.3 index e38ba2f..904d4ab 100644 --- a/doc/SetRecLmt.3 +++ b/doc/SetRecLmt.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter diff --git a/doc/SetResult.3 b/doc/SetResult.3 index 2245794..4bb9101 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_FreeResult \- manipulate Tcl result diff --git a/doc/SetVar.3 b/doc/SetVar.3 index ce47a73..e0eb51e 100644 --- a/doc/SetVar.3 +++ b/doc/SetVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables diff --git a/doc/Signal.3 b/doc/Signal.3 index 5b12654..70b9d91 100644 --- a/doc/Signal.3 +++ b/doc/Signal.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SignalId 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SignalId, Tcl_SignalMsg \- Convert signal codes diff --git a/doc/Sleep.3 b/doc/Sleep.3 index 2423ba1..2d36697 100644 --- a/doc/Sleep.3 +++ b/doc/Sleep.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Sleep 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Sleep \- delay execution for a given number of milliseconds diff --git a/doc/SourceRCFile.3 b/doc/SourceRCFile.3 index eabc47c..0afb66b 100644 --- a/doc/SourceRCFile.3 +++ b/doc/SourceRCFile.3 @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH Tcl_SourceRCFile 3 8.3 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SourceRCFile \- source the Tcl rc file diff --git a/doc/SplitList.3 b/doc/SplitList.3 index fd6ec8b..0fefc8b 100644 --- a/doc/SplitList.3 +++ b/doc/SplitList.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SplitList 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement, Tcl_ScanCountedElement, Tcl_ConvertCountedElement \- manipulate Tcl lists diff --git a/doc/SplitPath.3 b/doc/SplitPath.3 index 6578e3d..6863b6f 100644 --- a/doc/SplitPath.3 +++ b/doc/SplitPath.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SplitPath 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SplitPath, Tcl_JoinPath, Tcl_GetPathType \- manipulate platform-dependent file paths diff --git a/doc/StaticPkg.3 b/doc/StaticPkg.3 index 0dd67d1..0b2ad57 100644 --- a/doc/StaticPkg.3 +++ b/doc/StaticPkg.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_StaticPackage \- make a statically linked package available via the 'load' command diff --git a/doc/StdChannels.3 b/doc/StdChannels.3 index b5b020e..651ad7d 100644 --- a/doc/StdChannels.3 +++ b/doc/StdChannels.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "Standard Channels" 3 7.5 Tcl "Tcl Library Procedures" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/StrMatch.3 b/doc/StrMatch.3 index 5adaf6e..f9c2be3 100644 --- a/doc/StrMatch.3 +++ b/doc/StrMatch.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_StringMatch 3 8.5 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_StringMatch, Tcl_StringCaseMatch \- test whether a string matches a pattern diff --git a/doc/StringObj.3 b/doc/StringObj.3 index e451c61..47f597c 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl objects as strings diff --git a/doc/SubstObj.3 b/doc/SubstObj.3 index 786b595..ba0ee7c 100644 --- a/doc/SubstObj.3 +++ b/doc/SubstObj.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_SubstObj 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_SubstObj \- perform substitutions on Tcl objects diff --git a/doc/TCL_MEM_DEBUG.3 b/doc/TCL_MEM_DEBUG.3 index 5a3e08a..e3a6809 100644 --- a/doc/TCL_MEM_DEBUG.3 +++ b/doc/TCL_MEM_DEBUG.3 @@ -3,8 +3,8 @@ '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH TCL_MEM_DEBUG 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME TCL_MEM_DEBUG \- Compile-time flag to enable Tcl memory debugging diff --git a/doc/Tcl.n b/doc/Tcl.n index 8b5b501..980d81f 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl n "8.5" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME Tcl \- Tool Command Language diff --git a/doc/Tcl_Main.3 b/doc/Tcl_Main.3 index 54b2e84..4b4ceb7 100644 --- a/doc/Tcl_Main.3 +++ b/doc/Tcl_Main.3 @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications diff --git a/doc/Thread.3 b/doc/Thread.3 index 80d34ad..5517a41 100644 --- a/doc/Thread.3 +++ b/doc/Thread.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Threads 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support diff --git a/doc/ToUpper.3 b/doc/ToUpper.3 index d6b3006..587e76b 100644 --- a/doc/ToUpper.3 +++ b/doc/ToUpper.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_UtfToUpper 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_UtfToLower, Tcl_UtfToTitle \- routines for manipulating the case of Unicode characters and UTF-8 strings diff --git a/doc/TraceCmd.3 b/doc/TraceCmd.3 index 020f1ca..b15face 100644 --- a/doc/TraceCmd.3 +++ b/doc/TraceCmd.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_TraceCommand 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index f80d86f..97af6d4 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable diff --git a/doc/Translate.3 b/doc/Translate.3 index d434cda..7b8acc9 100644 --- a/doc/Translate.3 +++ b/doc/Translate.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_TranslateFileName 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3 index 6029b2d..ea6fc5b 100644 --- a/doc/UniCharIsAlpha.3 +++ b/doc/UniCharIsAlpha.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_UniCharIsAlpha 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UniCharIsAlnum, Tcl_UniCharIsAlpha, Tcl_UniCharIsControl, Tcl_UniCharIsDigit, Tcl_UniCharIsGraph, Tcl_UniCharIsLower, Tcl_UniCharIsPrint, Tcl_UniCharIsPunct, Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar \- routines for classification of Tcl_UniChar characters diff --git a/doc/UpVar.3 b/doc/UpVar.3 index f1e6fe4..8e7ba08 100644 --- a/doc/UpVar.3 +++ b/doc/UpVar.3 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UpVar, Tcl_UpVar2 \- link one variable to another diff --git a/doc/Utf.3 b/doc/Utf.3 index 8e39fef..cfd587c 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Utf 3 "8.1" Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings diff --git a/doc/WrongNumArgs.3 b/doc/WrongNumArgs.3 index 2175858..f24cba5 100644 --- a/doc/WrongNumArgs.3 +++ b/doc/WrongNumArgs.3 @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures" +.so man.macros .BS .SH NAME Tcl_WrongNumArgs \- generate standard error message for wrong number of arguments diff --git a/doc/after.n b/doc/after.n index 21961d3..2a5d005 100644 --- a/doc/after.n +++ b/doc/after.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH after n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/append.n b/doc/append.n index dc9adbe..b0b8216 100644 --- a/doc/append.n +++ b/doc/append.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH append n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/apply.n b/doc/apply.n index 8a38aac..003621e 100644 --- a/doc/apply.n +++ b/doc/apply.n @@ -2,8 +2,8 @@ '\" Copyright (c) 2006 Miguel Sofer '\" Copyright (c) 2006 Donal K. Fellows '\" -.so man.macros .TH apply n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/array.n b/doc/array.n index e112c23..056992c 100644 --- a/doc/array.n +++ b/doc/array.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH array n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/bgerror.n b/doc/bgerror.n index cb91351..da854f2 100644 --- a/doc/bgerror.n +++ b/doc/bgerror.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH bgerror n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/binary.n b/doc/binary.n index 6b2150e..ff800f0 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH binary n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/break.n b/doc/break.n index ed09c03..e364204 100644 --- a/doc/break.n +++ b/doc/break.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH break n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/case.n b/doc/case.n index 0155a61..54d5bf4 100644 --- a/doc/case.n +++ b/doc/case.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH case n 7.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/catch.n b/doc/catch.n index 0e2ec04..ada0fe7 100644 --- a/doc/catch.n +++ b/doc/catch.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH catch n "8.5" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/cd.n b/doc/cd.n index 191fb62..d6b0aa0 100644 --- a/doc/cd.n +++ b/doc/cd.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH cd n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/chan.n b/doc/chan.n index f5d3d54..e8356e2 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -3,8 +3,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -.so man.macros .TH chan n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/clock.n b/doc/clock.n index 600722b..7c4c3df 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -2,8 +2,8 @@ '\" Generated from file './doc/clock.dt' by tcllib/doctools with format 'nroff' '\" Copyright (c) 2004 Kevin B. Kenny . All rights reserved. '\" -.so man.macros .TH "clock" n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME clock \- Obtain and manipulate dates and times diff --git a/doc/close.n b/doc/close.n index 4ef3c7d..639fddb 100644 --- a/doc/close.n +++ b/doc/close.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH close n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/concat.n b/doc/concat.n index f7317c4..252f52c 100644 --- a/doc/concat.n +++ b/doc/concat.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH concat n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/continue.n b/doc/continue.n index 221b7e2..728b9dc 100644 --- a/doc/continue.n +++ b/doc/continue.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH continue n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/dde.n b/doc/dde.n index 2e3c883..06de949 100644 --- a/doc/dde.n +++ b/doc/dde.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH dde n 1.3 dde "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/dict.n b/doc/dict.n index 28c4f7c..4a107d3 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH dict n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/encoding.n b/doc/encoding.n index f8f3d54..1c0bfa9 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH encoding n "8.1" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME encoding \- Manipulate encodings diff --git a/doc/eof.n b/doc/eof.n index 14cf8f9..f382fdf 100644 --- a/doc/eof.n +++ b/doc/eof.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH eof n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/error.n b/doc/error.n index 77391e5..ff01a6f 100644 --- a/doc/error.n +++ b/doc/error.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH error n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/eval.n b/doc/eval.n index a642d23..d68db95 100644 --- a/doc/eval.n +++ b/doc/eval.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH eval n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/exec.n b/doc/exec.n index fd4e9cf..3857a71 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH exec n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/exit.n b/doc/exit.n index eccd635..cce449f 100644 --- a/doc/exit.n +++ b/doc/exit.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH exit n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/expr.n b/doc/expr.n index dbc9026..6c83504 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH expr n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fblocked.n b/doc/fblocked.n index d8e8af7..fbe244f 100644 --- a/doc/fblocked.n +++ b/doc/fblocked.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 0763232..51778c3 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fconfigure n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fcopy.n b/doc/fcopy.n index d583cf0..290ec49 100644 --- a/doc/fcopy.n +++ b/doc/fcopy.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fcopy n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/file.n b/doc/file.n index b62d252..36eae79 100644 --- a/doc/file.n +++ b/doc/file.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/fileevent.n b/doc/fileevent.n index eb555f5..c1cea3a 100644 --- a/doc/fileevent.n +++ b/doc/fileevent.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/filename.n b/doc/filename.n index 1fe22f0..e5f939b 100644 --- a/doc/filename.n +++ b/doc/filename.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH filename n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/flush.n b/doc/flush.n index 1c79ea0..4a9ef15 100644 --- a/doc/flush.n +++ b/doc/flush.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH flush n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/for.n b/doc/for.n index 033903f..9773677 100644 --- a/doc/for.n +++ b/doc/for.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH for n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/foreach.n b/doc/foreach.n index 654c0cf..1a3b2b6 100644 --- a/doc/foreach.n +++ b/doc/foreach.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH foreach n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/format.n b/doc/format.n index f842f16..8456e28 100644 --- a/doc/format.n +++ b/doc/format.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH format n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/gets.n b/doc/gets.n index bed7e32..fd1b87a 100644 --- a/doc/gets.n +++ b/doc/gets.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH gets n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/glob.n b/doc/glob.n index c257983..701a623 100644 --- a/doc/glob.n +++ b/doc/glob.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH glob n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/global.n b/doc/global.n index c9d7a36..34db146 100644 --- a/doc/global.n +++ b/doc/global.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH global n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/history.n b/doc/history.n index ba507b4..e1f9781 100644 --- a/doc/history.n +++ b/doc/history.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH history n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/http.n b/doc/http.n index 24b5f6a..8aeb286 100644 --- a/doc/http.n +++ b/doc/http.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "http" n 2.7 http "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/if.n b/doc/if.n index d84cf08..085d3fe 100644 --- a/doc/if.n +++ b/doc/if.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH if n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/incr.n b/doc/incr.n index 72b3ff8..46c80a1 100644 --- a/doc/incr.n +++ b/doc/incr.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH incr n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/info.n b/doc/info.n index fae0d43..8008c57 100644 --- a/doc/info.n +++ b/doc/info.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/interp.n b/doc/interp.n index c753ee9..d9ce0c4 100644 --- a/doc/interp.n +++ b/doc/interp.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH interp n 7.6 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/join.n b/doc/join.n index 582b730..270f9f3 100644 --- a/doc/join.n +++ b/doc/join.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH join n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lappend.n b/doc/lappend.n index dbed3bb..5619272 100644 --- a/doc/lappend.n +++ b/doc/lappend.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lappend n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lassign.n b/doc/lassign.n index b791feb..7b3bcdc 100644 --- a/doc/lassign.n +++ b/doc/lassign.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lassign n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/library.n b/doc/library.n index f29af8b..e9f81ac 100644 --- a/doc/library.n +++ b/doc/library.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH library n "8.0" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME auto_execok, auto_import, auto_load, auto_mkindex, auto_mkindex_old, auto_qualify, auto_reset, tcl_findLibrary, parray, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore \- standard library of Tcl procedures diff --git a/doc/lindex.n b/doc/lindex.n index f0417ac..1482807 100644 --- a/doc/lindex.n +++ b/doc/lindex.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lindex n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/linsert.n b/doc/linsert.n index 9f37fcd..d73a05a 100644 --- a/doc/linsert.n +++ b/doc/linsert.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH linsert n 8.2 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/list.n b/doc/list.n index 2bcdafb..993987e 100644 --- a/doc/list.n +++ b/doc/list.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH list n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/llength.n b/doc/llength.n index 627800f..d3d7e14 100644 --- a/doc/llength.n +++ b/doc/llength.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH llength n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/load.n b/doc/load.n index e5501f6..e028642 100644 --- a/doc/load.n +++ b/doc/load.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lrange.n b/doc/lrange.n index 34f0150..66345c6 100644 --- a/doc/lrange.n +++ b/doc/lrange.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lrange n 7.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lrepeat.n b/doc/lrepeat.n index ac78690..848255b 100644 --- a/doc/lrepeat.n +++ b/doc/lrepeat.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lrepeat n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lreplace.n b/doc/lreplace.n index 2cd79d8..18c6490 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lreverse.n b/doc/lreverse.n index da5e489..48886be 100644 --- a/doc/lreverse.n +++ b/doc/lreverse.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lreverse n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lsearch.n b/doc/lsearch.n index b046ba2..f7c4976 100644 --- a/doc/lsearch.n +++ b/doc/lsearch.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lsearch n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lset.n b/doc/lset.n index 5efcbae..c191ebf 100644 --- a/doc/lset.n +++ b/doc/lset.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lset n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/lsort.n b/doc/lsort.n index 1726e92..cf0f0ca 100644 --- a/doc/lsort.n +++ b/doc/lsort.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH lsort n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/mathfunc.n b/doc/mathfunc.n index 4ba25e4..c5ef6e0 100644 --- a/doc/mathfunc.n +++ b/doc/mathfunc.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH mathfunc n 8.5 Tcl "Tcl Mathematical Functions" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/mathop.n b/doc/mathop.n index 5757f87..1ddd86e 100644 --- a/doc/mathop.n +++ b/doc/mathop.n @@ -4,8 +4,8 @@ .\" See the file "license.terms" for information on usage and redistribution .\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .\" -.so man.macros .TH mathop n 8.5 Tcl "Tcl Mathematical Operator Commands" +.so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/memory.n b/doc/memory.n index 4ff681d..92e67c8 100644 --- a/doc/memory.n +++ b/doc/memory.n @@ -3,8 +3,8 @@ '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH memory n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME memory \- Control Tcl memory debugging capabilities diff --git a/doc/msgcat.n b/doc/msgcat.n index bfd94ae..bae6dbe 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/namespace.n b/doc/namespace.n index 8b26786..866db1b 100644 --- a/doc/namespace.n +++ b/doc/namespace.n @@ -7,8 +7,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH namespace n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/open.n b/doc/open.n index 88283bb..b888126 100644 --- a/doc/open.n +++ b/doc/open.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH open n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/package.n b/doc/package.n index d4fe657..dd1fc36 100644 --- a/doc/package.n +++ b/doc/package.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH package n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/packagens.n b/doc/packagens.n index 1220b20..1152314 100644 --- a/doc/packagens.n +++ b/doc/packagens.n @@ -2,8 +2,8 @@ '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" -.so man.macros .TH pkg::create n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/pid.n b/doc/pid.n index 97a42a7..a4df2f3 100644 --- a/doc/pid.n +++ b/doc/pid.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH pid n 7.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n index 5895407..d5cab7b 100644 --- a/doc/pkgMkIndex.n +++ b/doc/pkgMkIndex.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/platform.n b/doc/platform.n index 053448d..7233215 100644 --- a/doc/platform.n +++ b/doc/platform.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "platform" n 1.0.4 platform "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/platform_shell.n b/doc/platform_shell.n index eef4d4e..64a2e46 100644 --- a/doc/platform_shell.n +++ b/doc/platform_shell.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "platform::shell" n 1.1.4 platform::shell "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/proc.n b/doc/proc.n index 4525207..0f8cc04 100644 --- a/doc/proc.n +++ b/doc/proc.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH proc n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/puts.n b/doc/puts.n index 5cd8721..7dbfa5e 100644 --- a/doc/puts.n +++ b/doc/puts.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH puts n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/pwd.n b/doc/pwd.n index e63b815..423a263 100644 --- a/doc/pwd.n +++ b/doc/pwd.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH pwd n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/re_syntax.n b/doc/re_syntax.n index 8701641..a74746a 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" +.so man.macros .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions diff --git a/doc/read.n b/doc/read.n index 5398b08..6e614f2 100644 --- a/doc/read.n +++ b/doc/read.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH read n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/refchan.n b/doc/refchan.n index 577c78a..d27e464 100644 --- a/doc/refchan.n +++ b/doc/refchan.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH refchan n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/regexp.n b/doc/regexp.n index 100f0d8..db53897 100644 --- a/doc/regexp.n +++ b/doc/regexp.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH regexp n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/registry.n b/doc/registry.n index e4371e6..927af16 100644 --- a/doc/registry.n +++ b/doc/registry.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH registry n 1.1 registry "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/regsub.n b/doc/regsub.n index 5adfd61..90e7d88 100644 --- a/doc/regsub.n +++ b/doc/regsub.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH regsub n 8.3 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/rename.n b/doc/rename.n index c207523..0633710 100644 --- a/doc/rename.n +++ b/doc/rename.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH rename n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/return.n b/doc/return.n index b08de4a..b7f928a 100644 --- a/doc/return.n +++ b/doc/return.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH return n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/safe.n b/doc/safe.n index 590f2c6..9ecc9a0 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/scan.n b/doc/scan.n index 4ee9a59..7a84499 100644 --- a/doc/scan.n +++ b/doc/scan.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH scan n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/seek.n b/doc/seek.n index d4ce9b7..9214f8e 100644 --- a/doc/seek.n +++ b/doc/seek.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH seek n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/set.n b/doc/set.n index fb8dfac..5e13713 100644 --- a/doc/set.n +++ b/doc/set.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH set n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/socket.n b/doc/socket.n index c020839..7050429 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH socket n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/source.n b/doc/source.n index 69d383e..9f0fd6f 100644 --- a/doc/source.n +++ b/doc/source.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH source n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/split.n b/doc/split.n index c289be0..70bf129 100644 --- a/doc/split.n +++ b/doc/split.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH split n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/string.n b/doc/string.n index e74b8a2..f39d57c 100644 --- a/doc/string.n +++ b/doc/string.n @@ -5,8 +5,8 @@ .\" See the file "license.terms" for information on usage and redistribution .\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .\" -.so man.macros .TH string n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS .\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/subst.n b/doc/subst.n index 5a162c4..07f0933 100644 --- a/doc/subst.n +++ b/doc/subst.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH subst n 7.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/switch.n b/doc/switch.n index defa849..1c4dd74 100644 --- a/doc/switch.n +++ b/doc/switch.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH switch n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tclsh.1 b/doc/tclsh.1 index d9fe95e..d40ac55 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tcltest.n b/doc/tcltest.n index 9ac8f66..399a673 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -8,8 +8,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tclvars.n b/doc/tclvars.n index 885de34..b3e1bee 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tell.n b/doc/tell.n index 282cae5..c3f8db8 100644 --- a/doc/tell.n +++ b/doc/tell.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tell n 8.1 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/time.n b/doc/time.n index bdd0786..b734c6a 100644 --- a/doc/time.n +++ b/doc/time.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH time n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/tm.n b/doc/tm.n index aef06dd..edd6cff 100644 --- a/doc/tm.n +++ b/doc/tm.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH tm n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/trace.n b/doc/trace.n index c928856..97fbdba 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH trace n "8.4" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/unknown.n b/doc/unknown.n index c258daa..15f903d 100644 --- a/doc/unknown.n +++ b/doc/unknown.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH unknown n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/unload.n b/doc/unload.n index f060cd6..82c4f4a 100644 --- a/doc/unload.n +++ b/doc/unload.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH unload n 8.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/unset.n b/doc/unset.n index 29d7e7c..09f2ce6 100644 --- a/doc/unset.n +++ b/doc/unset.n @@ -6,8 +6,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH unset n 8.4 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/update.n b/doc/update.n index 555766c..745c5fd 100644 --- a/doc/update.n +++ b/doc/update.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH update n 7.5 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/uplevel.n b/doc/uplevel.n index c8ef0ff..074f822 100644 --- a/doc/uplevel.n +++ b/doc/uplevel.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH uplevel n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/upvar.n b/doc/upvar.n index a255485..91db24a 100644 --- a/doc/upvar.n +++ b/doc/upvar.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH upvar n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/variable.n b/doc/variable.n index 3a60485..6400c23 100644 --- a/doc/variable.n +++ b/doc/variable.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH variable n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/vwait.n b/doc/vwait.n index e7289e1..f516d46 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -4,8 +4,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH vwait n 8.0 Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/while.n b/doc/while.n index 33aa415..da49853 100644 --- a/doc/while.n +++ b/doc/while.n @@ -5,8 +5,8 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.so man.macros .TH while n "" Tcl "Tcl Built-In Commands" +.so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -- cgit v0.12 From 498d86acd9ca0d9d7bc004c1c14c19dc332b77a3 Mon Sep 17 00:00:00 2001 From: max Date: Tue, 12 Nov 2013 11:45:04 +0000 Subject: Fix [5425f2c082]: [fconfigure -error] breaks the background processing of a pending [socket -async]. --- tests/socket.test | 28 ++++++++++++++++++++++++++++ unix/tclUnixSock.c | 19 ++++++++++++++----- 2 files changed, 42 insertions(+), 5 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index 5542c09..f7e817b 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1841,6 +1841,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ after cancel $after close $client close $server + unset x } -result {{} bye} test socket-14.5 {[socket -async] which fails before any connect() can be made} \ -constraints [list socket supported_any] \ @@ -1850,6 +1851,33 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} +test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ + -constraints [list socket supported_any] \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + foreach _ {1 2} { + lappend x [lindex [fconfigure $client -sockname] 0] + lappend x [fconfigure $client -error] + update + } + lappend x [gets $client] + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result [list ::1 "connection refused" 127.0.0.1 "" bye] + ::tcltest::cleanupTests flush stdout return diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index a6360c2..7ef28d8 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -737,7 +737,10 @@ TcpGetOptionProc( if (statePtr->status == 0) { ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &err, &optlen); + (char *) &err, &optlen); + if (statePtr->flags & TCP_ASYNC_CONNECT) { + statePtr->status = err; + } if (ret < 0) { err = errno; } @@ -1054,12 +1057,17 @@ CreateClientSocket( */ optlen = sizeof(int); - getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR, - (char *) &status, &optlen); - state->status = status; + + if (state->status == 0) { + getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR, + (char *) &status, &optlen); + state->status = status; + } else { + status = state->status; + state->status = 0; + } } if (status == 0) { - CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT); goto out; } } @@ -1067,6 +1075,7 @@ CreateClientSocket( out: + CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT); if (async_callback) { /* * An asynchonous connection has finally succeeded or failed. -- cgit v0.12 From 68a9570548ce0893129ab3c5a19b38bfd3eb99fb Mon Sep 17 00:00:00 2001 From: max Date: Tue, 12 Nov 2013 13:12:21 +0000 Subject: socket-14.6 only makes sense where both, IPv4 and IPv6 are supported. --- tests/socket.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/socket.test b/tests/socket.test index f7e817b..51219e6 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1852,7 +1852,7 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ - -constraints [list socket supported_any] \ + -constraints [list socket supported_inet supported_inet6] \ -setup { proc accept {s a p} { puts $s bye -- cgit v0.12 From 729e8b44d736e3ca4af72adb070a8b89cf6fb94e Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 12 Nov 2013 15:43:55 +0000 Subject: [528717] Slight rewording to clarify what the evaluation steps are. --- doc/Tcl.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index be0b24d..e868388 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -28,7 +28,7 @@ First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. -The first word is used to locate a command procedure to +Secondly, first word is used to locate a command procedure to carry out the command, then all of the words of the command are passed to the command procedure. The command procedure is free to interpret each of its words -- cgit v0.12 From dffcad90e2d661e520f735c824ddff5f1d630ddd Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 12 Nov 2013 15:47:21 +0000 Subject: Grammar check... --- doc/Tcl.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index e868388..8b17f93 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -28,7 +28,7 @@ First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. -Secondly, first word is used to locate a command procedure to +Secondly, the first word is used to locate a command procedure to carry out the command, then all of the words of the command are passed to the command procedure. The command procedure is free to interpret each of its words -- cgit v0.12 From 1cc85db9fe34f20eb5109b58d4d5bd0d65140129 Mon Sep 17 00:00:00 2001 From: max Date: Fri, 15 Nov 2013 16:13:53 +0000 Subject: Don't leak getaddrinfo() results --- win/tclWinSock.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index f4d5a90..84a33ea 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1359,10 +1359,10 @@ CreateSocket( } error: - if (addrlist == NULL) { + if (addrlist != NULL) { freeaddrinfo(addrlist); } - if (myaddrlist == NULL) { + if (myaddrlist != NULL) { freeaddrinfo(myaddrlist); } -- cgit v0.12 From 4638909b08044425c05cc87efd7713ad9c6be4de Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 16 Nov 2013 20:33:17 +0000 Subject: Map WSAEWOULDBLOCK to EWOULDBLOCK. Suggested by Reinhard Max. --- win/tclWinConsole.c | 4 ++-- win/tclWinError.c | 2 +- win/tclWinPipe.c | 6 +++--- win/tclWinSerial.c | 4 ++-- win/tclWinSock.c | 6 +++--- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 65e4aed..0ec22c5 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -800,7 +800,7 @@ ConsoleOutputProc( * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error; } @@ -1079,7 +1079,7 @@ WaitForRead( * is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; return -1; } diff --git a/win/tclWinError.c b/win/tclWinError.c index 49eeed3..4d3250d 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -292,7 +292,7 @@ static const unsigned char errorTable[] = { */ static const unsigned char wsaErrorTable[] = { - EAGAIN, /* WSAEWOULDBLOCK */ + EWOULDBLOCK, /* WSAEWOULDBLOCK */ EINPROGRESS, /* WSAEINPROGRESS */ EALREADY, /* WSAEALREADY */ ENOTSOCK, /* WSAENOTSOCK */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 13caba9..77fc776 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1884,7 +1884,7 @@ PipeClose2Proc( SetEvent(pipePtr->stopWriter); if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) { - return EAGAIN; + return EWOULDBLOCK; } } else { @@ -2161,7 +2161,7 @@ PipeOutputProc( * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error; } @@ -2712,7 +2712,7 @@ WaitForRead( * is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; return -1; } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 75d5ffc..b9c9a9f 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -932,7 +932,7 @@ SerialInputProc( bufSize = cStat.cbInQue; } } else { - errno = *errorCode = EAGAIN; + errno = *errorCode = EWOULDBLOCK; return -1; } } else { @@ -1034,7 +1034,7 @@ SerialOutputProc( * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error1; } diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 84a33ea..00df85f 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1318,7 +1318,7 @@ CreateSocket( if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); - if (Tcl_GetErrno() != EAGAIN) { + if (Tcl_GetErrno() != EWOULDBLOCK) { goto looperror; } @@ -1441,7 +1441,7 @@ WaitForSocketEvent( } else if (infoPtr->readyEvents & events) { break; } else if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EAGAIN; + *errorCodePtr = EWOULDBLOCK; result = 0; break; } @@ -1926,7 +1926,7 @@ TcpOutputProc( if (error == WSAEWOULDBLOCK) { infoPtr->readyEvents &= ~(FD_WRITE); if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EAGAIN; + *errorCodePtr = EWOULDBLOCK; bytesWritten = -1; break; } -- cgit v0.12 From 0507a702179a76c4f004e5321dc5f5daa0604080 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 16 Nov 2013 21:05:38 +0000 Subject: Fix [e832d2b08]: unnecessary code in Tcl_SetMaxBlockTime. --- generic/tclNotify.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclNotify.c b/generic/tclNotify.c index f85fb7a..b45539a 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -820,11 +820,7 @@ Tcl_SetMaxBlockTime( */ if (!tsdPtr->inTraversal) { - if (tsdPtr->blockTimeSet) { - Tcl_SetTimer(&tsdPtr->blockTime); - } else { - Tcl_SetTimer(NULL); - } + Tcl_SetTimer(&tsdPtr->blockTime); } } -- cgit v0.12 From 643e5bc24ed7dd6a21ca1a562693d0d9ce4f2651 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Nov 2013 11:00:51 +0000 Subject: Eliminate some redundant Tcl_GetErrno() calls. --- generic/tclIOGT.c | 5 +++-- win/tclWinSock.c | 5 +++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index bfe6a10..825f408 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -661,12 +661,13 @@ TransformInputProc( * had some data before we report that instead of the request to * re-try. */ + int error = Tcl_GetErrno(); - if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { + if ((error == EAGAIN) && (gotBytes > 0)) { return gotBytes; } - *errorCodePtr = Tcl_GetErrno(); + *errorCodePtr = error; return -1; } else if (read == 0) { /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 00df85f..5ac8f47 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1317,8 +1317,9 @@ CreateSocket( if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - if (Tcl_GetErrno() != EWOULDBLOCK) { + DWORD error = (DWORD) WSAGetLastError(); + if (error != WSAEWOULDBLOCK) { + TclWinConvertError(error); goto looperror; } -- cgit v0.12 From 5a8572af1f72090ba2d223c007d9803397958c14 Mon Sep 17 00:00:00 2001 From: max Date: Mon, 18 Nov 2013 12:35:58 +0000 Subject: To prepare for completion of the [socket -async] implementation on Windows [13d3af3ad5]: * Move the server code from CreateSocket to Tcl_OpenTcpServer. * Rename CreateSocket to CreateClientSocket. * Unify the naming convention of socket channels with Unix (sock + hex representation of the state/info structure). --- win/tclWinSock.c | 368 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 203 insertions(+), 165 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 5ac8f47..bd993fa 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -74,6 +74,10 @@ #undef getsockopt #undef setsockopt +/* "sock" + a pointer in hex + \0 */ +#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) +#define SOCK_TEMPLATE "sock%lx" + /* * The following variable is used to tell whether this module has been * initialized. If 1, initialization of sockets was successful, if -1 then @@ -210,8 +214,8 @@ static WNDCLASS windowClass; * Static functions defined in this file. */ -static SocketInfo * CreateSocket(Tcl_Interp *interp, int port, - const char *host, int server, const char *myaddr, +static SocketInfo * CreateClientSocket(Tcl_Interp *interp, int port, + const char *host, const char *myaddr, int myport, int async); static void InitSockets(void); static SocketInfo * NewSocketInfo(SOCKET socket); @@ -1101,10 +1105,10 @@ NewSocketInfo( /* *---------------------------------------------------------------------- * - * CreateSocket -- + * CreateClientSocket -- * - * This function opens a new socket and initializes the SocketInfo - * structure. + * This function opens a new client socket and initializes the + * SocketInfo structure. * * Results: * Returns a new SocketInfo, or NULL with an error in interp. @@ -1116,12 +1120,10 @@ NewSocketInfo( */ static SocketInfo * -CreateSocket( +CreateClientSocket( Tcl_Interp *interp, /* For error reporting; can be NULL. */ int port, /* Port number to open. */ const char *host, /* Name of host on which to open port. */ - int server, /* 1 if socket should be a server socket, else - * 0 for a client socket. */ const char *myaddr, /* Optional client-side address */ int myport, /* Optional client-side port */ int async) /* If nonzero, connect client socket @@ -1155,7 +1157,7 @@ CreateSocket( * Construct the addresses for each end of the socket. */ - if (!TclCreateSocketAddress(interp, &addrlist, host, port, server, + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)) { goto error; } @@ -1164,10 +1166,20 @@ CreateSocket( goto error; } - if (server) { + for (addrPtr = addrlist; addrPtr != NULL; + addrPtr = addrPtr->ai_next) { + for (myaddrPtr = myaddrlist; myaddrPtr != NULL; + myaddrPtr = myaddrPtr->ai_next) { + /* + * No need to try combinations of local and remote addresses + * of different families. + */ - for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { - sock = socket(addrPtr->ai_family, SOCK_STREAM, 0); + if (myaddrPtr->ai_family != addrPtr->ai_family) { + continue; + } + + sock = socket(myaddrPtr->ai_family, SOCK_STREAM, 0); if (sock == INVALID_SOCKET) { TclWinConvertError((DWORD) WSAGetLastError()); continue; @@ -1187,158 +1199,52 @@ CreateSocket( TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); /* - * Make sure we use the same port when opening two server sockets - * for IPv4 and IPv6. - * - * As sockaddr_in6 uses the same offset and size for the port - * member as sockaddr_in, we can handle both through the IPv4 API. + * Try to bind to a local port. */ - if (port == 0 && chosenport != 0) { - ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = - htons(chosenport); + if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen) + == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + goto looperror; } - /* - * Bind to the specified port. Note that we must not call - * setsockopt with SO_REUSEADDR because Microsoft allows addresses - * to be reused even if they are still in use. - * - * Bind should not be affected by the socket having already been - * set into nonblocking mode. If there is trouble, this is one - * place to look for bugs. + * Set the socket into nonblocking mode if the connect should + * be done in the background. */ - - if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { + if (async && ioctlsocket(sock, (long) FIONBIO, &flag) + == SOCKET_ERROR) { TclWinConvertError((DWORD) WSAGetLastError()); - closesocket(sock); - continue; - } - if (port == 0 && chosenport == 0) { - address sockname; - socklen_t namelen = sizeof(sockname); - - /* - * Synchronize port numbers when binding to port 0 of multiple - * addresses. - */ - - if (getsockname(sock, &sockname.sa, &namelen) >= 0) { - chosenport = ntohs(sockname.sa4.sin_port); - } + goto looperror; } /* - * Set the maximum number of pending connect requests to the max - * value allowed on each platform (Win32 and Win32s may be - * different, and there may be differences between TCP/IP stacks). + * Attempt to connect to the remote socket. */ - if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - closesocket(sock); - continue; - } - - if (infoPtr == NULL) { - /* - * Add this socket to the global list of sockets. - */ - - infoPtr = NewSocketInfo(sock); - - /* - * Set up the select mask for connection request events. - */ - - infoPtr->selectEvents = FD_ACCEPT; - infoPtr->watchEvents |= FD_ACCEPT; - - } else { - AddSocketInfoFd( infoPtr, sock ); - } - } - } else { - for (addrPtr = addrlist; addrPtr != NULL; - addrPtr = addrPtr->ai_next) { - for (myaddrPtr = myaddrlist; myaddrPtr != NULL; - myaddrPtr = myaddrPtr->ai_next) { - /* - * No need to try combinations of local and remote addresses - * of different families. - */ - - if (myaddrPtr->ai_family != addrPtr->ai_family) { - continue; - } - - sock = socket(myaddrPtr->ai_family, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); - continue; - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers((void *) sock, TCP_BUFFER_SIZE); - - /* - * Try to bind to a local port. - */ - - if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen) - == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); + if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) + == SOCKET_ERROR) { + DWORD error = (DWORD) WSAGetLastError(); + if (error != WSAEWOULDBLOCK) { + TclWinConvertError(error); goto looperror; } + /* - * Set the socket into nonblocking mode if the connect should - * be done in the background. + * The connection is progressing in the background. */ - if (async && ioctlsocket(sock, (long) FIONBIO, &flag) - == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - goto looperror; - } - - /* - * Attempt to connect to the remote socket. - */ - - if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { - DWORD error = (DWORD) WSAGetLastError(); - if (error != WSAEWOULDBLOCK) { - TclWinConvertError(error); - goto looperror; - } - - /* - * The connection is progressing in the background. - */ - asyncConnect = 1; - } - goto connected; - - looperror: - if (sock != INVALID_SOCKET) { - closesocket(sock); - sock = INVALID_SOCKET; - } + asyncConnect = 1; + } + goto connected; + + looperror: + if (sock != INVALID_SOCKET) { + closesocket(sock); + sock = INVALID_SOCKET; } } - goto error; + } + goto error; connected: /* @@ -1357,7 +1263,6 @@ CreateSocket( infoPtr->flags |= SOCKET_ASYNC_CONNECT; infoPtr->selectEvents |= FD_CONNECT; } - } error: if (addrlist != NULL) { @@ -1496,12 +1401,12 @@ Tcl_OpenTcpClient( * Create a new client socket and wrap it in a channel. */ - infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); + infoPtr = CreateClientSocket(interp, port, host, myaddr, myport, async); if (infoPtr == NULL) { return NULL; } - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); + sprintf(channelName, SOCK_TEMPLATE, infoPtr); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, infoPtr, (TCL_READABLE | TCL_WRITABLE)); @@ -1564,7 +1469,7 @@ Tcl_MakeTcpClientChannel( infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); + sprintf(channelName, SOCK_TEMPLATE, infoPtr); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, infoPtr, (TCL_READABLE | TCL_WRITABLE)); Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); @@ -1598,36 +1503,169 @@ Tcl_OpenTcpServer( * clients. */ ClientData acceptProcData) /* Data for the callback. */ { - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + SOCKET sock = INVALID_SOCKET; + unsigned short chosenport = 0; + struct addrinfo *addrPtr; /* Socket address to listen on. */ + SocketInfo *infoPtr = NULL; /* The returned value. */ + void *addrlist = NULL; + char channelName[SOCK_CHAN_LENGTH]; + u_long flag = 1; /* Indicates nonblocking mode. */ + const char *errorMsg = NULL; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Create a new client socket and wrap it in a channel. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0); - if (infoPtr == NULL) { + if (!SocketsEnabled()) { return NULL; } - infoPtr->acceptProc = acceptProc; - infoPtr->acceptProcData = acceptProcData; + /* + * Construct the addresses for each end of the socket. + */ - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 1, &errorMsg)) { + goto error; + } - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - infoPtr, 0); - if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") + for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { + sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, + addrPtr->ai_protocol); + if (sock == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ + + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); + + /* + * Make sure we use the same port when opening two server sockets + * for IPv4 and IPv6. + * + * As sockaddr_in6 uses the same offset and size for the port + * member as sockaddr_in, we can handle both through the IPv4 API. + */ + + if (port == 0 && chosenport != 0) { + ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = + htons(chosenport); + } + + /* + * Bind to the specified port. Note that we must not call + * setsockopt with SO_REUSEADDR because Microsoft allows addresses + * to be reused even if they are still in use. + * + * Bind should not be affected by the socket having already been + * set into nonblocking mode. If there is trouble, this is one + * place to look for bugs. + */ + + if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) + == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + closesocket(sock); + continue; + } + if (port == 0 && chosenport == 0) { + address sockname; + socklen_t namelen = sizeof(sockname); + + /* + * Synchronize port numbers when binding to port 0 of multiple + * addresses. + */ + + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { + chosenport = ntohs(sockname.sa4.sin_port); + } + } + + /* + * Set the maximum number of pending connect requests to the max + * value allowed on each platform (Win32 and Win32s may be + * different, and there may be differences between TCP/IP stacks). + */ + + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + closesocket(sock); + continue; + } + + if (infoPtr == NULL) { + /* + * Add this socket to the global list of sockets. + */ + infoPtr = NewSocketInfo(sock); + } else { + AddSocketInfoFd( infoPtr, sock ); + } + } + +error: + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } + + if (infoPtr != NULL) { + + infoPtr->acceptProc = acceptProc; + infoPtr->acceptProcData = acceptProcData; + sprintf(channelName, SOCK_TEMPLATE, infoPtr); + infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + infoPtr, 0); + /* + * Set up the select mask for connection request events. + */ + + infoPtr->selectEvents = FD_ACCEPT; + infoPtr->watchEvents |= FD_ACCEPT; + + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + ioctlsocket(sock, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); + if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close(NULL, infoPtr->channel); - return NULL; + Tcl_Close(NULL, infoPtr->channel); + return NULL; + } + return infoPtr->channel; } - return infoPtr->channel; + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); + } + + if (sock != INVALID_SOCKET) { + closesocket(sock); + } + return NULL; } /* @@ -1682,7 +1720,7 @@ TcpAccept( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) newInfoPtr); - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) newInfoPtr->sockets->fd); + sprintf(channelName, SOCK_TEMPLATE, newInfoPtr); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", -- cgit v0.12 From 9b104b7167d18325a28a7e1c3891ce8513249e23 Mon Sep 17 00:00:00 2001 From: max Date: Mon, 18 Nov 2013 13:32:30 +0000 Subject: Revert [3c0b0bbda6]. If this really is a problem, it needs to get fixed by other means than covering behind void pointers. --- generic/tclIOSock.c | 4 ++-- generic/tclInt.h | 5 +++-- unix/tclUnixSock.c | 5 ++--- win/tclWinSock.c | 5 ++--- 4 files changed, 9 insertions(+), 10 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 7d6c462..694501f 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -139,7 +139,7 @@ int TclCreateSocketAddress( Tcl_Interp *interp, /* Interpreter for querying * the desired socket family */ - void **addrlist, /* Socket address list */ + struct addrinfo **addrlist, /* Socket address list */ const char *host, /* Host. NULL implies INADDR_ANY */ int port, /* Port number */ int willBind, /* Is this an address to bind() to or @@ -213,7 +213,7 @@ TclCreateSocketAddress( hints.ai_flags |= AI_PASSIVE; } - result = getaddrinfo(native, portstring, &hints, (struct addrinfo **) addrlist); + result = getaddrinfo(native, portstring, &hints, addrlist); if (host != NULL) { Tcl_DStringFree(&ds); diff --git a/generic/tclInt.h b/generic/tclInt.h index feea6dd..5c8dbfd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3001,8 +3001,9 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, - void **addrlist, const char *host, int port, - int willBind, const char **errorMsgPtr); + struct addrinfo **addrlist, + const char *host, int port, int willBind, + const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 7ef28d8..49a6460 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1140,7 +1140,7 @@ Tcl_OpenTcpClient( { TcpState *state; const char *errorMsg = NULL; - void *addrlist = NULL, *myaddrlist = NULL; + struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; /* @@ -1285,8 +1285,7 @@ Tcl_OpenTcpServer( ClientData acceptProcData) /* Data for the callback. */ { int status = 0, sock = -1, reuseaddr = 1, chosenport = 0; - void *addrlist = NULL; - struct addrinfo *addrPtr; /* socket address */ + struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */ TcpState *statePtr = NULL; char channelName[SOCK_CHAN_LENGTH]; const char *errorMsg = NULL; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 5ac8f47..11b4162 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1131,10 +1131,9 @@ CreateSocket( int asyncConnect = 0; /* Will be 1 if async connect is in * progress. */ unsigned short chosenport = 0; - void *addrlist = NULL, *myaddrlist = NULL; - struct addrinfo *addrPtr; + struct addrinfo *addrlist = NULL, *addrPtr; /* Socket address to connect to. */ - struct addrinfo *myaddrPtr; + struct addrinfo *myaddrlist = NULL, *myaddrPtr; /* Socket address for our side. */ const char *errorMsg = NULL; SOCKET sock = INVALID_SOCKET; -- cgit v0.12 From 18b36e37e61e3936419af460b146f5c27e2d87f1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Nov 2013 08:23:05 +0000 Subject: Cygwin: Instead of checking whether the win32 part is configured properly, just configure it when needed. Always build the stub library first (and - on Cygwin - configure win32 properly just before building the stub library) --- unix/Makefile.in | 7 +++++-- unix/configure | 13 +++++++++---- unix/tcl.m4 | 11 +++++++++-- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 210d90b..70d98c1 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -546,7 +546,7 @@ SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \ all: binaries libraries doc -binaries: ${LIB_FILE} $(STUB_LIB_FILE) ${TCL_EXE} +binaries: ${LIB_FILE} ${TCL_EXE} libraries: @@ -554,11 +554,14 @@ doc: # The following target is configured by autoconf to generate either a shared # library or non-shared library for Tcl. -${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE} +${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} rm -f $@ @MAKE_LIB@ ${STUB_LIB_FILE}: ${STUB_LIB_OBJS} + @if test "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll"; then \ + (cd ${TOP_DIR}/win; ${MAKE} libtclstub${MAJOR_VERSION}${MINOR_VERSION}.a); \ + fi rm -f $@ @MAKE_STUB_LIB@ diff --git a/unix/configure b/unix/configure index d7bd53b..7f8922b 100755 --- a/unix/configure +++ b/unix/configure @@ -7007,10 +7007,15 @@ echo "$as_me: error: ${CC} is not a cygwin compiler." >&2;} echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2;} { (exit 1); exit 1; }; } fi - if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde13.dll" -a ! -f "../win/tk85.dll"; then - { { echo "$as_me:$LINENO: error: Please configure and make the ../win directory first." >&5 -echo "$as_me: error: Please configure and make the ../win directory first." >&2;} - { (exit 1); exit 1; }; } + do64bit_ok=yes + if test "x${SHARED_BUILD}" = "x1"; then + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + # The eval makes quoting arguments work. + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + then : + else + { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } + fi fi ;; dgux*) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index f484989..e9795b8 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1263,8 +1263,15 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "x${TCL_THREADS}" = "x0"; then AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads]) fi - if test "x${SHARED_BUILD}" = "x1" -a ! -f "../win/tcldde13.dll" -a ! -f "../win/tk85.dll"; then - AC_MSG_ERROR([Please configure and make the ../win directory first.]) + do64bit_ok=yes + if test "x${SHARED_BUILD}" = "x1"; then + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + # The eval makes quoting arguments work. + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + then : + else + { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } + fi fi ;; dgux*) -- cgit v0.12 From 015b2e6c6503106478c6dd3affa36035264c7482 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Nov 2013 09:09:42 +0000 Subject: Revert [5215b8740c] (Enh [2959069]), as it turns out that -fvisibility=hidden only affects definitions and not declarations. Therefore explicitely declaring each MODULE_SCOPE function as __attribute__((__visibility__("hidden")) is much better. Suggested by Stuart Cassoff (Thanks!). --- unix/configure | 83 +++------------------------------------------------------- unix/tcl.m4 | 30 +++++---------------- 2 files changed, 10 insertions(+), 103 deletions(-) diff --git a/unix/configure b/unix/configure index 06ff7a4..5009807 100755 --- a/unix/configure +++ b/unix/configure @@ -6490,80 +6490,6 @@ if test "${tcl_cv_cc_visibility_hidden+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else - if test "$SHARED_BUILD" = 1; then - - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror" - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -int -main () -{ -#if !defined(__GNUC__) || __GNUC__ < 4 -#error visibility hidden is not supported for this compiler -#endif - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 - (eval $ac_compile) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest.$ac_objext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_cc_visibility_hidden=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -tcl_cv_cc_visibility_hidden=no -fi -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext - CFLAGS=$hold_cflags - -else - - tcl_cv_cc_visibility_hidden=no - -fi - - -fi -echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5 -echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 - if test $tcl_cv_cc_visibility_hidden = yes; then - - CFLAGS="$CFLAGS -fvisibility=hidden" - -cat >>confdefs.h <<\_ACEOF -#define MODULE_SCOPE extern -_ACEOF - - -else - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ @@ -6614,7 +6540,10 @@ fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags - if test $tcl_cv_cc_visibility_hidden = yes; then +fi +echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5 +echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 + if test $tcl_cv_cc_visibility_hidden = yes; then cat >>confdefs.h <<\_ACEOF @@ -6630,9 +6559,6 @@ _ACEOF fi -fi - - # Step 0.d: Disable -rpath support? echo "$as_me:$LINENO: checking if rpath support is requested" >&5 @@ -8145,7 +8071,6 @@ cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE __private_extern__ _ACEOF - tcl_cv_cc_visibility_hidden=yes fi diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 194cf90..e3a0d15 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1045,34 +1045,17 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK([if compiler supports visibility "hidden"], tcl_cv_cc_visibility_hidden, [ - AS_IF([test "$SHARED_BUILD" = 1], [ - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror" - AC_TRY_COMPILE(,[#if !defined(__GNUC__) || __GNUC__ < 4 -#error visibility hidden is not supported for this compiler -#endif - ], tcl_cv_cc_visibility_hidden=yes, - tcl_cv_cc_visibility_hidden=no) - CFLAGS=$hold_cflags - ], [ - tcl_cv_cc_visibility_hidden=no - ]) - ]) - AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ - CFLAGS="$CFLAGS -fvisibility=hidden" - AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) - ], [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" AC_TRY_LINK([ extern __attribute__((__visibility__("hidden"))) void f(void); void f(void) {}], [f();], tcl_cv_cc_visibility_hidden=yes, tcl_cv_cc_visibility_hidden=no) - CFLAGS=$hold_cflags - AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ - AC_DEFINE(MODULE_SCOPE, - [extern __attribute__((__visibility__("hidden")))], - [Compiler support for module scope symbols]) - AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols]) - ]) + CFLAGS=$hold_cflags]) + AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ + AC_DEFINE(MODULE_SCOPE, + [extern __attribute__((__visibility__("hidden")))], + [Compiler support for module scope symbols]) + AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols]) ]) # Step 0.d: Disable -rpath support? @@ -1638,7 +1621,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [__private_extern__], [Compiler support for module scope symbols]) - tcl_cv_cc_visibility_hidden=yes ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" -- cgit v0.12 From 292a07fb1ed3636070430bbcda1f350629eba5e2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Nov 2013 11:50:03 +0000 Subject: Some formatting --- unix/tcl.m4 | 22 ++++++++++------------ win/tcl.m4 | 2 +- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 687866e..8c29334 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -111,9 +111,9 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then - ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" - break - fi + ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" + break + fi done fi ]) @@ -271,11 +271,10 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ # # Results: # -# Subst the following vars: +# Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE -# #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TCLCONFIG], [ @@ -439,11 +438,11 @@ AC_DEFUN([SC_LOAD_TKCONFIG], [ # extension can't assume that an executable Tcl shell exists at # build time. # -# Arguments +# Arguments: # none # -# Results -# Subst's the following values: +# Results: +# Substitutes the following vars: # TCLSH_PROG #------------------------------------------------------------------------ @@ -484,11 +483,11 @@ AC_DEFUN([SC_PROG_TCLSH], [ # when running tests from an extension build directory. It is not # correct to use the TCLSH_PROG in cases like this. # -# Arguments +# Arguments: # none # -# Results -# Subst's the following values: +# Results: +# Substitutes the following values: # BUILD_TCLSH #------------------------------------------------------------------------ @@ -790,7 +789,6 @@ AC_DEFUN([SC_ENABLE_SYMBOLS], [ # # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. -# #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_LANGINFO], [ diff --git a/win/tcl.m4 b/win/tcl.m4 index 52c001f..625c329 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -247,7 +247,7 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ # # Results: # -# Subst the following vars: +# Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE -- cgit v0.12 From df9709eef5f83bb6070ddb864f042cf9daff7d96 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 11:20:32 +0000 Subject: Bug Fix: EnvTraceProc() MUST always return NULL to indicate success. --- generic/tclEnv.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 6a21947..7c49d44 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -614,7 +614,7 @@ EnvTraceProc( const char *value = TclGetEnv(name2, &valueString); if (value == NULL) { - return (char *) "no such variable"; + return NULL; } Tcl_SetVar2(interp, name1, name2, value, 0); Tcl_DStringFree(&valueString); -- cgit v0.12 From 960a377fd1879082dbe0266533202d47cfdd5683 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 11:34:29 +0000 Subject: ... and don't break env-5.3 and env-5.5 test-cases. --- generic/tclEnv.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 7c49d44..8f51c1b 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -614,6 +614,7 @@ EnvTraceProc( const char *value = TclGetEnv(name2, &valueString); if (value == NULL) { + Tcl_UnsetVar2(interp, name1, name2, 0); return NULL; } Tcl_SetVar2(interp, name1, name2, value, 0); -- cgit v0.12 From 0be4102b2ac1be2e1d9d7960aa33308bdf206b02 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 12:58:35 +0000 Subject: Fix env-5.1 test-case on Cygwin (and probably other platforms which don't have iso8859-1 as system-encoding) --- tests/env.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/env.test b/tests/env.test index 8115652..83d99e0 100644 --- a/tests/env.test +++ b/tests/env.test @@ -218,8 +218,8 @@ test env-4.5 {unsetting international environment variables} -setup { unset env(\ua7) getenv } -constraints {exec} -cleanup { - encoding system $sysenc unset env(\ub6) + encoding system $sysenc } -result {\u00b6=\u00a7} test env-5.0 {corner cases - set a value, it should exist} -body { -- cgit v0.12 From c6900d988e939fafa1b1800ba27302c378d3e3c2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 14:38:08 +0000 Subject: Starting with Windows 8 DSK, GetVersionExA is deprecated --- win/tclWin32Dll.c | 6 +++--- win/tclWinInit.c | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 2cb7d7c..e5e5202 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -432,11 +432,11 @@ void TclWinInit( HINSTANCE hInst) /* Library instance handle. */ { - OSVERSIONINFO os; + OSVERSIONINFOW os; hInstance = hInst; - os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - GetVersionEx(&os); + os.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + GetVersionExW(&os); platformId = os.dwPlatformId; /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 5baf020..81d762f 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -563,7 +563,7 @@ TclpSetVariables( SYSTEM_INFO info; OemId oemId; } sys; - OSVERSIONINFOA osInfo; + OSVERSIONINFOW osInfo; Tcl_DString ds; WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; @@ -571,8 +571,8 @@ TclpSetVariables( Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - GetVersionExA(&osInfo); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + GetVersionExW(&osInfo); GetSystemInfo(&sys.info); -- cgit v0.12 From c555e477b12e11467a877024a205f39376477389 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Nov 2013 16:04:43 +0000 Subject: Safer clean-up of environment variables: Do removal after insertions -> tcltest 2.3.7 --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 13 ++++++++----- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 13 insertions(+), 10 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 60a9485..c99ad2a 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.7 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index c30d2e4..d066a1b 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.6 + variable Version 2.3.7 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -2495,16 +2495,19 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { set changedEnv {} set removedEnv {} foreach index [array names ::env] { - if {![info exists originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { + if {[info exists originalEnv($index)]} { if {$::env($index) != $originalEnv($index)} { lappend changedEnv $index set ::env($index) $originalEnv($index) } } } + foreach index [array names ::env] { + if {![info exists originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) + } + } foreach index [array names originalEnv] { if {![info exists ::env($index)]} { lappend removedEnv $index diff --git a/unix/Makefile.in b/unix/Makefile.in index 70d98c1..c7caf5b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -782,8 +782,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.6 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; + @echo "Installing package tcltest 2.3.7 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.7.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; diff --git a/win/Makefile.in b/win/Makefile.in index e0b2f26..b962fb4 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -651,8 +651,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.6 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; + @echo "Installing package tcltest 2.3.7 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.7.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 2254dff19ede852c343b6cc357a840917e55b112 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Nov 2013 09:18:04 +0000 Subject: The only relyable way of changing environment variables to uppercase (e.g. env(ComSpec) to env(COMSPEC)) is unsetting the old one first. Long-standing bug, exposed by [219226]. --- library/init.tcl | 72 ++++++++++++++++++++++----------------------- library/tcltest/tcltest.tcl | 11 ++----- 2 files changed, 39 insertions(+), 44 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index 6b49fdf..38c6bb3 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -77,7 +77,7 @@ namespace eval tcl { # TIP #255 min and max functions namespace eval mathfunc { proc min {args} { - if {[llength $args] == 0} { + if {![llength $args]} { return -code error \ "too few arguments to math function \"min\"" } @@ -88,12 +88,12 @@ namespace eval tcl { if {[catch {expr {double($arg)}} err]} { return -code error $err } - if {$arg < $val} { set val $arg } + if {$arg < $val} {set val $arg} } return $val } proc max {args} { - if {[llength $args] == 0} { + if {![llength $args]} { return -code error \ "too few arguments to math function \"max\"" } @@ -104,7 +104,7 @@ namespace eval tcl { if {[catch {expr {double($arg)}} err]} { return -code error $err } - if {$arg > $val} { set val $arg } + if {$arg > $val} {set val $arg} } return $val } @@ -130,9 +130,9 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { switch -- $u { COMSPEC - PATH { - if {![info exists env($u)]} { - set env($u) $env($p) - } + set temp $env($p) + unset env($p) + set env($u) $temp trace add variable env($p) write \ [namespace code [list EnvTraceProc $p]] trace add variable env($u) write \ @@ -179,9 +179,9 @@ if {[interp issafe]} { -subcommands { add clicks format microseconds milliseconds scan seconds }] - + # Auto-loading stubs for 'clock.tcl' - + foreach cmd {add format scan} { proc ::tcl::clock::$cmd args { variable TclLibDir @@ -261,13 +261,13 @@ proc unknown args { # if {[info exists UnknownPending($name)]} { return -code error "self-referential recursion\ - in \"unknown\" for command \"$name\""; + in \"unknown\" for command \"$name\"" } - set UnknownPending($name) pending; + set UnknownPending($name) pending set ret [catch { auto_load $name [uplevel 1 {::namespace current}] } msg opts] - unset UnknownPending($name); + unset UnknownPending($name) if {$ret != 0} { dict append opts -errorinfo "\n (autoloading \"$name\")" return -options $opts $msg @@ -290,7 +290,7 @@ proc unknown args { if {$code == 1} { # # Compute stack trace contribution from the [uplevel]. - # Note the dependence on how Tcl_AddErrorInfo, etc. + # Note the dependence on how Tcl_AddErrorInfo, etc. # construct the stack trace. # set errInfo [dict get $opts -errorinfo] @@ -421,7 +421,7 @@ proc unknown args { # library file to create the procedure. Returns 1 if it successfully # loaded the procedure, 0 otherwise. # -# Arguments: +# Arguments: # cmd - Name of the command to find and load. # namespace (optional) The namespace where the command is being used - must be # a canonical namespace as returned [namespace current] @@ -445,7 +445,7 @@ proc auto_load {cmd {namespace {}}} { # info commands $name # Unfortunately, if the name has glob-magic chars in it like * # or [], it may not match. For our purposes here, a better - # route is to use + # route is to use # namespace which -command $name if {[namespace which -command $name] ne ""} { return 1 @@ -476,7 +476,7 @@ proc auto_load {cmd {namespace {}}} { # of available commands. Returns 1 if the index is loaded, and 0 if # the index is already loaded and up to date. # -# Arguments: +# Arguments: # None. proc auto_load_index {} { @@ -555,34 +555,34 @@ proc auto_qualify {cmd namespace} { # Before each return case we give an example of which category it is # with the following form : - # ( inputCmd, inputNameSpace) -> output + # (inputCmd, inputNameSpace) -> output if {[string match ::* $cmd]} { if {$n > 1} { - # ( ::foo::bar , * ) -> ::foo::bar + # (::foo::bar , *) -> ::foo::bar return [list $cmd] } else { - # ( ::global , * ) -> global + # (::global , *) -> global return [list [string range $cmd 2 end]] } } - + # Potentially returning 2 elements to try : # (if the current namespace is not the global one) if {$n == 0} { if {$namespace eq "::"} { - # ( nocolons , :: ) -> nocolons + # (nocolons , ::) -> nocolons return [list $cmd] } else { - # ( nocolons , ::sub ) -> ::sub::nocolons nocolons + # (nocolons , ::sub) -> ::sub::nocolons nocolons return [list ${namespace}::$cmd $cmd] } } elseif {$namespace eq "::"} { - # ( foo::bar , :: ) -> ::foo::bar + # (foo::bar , ::) -> ::foo::bar return [list ::$cmd] } else { - # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar + # (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar return [list ${namespace}::$cmd ::$cmd] } } @@ -624,13 +624,13 @@ proc auto_import {pattern} { # auto_execok -- # -# Returns string that indicates name of program to execute if +# Returns string that indicates name of program to execute if # name corresponds to a shell builtin or an executable in the -# Windows search path, or "" otherwise. Builds an associative -# array auto_execs that caches information about previous checks, +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, # for speed. # -# Arguments: +# Arguments: # name - Name of a command. if {$tcl_platform(platform) eq "windows"} { @@ -685,7 +685,7 @@ proc auto_execok name { set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { - set windir $env(WINDIR) + set windir $env(WINDIR) } if {[info exists windir]} { if {$tcl_platform(os) eq "Windows NT"} { @@ -704,7 +704,7 @@ proc auto_execok name { unset -nocomplain checked foreach dir [split $path {;}] { # Skip already checked directories - if {[info exists checked($dir)] || ($dir eq {})} { + if {[info exists checked($dir)] || ($dir eq "")} { continue } set checked($dir) {} @@ -753,13 +753,13 @@ proc auto_execok name { # This procedure is called by Tcl's core when attempts to call the # filesystem's copydirectory function fail. The semantics of the call # are that 'dest' does not yet exist, i.e. dest should become the exact -# image of src. If dest does exist, we throw an error. -# +# image of src. If dest does exist, we throw an error. +# # Note that making changes to this procedure can change the results # of running Tcl's tests. # -# Arguments: -# action - "renaming" or "copying" +# Arguments: +# action - "renaming" or "copying" # src - source directory # dest - destination directory proc tcl::CopyDirectory {action src dest} { @@ -787,7 +787,7 @@ proc tcl::CopyDirectory {action src dest} { # exists, then we should only call this function if -force # is true, which means we just want to over-write. So, # the following code is now commented out. - # + # # return -code error "error $action \"$src\" to\ # \"$dest\": file already exists" } else { @@ -820,7 +820,7 @@ proc tcl::CopyDirectory {action src dest} { # Have to be careful to capture both visible and hidden files. # We will also be more generous to the file system and not # assume the hidden and non-hidden lists are non-overlapping. - # + # # On Unix 'hidden' files begin with '.'. On other platforms # or filesystems hidden files may have other interpretations. set filelist [concat [glob -nocomplain -directory $src *] \ diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d066a1b..4b94312 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2495,14 +2495,6 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { set changedEnv {} set removedEnv {} foreach index [array names ::env] { - if {[info exists originalEnv($index)]} { - if {$::env($index) != $originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $originalEnv($index) - } - } - } - foreach index [array names ::env] { if {![info exists originalEnv($index)]} { lappend newEnv $index unset ::env($index) @@ -2512,6 +2504,9 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { if {![info exists ::env($index)]} { lappend removedEnv $index set ::env($index) $originalEnv($index) + } elseif {$::env($index) ne $originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $originalEnv($index) } } if {[llength $newEnv] > 0} { -- cgit v0.12 From 91582a5e3b0cc2931ad1232c59719d602d95bfc8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Nov 2013 11:43:00 +0000 Subject: Add support for Windows 8.1: See [http://msdn.microsoft.com/en-us/library/windows/desktop/dn302074.aspx] --- win/configure | 20 ++++++++++++++++++-- win/configure.in | 15 ++++++++++++++- win/tclsh.exe.manifest.in | 33 +++++++++++++++++++++++++++++++++ win/tclsh.rc | 13 +++++++++++++ 4 files changed, 78 insertions(+), 3 deletions(-) create mode 100644 win/tclsh.exe.manifest.in diff --git a/win/configure b/win/configure index a997ac9..cec352b 100755 --- a/win/configure +++ b/win/configure @@ -309,7 +309,7 @@ ac_includes_default="\ # include #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. @@ -4821,6 +4821,19 @@ else TCL_PACKAGE_PATH="${prefix}/lib" fi +# The tclsh.exe.manifest requires these +# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs +# the release level, and must account for interim release versioning +case "$TCL_PATCH_LEVEL" in + *a*) TCL_RELEASE_LEVEL=0 ;; + *b*) TCL_RELEASE_LEVEL=1 ;; + *) TCL_RELEASE_LEVEL=2 ;; +esac +TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" + +# X86|AMD64|IA64 for manifest + + @@ -4909,7 +4922,7 @@ fi - ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj" + ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure @@ -5463,6 +5476,7 @@ do "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; "tclConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;; "tcl.hpj" ) CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;; + "tclsh.exe.manifest" ) CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; @@ -5573,6 +5587,8 @@ s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t s,@VC_MANIFEST_EMBED_DLL@,$VC_MANIFEST_EMBED_DLL,;t t s,@VC_MANIFEST_EMBED_EXE@,$VC_MANIFEST_EMBED_EXE,;t t +s,@TCL_WIN_VERSION@,$TCL_WIN_VERSION,;t t +s,@MACHINE@,$MACHINE,;t t s,@TCL_VERSION@,$TCL_VERSION,;t t s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t diff --git a/win/configure.in b/win/configure.in index 8b181f8..cde3ab4 100644 --- a/win/configure.in +++ b/win/configure.in @@ -248,6 +248,19 @@ else TCL_PACKAGE_PATH="${prefix}/lib" fi +# The tclsh.exe.manifest requires these +# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs +# the release level, and must account for interim release versioning +case "$TCL_PATCH_LEVEL" in + *a*) TCL_RELEASE_LEVEL=0 ;; + *b*) TCL_RELEASE_LEVEL=1 ;; + *) TCL_RELEASE_LEVEL=2 ;; +esac +TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" +AC_SUBST(TCL_WIN_VERSION) +# X86|AMD64|IA64 for manifest +AC_SUBST(MACHINE) + AC_SUBST(TCL_VERSION) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) @@ -336,7 +349,7 @@ AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) -AC_OUTPUT(Makefile tclConfig.sh tcl.hpj) +AC_OUTPUT(Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest) dnl Local Variables: dnl mode: autoconf; diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in new file mode 100644 index 0000000..aaa34e1 --- /dev/null +++ b/win/tclsh.exe.manifest.in @@ -0,0 +1,33 @@ + + + + Tcl command line shell (tclsh) + + + + + + + + + + + + + + + + + + + + diff --git a/win/tclsh.rc b/win/tclsh.rc index 16eaf83..161da50 100644 --- a/win/tclsh.rc +++ b/win/tclsh.rc @@ -1,3 +1,4 @@ +// // Version Resource Script // @@ -67,3 +68,15 @@ END // tclsh ICON DISCARDABLE "tclsh.ico" + +// +// This is needed for Windows 8.1 onwards. +// + +#ifndef RT_MANIFEST +#define RT_MANIFEST 24 +#endif +#ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#endif +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tclsh.exe.manifest" -- cgit v0.12 From fd3c38f894a7cce3d725b60f8d5cead803d9ff6c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 21 Nov 2013 16:20:01 +0000 Subject: Modify makefile.vc for Windows 8.1 support --- win/makefile.vc | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index d9570b9..4466439 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -899,6 +899,12 @@ $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? +$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in + @nmakehlp -s << $** >$@ +@MACHINE@ $(MACHINE:IX86=X86) +@TCL_WIN_VERSION@ $(TCL_DOTVERSION).0.0 +<< + #--------------------------------------------------------------------- # Generate the source dependencies. Having dependency rules will # improve incremental build accuracy without having to resort to a @@ -958,12 +964,14 @@ $< << {$(WINDIR)}.rc{$(TMP_DIR)}.res: - $(rc32) -fo $@ -r -i "$(GENERICDIR)" \ + $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ -d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ -d TCL_THREADS=$(TCL_THREADS) \ -d STATIC_BUILD=$(STATIC_BUILD) \ $< +$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest + .SUFFIXES: .SUFFIXES:.c .rc -- cgit v0.12 From f46d2546ab96bd78b76d02331df74ce035c356d4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Nov 2013 13:16:21 +0000 Subject: Cygwin: Fix conflicting definition with _mingw_stat64.h, if included together with --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index eeff36e..31960ec 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -422,7 +422,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) - typedef struct _stat32i64 { + typedef struct { dev_t st_dev; unsigned short st_ino; unsigned short st_mode; -- cgit v0.12 From da13f6ea8ce3f01699903c9125b1f90ad0ae2189 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 22 Nov 2013 13:21:52 +0000 Subject: revert accidental part of previous commit --- generic/regcustom.h | 4 ---- generic/regex.h | 4 ---- 2 files changed, 8 deletions(-) diff --git a/generic/regcustom.h b/generic/regcustom.h index d907ca7..1c970ea 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -74,11 +74,7 @@ #endif /* Interface types */ #define __REG_WIDE_T Tcl_UniChar -#ifdef __CYGWIN__ -#define __REG_REGOFF_T int /* Not really right, but good enough... */ -#else #define __REG_REGOFF_T long /* Not really right, but good enough... */ -#endif #define __REG_VOID_T void #define __REG_CONST const /* Names and declarations */ diff --git a/generic/regex.h b/generic/regex.h index 4422f2a..9466fbb 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -106,11 +106,7 @@ extern "C" { #endif /* interface types */ #define __REG_WIDE_T Tcl_UniChar -#ifdef __CYGWIN__ -#define __REG_REGOFF_T int /* not really right, but good enough... */ -#else #define __REG_REGOFF_T long /* not really right, but good enough... */ -#endif #define __REG_VOID_T void #define __REG_CONST const /* names and declarations */ -- cgit v0.12 From 7f7ce5b4a67db42df570c86bcfbc45c4b9fa6d39 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 24 Nov 2013 18:34:16 +0000 Subject: [a122627849] Improve stack trace from parray on not-array. --- library/parray.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/parray.tcl b/library/parray.tcl index 3ce9817..a9c2cb1 100644 --- a/library/parray.tcl +++ b/library/parray.tcl @@ -11,7 +11,7 @@ proc parray {a {pattern *}} { upvar 1 $a array if {![array exists array]} { - error "\"$a\" isn't an array" + return -code error "\"$a\" isn't an array" } set maxl 0 set names [lsort [array names array $pattern]] -- cgit v0.12 From 8f8438c53e0a086672a12fec00764d770323caed Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 5 Dec 2013 15:15:23 +0000 Subject: New compiler and bytecodes for foreach and lmap: 70% faster * speed as measured by http://wiki.tcl.tk/39021: runs in <1/3 the time * still need to adapt array-set to use this * assemble.test-16.5 or 16.6 bombs in a purify/symbols build (?) * removing the old opcodes would force recompilation of old .tbc files or adaptation of tbcload --- generic/tcl.h | 4 ++ generic/tclCompCmds.c | 131 ++++++++++----------------------------- generic/tclCompile.c | 10 +++ generic/tclCompile.h | 12 +++- generic/tclExecute.c | 168 +++++++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 220 insertions(+), 105 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 4bf81cc..aab299e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -848,6 +848,10 @@ typedef struct Tcl_Obj { void *ptr; unsigned long value; } ptrAndLongRep; + struct { + long int1; + long int2; + } twoIntValue; } internalRep; } Tcl_Obj; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9c43bfe..e934d92 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2469,18 +2469,12 @@ CompileEachloopCmd( ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - int firstValueTemp; /* Index of the first temp var in the frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var holding the loop's - * iteration count. */ int collectVar = -1; /* Index of temp var holding the result var * index. */ - + Tcl_Token *tokenPtr, *bodyTokenPtr; - unsigned char *jumpPc; - JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range; - int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; + int jumpBackOffset, infoIndex, range; + int numWords, numLists, numVars, loopIndex, i, j, code; DefineLineInformation; /* TIP #280 */ /* @@ -2588,6 +2582,10 @@ CompileEachloopCmd( loopIndex++; } + /* + * We will compile the foreach command. + */ + if (collect == TCL_EACH_COLLECT) { collectVar = AnonymousLocal(envPtr); if (collectVar < 0) { @@ -2595,25 +2593,7 @@ CompileEachloopCmd( } } - /* - * We will compile the foreach command. Reserve (numLists + 1) temporary - * variables: - * - numLists temps to hold each value list - * - 1 temp for the loop counter (index of next element in each list) - * - * At this time we don't try to reuse temporaries; if there are two - * nonoverlapping foreach loops, they don't share any temps. - */ - code = TCL_OK; - firstValueTemp = -1; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - tempVar = AnonymousLocal(envPtr); - if (loopIndex == 0) { - firstValueTemp = tempVar; - } - } - loopCtTemp = AnonymousLocal(envPtr); /* * Create and initialize the ForeachInfo and ForeachVarList data @@ -2624,8 +2604,8 @@ CompileEachloopCmd( infoPtr = ckalloc(sizeof(ForeachInfo) + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = numLists; - infoPtr->firstValueTemp = firstValueTemp; - infoPtr->loopCtTemp = loopCtTemp; + infoPtr->firstValueTemp = collect; + infoPtr->loopCtTemp = 0; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; @@ -2645,25 +2625,14 @@ CompileEachloopCmd( infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); /* - * Create an exception record to handle [break] and [continue]. + * Evaluate each value list and leave it on stack. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Evaluate then store each value list in the associated temporary. - */ - - loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { CompileWord(envPtr, tokenPtr, interp, i); - tempVar = (firstValueTemp + loopIndex); - Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - loopIndex++; } } @@ -2677,81 +2646,43 @@ CompileEachloopCmd( TclEmitOpcode( INST_POP, envPtr); } - /* - * Initialize the temporary var that holds the count of loop iterations. - */ - - TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Top of loop code: assign each loop variable and check whether - * to terminate the loop. - */ - - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + /* * Inline compile the loop body. */ + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, range); BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); - + if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); } TclEmitOpcode( INST_POP, envPtr); /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump if - * the distance to the test is > 120 bytes. This is conservative and - * ensures that we won't have to replace this jump if we later need to - * replace the ifFalse jump with a 4 byte jump. + * Bottom of loop code: assign each loop variable and check whether + * to terminate the loop. Set the loop's break target. */ - jumpBackOffset = CurrentOffset(envPtr); - jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); - } - - /* - * Fix the target of the jump after the foreach_step test. - */ - - if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->exceptArrayPtr[range].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); - } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); - } - } + ExceptionRangeTarget(envPtr, range, continueOffset); + TclEmitOpcode(INST_FOREACH_STEP, envPtr); + ExceptionRangeTarget(envPtr, range, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, range); + TclEmitOpcode(INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-(numLists+2), envPtr); /* - * Set the loop's break target. + * Set the jumpback distance from INST_FOREACH_STEP to the start of the + * body's code */ - - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); + + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + envPtr->exceptArrayPtr[range].codeOffset; + infoPtr->loopCtTemp = -jumpBackOffset; /* * The command's result is an empty string if not collecting, or the @@ -2765,8 +2696,8 @@ CompileEachloopCmd( } else { PushStringLiteral(envPtr, ""); } - - done: + + done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { if (varvList[loopIndex] != NULL) { ckfree(varvList[loopIndex]); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3c8e4ef..7cd9796 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -545,6 +545,16 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + /* New foreach implementation */ + {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. It pushes 2 + * elements which hold runtime params for foreach_step, they are later + * dropped by foreach_end together with the value lists. */ + {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, + /* "Step" or begin next iteration of foreach loop. */ + {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a39e0f1..c4e6222 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -586,8 +586,8 @@ typedef struct ByteCode { #define INST_CONTINUE 66 /* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 67 -#define INST_FOREACH_STEP4 68 +#define INST_FOREACH_START4 67 /* DEPRECATED */ +#define INST_FOREACH_STEP4 68 /* DEPRECATED */ /* Opcodes 69 to 72 */ #define INST_BEGIN_CATCH4 69 @@ -768,8 +768,14 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 +/* New foreach implementation */ + +#define INST_FOREACH_START 166 +#define INST_FOREACH_STEP 167 +#define INST_FOREACH_END 168 + /* The last opcode */ -#define LAST_INST_OPCODE 165 +#define LAST_INST_OPCODE 168 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3c1227..32b64a2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6029,7 +6029,7 @@ TEBCresume( int varIndex, valIndex, continueLoop, j, iterTmpIndex; long i; - case INST_FOREACH_START4: + case INST_FOREACH_START4: /* DEPRECATED */ /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. @@ -6062,7 +6062,7 @@ TEBCresume( NEXT_INST_F(5, 0, 0); #endif - case INST_FOREACH_STEP4: + case INST_FOREACH_STEP4: /* DEPRECATED */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. @@ -6180,6 +6180,170 @@ TEBCresume( } else { NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } + + } + { + ForeachInfo *infoPtr; + Tcl_Obj *listPtr, **elements, *tmpPtr; + ForeachVarList *varListPtr; + int numLists, iterMax, listLen, numVars; + int iterTmp, iterNum, listTmpDepth; + int varIndex, valIndex, j; + long i; + + case INST_FOREACH_START: + /* + * Initialize the data for the looping construct, pushing the + * corresponding Tcl_Objs to the stack. + */ + + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + + /* + * Compute the number of iterations that will be run: iterMax + */ + + iterMax = 0; + listTmpDepth = numLists-1; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + listPtr = OBJ_AT_DEPTH(listTmpDepth); + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + if (Tcl_IsShared(listPtr)) { + objPtr = TclListObjCopy(NULL, listPtr); + Tcl_IncrRefCount(objPtr); + Tcl_DecrRefCount(listPtr); + OBJ_AT_DEPTH(listTmpDepth) = objPtr; + } + iterTmp = (listLen + (numVars - 1))/numVars; + if (iterTmp > iterMax) { + iterMax = iterTmp; + } + listTmpDepth--; + } + + /* + * Store the iterNum and iterMax in a single Tcl_Obj; we keep a + * nul-string obj with the pointer stored in the ptrValue so that the + * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but + * it will never leave this scope and is read-only. + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.twoIntValue.int1 = 0; + tmpPtr->internalRep.twoIntValue.int2 = iterMax; + PUSH_OBJECT(tmpPtr); /* iterCounts object */ + + /* + * Store a pointer to the ForeachInfo struct; same dirty trick + * as above + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.otherValuePtr = infoPtr; + PUSH_OBJECT(tmpPtr); /* infoPtr object */ + + /* + * Jump directly to the INST_FOREACH_STEP instruction; the C code just + * falls through. + */ + + pc += 5 - infoPtr->loopCtTemp; + + case INST_FOREACH_STEP: + /* + * "Step" a foreach loop (i.e., begin its next iteration) by assigning + * the next value list element to each loop var. + */ + + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + + tmpPtr = OBJ_AT_DEPTH(1); + iterNum = tmpPtr->internalRep.twoIntValue.int1; + iterMax = tmpPtr->internalRep.twoIntValue.int2; + + /* + * If some list still has a remaining list element iterate one more + * time. Assign to var the next element from its value list. + */ + + if (iterNum < iterMax) { + /* + * Set the variables and jump back to run the body + */ + + tmpPtr->internalRep.twoIntValue.int1 = iterNum + 1; + + listTmpDepth = numLists + 1; + + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listPtr = OBJ_AT_DEPTH(listTmpDepth); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_WITH_OBJ(( + "%u => ERROR init. index temp %d: ", + opnd,varIndex), Tcl_GetObjResult(interp)); + goto gotError; + } + CACHE_STACK_INFO(); + } + valIndex++; + } + listTmpDepth--; + } + NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); + } + + /* + * FALL THROUGH + */ + pc++; + + case INST_FOREACH_END: + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + NEXT_INST_V(1, numLists+2, 0); } case INST_BEGIN_CATCH4: -- cgit v0.12 From 631b9c724ec78675e289d7f1dec92dc7d5165fc2 Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 5 Dec 2013 16:01:16 +0000 Subject: add comments on field "misuse" --- generic/tclCompCmds.c | 2 +- generic/tclExecute.c | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index e934d92..78c6c5a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2677,7 +2677,7 @@ CompileEachloopCmd( /* * Set the jumpback distance from INST_FOREACH_STEP to the start of the - * body's code + * body's code. Misuse loopCtTemp for storing the jump size. */ jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 32b64a2..191a897 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6331,6 +6331,7 @@ TEBCresume( } listTmpDepth--; } + /* loopCtTemp being 'misused' for storing the jump size */ NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); } -- cgit v0.12 From ff9c2d4ad9a37c50a4921bada422365ae85d5ac1 Mon Sep 17 00:00:00 2001 From: mig Date: Thu, 5 Dec 2013 17:18:54 +0000 Subject: add comments on INST_FOREACH_* --- generic/tclExecute.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 191a897..fe05b30 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6259,6 +6259,7 @@ TEBCresume( pc += 5 - infoPtr->loopCtTemp; case INST_FOREACH_STEP: + /* THIS INSTRUCTION IS ONLY CALLED AS A CONTINUE TARGET */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. @@ -6341,6 +6342,7 @@ TEBCresume( pc++; case INST_FOREACH_END: + /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; -- cgit v0.12 From 6c9f0c69b67589dd2c52c36bdd3fd3a7fb8e6f60 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Dec 2013 20:45:45 +0000 Subject: Draft fix for Bug 0b874c344d. Includes test. --- generic/tclCmdIL.c | 60 ++++++++++++++++++++++++++++++++++++++++++++++++---- tests/coroutine.test | 3 +++ 2 files changed, 59 insertions(+), 4 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index fa4ead4..57434c1 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,6 +104,8 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ +static CmdFrame * CmdFrameChain(CoroutineData *corPtr); +static void CmdFrameUnchain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1167,20 +1169,22 @@ InfoFrameCmd( */ CmdFrame *lastPtr = NULL; + CmdFrame *tailPtr = CmdFrameChain(corPtr); + int offset = tailPtr ? tailPtr->level : 0; runPtr = iPtr->cmdFramePtr; /* TODO - deal with overflow */ - topLevel += corPtr->caller.cmdFramePtr->level; + topLevel += offset; while (runPtr) { - runPtr->level += corPtr->caller.cmdFramePtr->level; + runPtr->level += offset; lastPtr = runPtr; runPtr = runPtr->nextPtr; } if (lastPtr) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; + lastPtr->nextPtr = tailPtr; } else { - iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; + iPtr->cmdFramePtr = tailPtr; } } @@ -1244,10 +1248,58 @@ InfoFrameCmd( runPtr->level = 1; runPtr->nextPtr = NULL; } + CmdFrameUnchain(corPtr); } return code; } + +static void +CmdFrameUnchain( + CoroutineData *corPtr) +{ + if (corPtr->callerEEPtr->corPtr) { + CmdFrame *endPtr = corPtr->callerEEPtr->corPtr->caller.cmdFramePtr; + + if (corPtr->caller.cmdFramePtr == endPtr) { + corPtr->caller.cmdFramePtr = NULL; + } else { + CmdFrame *runPtr = corPtr->caller.cmdFramePtr; + + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; + } + CmdFrameUnchain(corPtr->callerEEPtr->corPtr); + } +} + +static CmdFrame * +CmdFrameChain( + CoroutineData *corPtr) +{ + if (corPtr->callerEEPtr->corPtr) { + CmdFrame *tailPtr = CmdFrameChain(corPtr->callerEEPtr->corPtr); + CmdFrame *lastPtr = NULL; + CmdFrame *runPtr = corPtr->caller.cmdFramePtr; + int offset = tailPtr ? tailPtr->level : 0; + + while (runPtr) { + runPtr->level += offset; + lastPtr = runPtr; + runPtr = runPtr->nextPtr; + } + if (lastPtr) { + lastPtr->nextPtr = tailPtr; + } else { + corPtr->caller.cmdFramePtr = tailPtr; + } + } + return corPtr->caller.cmdFramePtr; +} /* *---------------------------------------------------------------------- diff --git a/tests/coroutine.test b/tests/coroutine.test index 03c63ad..a360fd5 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -342,6 +342,9 @@ test coroutine-3.6 {info frame, bug #2910094} -setup { rename stack {} rename a {} } -result {} +test coroutine-3.7 {bug 0b874c344d} { + dict get [coroutine X coroutine Y info frame 0] cmd +} {coroutine X coroutine Y info frame 0} test coroutine-4.1 {bug #2093188} -setup { proc foo {} { -- cgit v0.12 From ec2f589b56bb7241ee7f7b60aad33ccdfa46ec98 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 00:02:16 +0000 Subject: tighter mem management --- generic/tclCompCmds.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 78c6c5a..da14af1 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2602,16 +2602,14 @@ CompileEachloopCmd( */ infoPtr = ckalloc(sizeof(ForeachInfo) - + numLists * sizeof(ForeachVarList *)); + + (numLists - 1) * sizeof(ForeachVarList *)); infoPtr->numLists = numLists; - infoPtr->firstValueTemp = collect; - infoPtr->loopCtTemp = 0; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; numVars = varcList[loopIndex]; varListPtr = ckalloc(sizeof(ForeachVarList) - + numVars * sizeof(int)); + + (numVars - 1) * sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { const char *varName = varvList[loopIndex][j]; -- cgit v0.12 From bd06c04659422136285db5fbcb585c18d10b595d Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 00:16:07 +0000 Subject: tighter mem management in array-set compiler --- generic/tclCompCmds.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index da14af1..73b1ec3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -323,11 +323,11 @@ TclCompileArraySetCmd( keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); + infoPtr = ckalloc(sizeof(ForeachInfo)); infoPtr->numLists = 1; infoPtr->firstValueTemp = dataVar; infoPtr->loopCtTemp = iterVar; - infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); + infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; -- cgit v0.12 From 53009920c226ade2ef2f7f12b73ee9cc0bcf766b Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 01:07:10 +0000 Subject: adapted the array-set compiler to use the new foreach opcodes --- generic/tclCompCmds.c | 83 +++++++++++++++++++-------------------------------- generic/tclExecute.c | 1 - 2 files changed, 31 insertions(+), 53 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 73b1ec3..b8b2605 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -245,8 +245,8 @@ TclCompileArraySetCmd( Tcl_Token *varTokenPtr, *dataTokenPtr; int isScalar, localIndex, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven, len; - int dataVar, iterVar, keyVar, valVar, infoIndex; - int back, fwd, offsetBack, offsetFwd; + int keyVar, valVar, infoIndex; + int fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; ForeachInfo *infoPtr; @@ -290,6 +290,7 @@ TclCompileArraySetCmd( code = TCL_ERROR; goto done; } + /* * Special case: literal empty value argument is just an "ensure array" * operation. @@ -314,19 +315,28 @@ TclCompileArraySetCmd( goto done; } + if (localIndex < 0) { + /* + * a non-local variable: upvar from a local one! This consumes the + * variable name that was left at stacktop. + */ + + localIndex = AnonymousLocal(envPtr); + PushStringLiteral(envPtr, "0"); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + /* * Prepare for the internal foreach. */ - dataVar = AnonymousLocal(envPtr); - iterVar = AnonymousLocal(envPtr); keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); infoPtr = ckalloc(sizeof(ForeachInfo)); infoPtr->numLists = 1; - infoPtr->firstValueTemp = dataVar; - infoPtr->loopCtTemp = iterVar; infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; @@ -360,54 +370,23 @@ TclCompileArraySetCmd( fwd = CurrentOffset(envPtr) - offsetFwd; TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); } - Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - TclEmitOpcode( INST_POP, envPtr); - } - if (!isDataLiteral) { - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( dataVar, envPtr); - } + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ + TclEmitOpcode( INST_FOREACH_STEP, envPtr); + TclEmitOpcode( INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-3, envPtr); PushStringLiteral(envPtr, ""); - done: + + done: Tcl_DecrRefCount(literalObj); return code; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fe05b30..a831cd6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6259,7 +6259,6 @@ TEBCresume( pc += 5 - infoPtr->loopCtTemp; case INST_FOREACH_STEP: - /* THIS INSTRUCTION IS ONLY CALLED AS A CONTINUE TARGET */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. -- cgit v0.12 From 7631cbda15c13ff69b665f0b71ad20c866c00624 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Dec 2013 09:28:45 +0000 Subject: Stop printing undefined values in disassembled code. --- generic/tclCompCmds.c | 42 +++++++++++++++++++++++++++++++++++++++++- generic/tclCompile.h | 1 + generic/tclExecute.c | 17 ++++++++--------- 3 files changed, 50 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b8b2605..bdab2ff 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -31,6 +31,9 @@ static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void PrintNewForeachInfo(ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -49,6 +52,13 @@ const AuxDataType tclForeachInfoType = { PrintForeachInfo /* printProc */ }; +const AuxDataType tclNewForeachInfoType = { + "NewForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo, /* freeProc */ + PrintNewForeachInfo /* printProc */ +}; + const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ @@ -2599,7 +2609,7 @@ CompileEachloopCmd( } infoPtr->varLists[loopIndex] = varListPtr; } - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); /* * Evaluate each value list and leave it on stack. @@ -2828,6 +2838,36 @@ PrintForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +static void +PrintNewForeachInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + infoPtr->loopCtTemp); + for (i=0 ; inumLists ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendToObj(appendObj, "[", -1); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; jnumVars ; j++) { + if (j) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); + } + Tcl_AppendToObj(appendObj, "]", -1); + } +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c4e6222..8b1724b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -908,6 +908,7 @@ typedef struct ForeachInfo { } ForeachInfo; MODULE_SCOPE const AuxDataType tclForeachInfoType; +MODULE_SCOPE const AuxDataType tclNewForeachInfoType; #define FOREACHINFO(envPtr, index) \ ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a831cd6..f496fe7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6197,7 +6197,6 @@ TEBCresume( * corresponding Tcl_Objs to the stack. */ - opnd = TclGetUInt4AtPtr(pc+1); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; @@ -6229,7 +6228,7 @@ TEBCresume( } listTmpDepth--; } - + /* * Store the iterNum and iterMax in a single Tcl_Obj; we keep a * nul-string obj with the pointer stored in the ptrValue so that the @@ -6241,12 +6240,12 @@ TEBCresume( tmpPtr->internalRep.twoIntValue.int1 = 0; tmpPtr->internalRep.twoIntValue.int2 = iterMax; PUSH_OBJECT(tmpPtr); /* iterCounts object */ - + /* * Store a pointer to the ForeachInfo struct; same dirty trick - * as above + * as above */ - + TclNewObj(tmpPtr); tmpPtr->internalRep.otherValuePtr = infoPtr; PUSH_OBJECT(tmpPtr); /* infoPtr object */ @@ -6254,10 +6253,10 @@ TEBCresume( /* * Jump directly to the INST_FOREACH_STEP instruction; the C code just * falls through. - */ + */ pc += 5 - infoPtr->loopCtTemp; - + case INST_FOREACH_STEP: /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning @@ -6276,14 +6275,14 @@ TEBCresume( * If some list still has a remaining list element iterate one more * time. Assign to var the next element from its value list. */ - + if (iterNum < iterMax) { /* * Set the variables and jump back to run the body */ tmpPtr->internalRep.twoIntValue.int1 = iterNum + 1; - + listTmpDepth = numLists + 1; for (i = 0; i < numLists; i++) { -- cgit v0.12 From 68864af6c2b0d93f8693c0f3447ffc7f8f92eb0e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 6 Dec 2013 10:04:48 +0000 Subject: Introducing a new union member in Tcl_Obj is not a good idea in a patch release, especially using "long". Better allow iterNum and iterMax to grow to ssize_t (or size_t) in Tcl 9 (or 8.x, why not?). Usage of "long" in public API causes interoperability problems between Cygwin64 and Win64 (probably no-one cares except me). --- generic/tcl.h | 4 ---- generic/tclExecute.c | 10 +++++----- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index aab299e..4bf81cc 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -848,10 +848,6 @@ typedef struct Tcl_Obj { void *ptr; unsigned long value; } ptrAndLongRep; - struct { - long int1; - long int2; - } twoIntValue; } internalRep; } Tcl_Obj; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f496fe7..c3f5372 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6237,8 +6237,8 @@ TEBCresume( */ TclNewObj(tmpPtr); - tmpPtr->internalRep.twoIntValue.int1 = 0; - tmpPtr->internalRep.twoIntValue.int2 = iterMax; + tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; + tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); PUSH_OBJECT(tmpPtr); /* iterCounts object */ /* @@ -6268,8 +6268,8 @@ TEBCresume( numLists = infoPtr->numLists; tmpPtr = OBJ_AT_DEPTH(1); - iterNum = tmpPtr->internalRep.twoIntValue.int1; - iterMax = tmpPtr->internalRep.twoIntValue.int2; + iterNum = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr2); /* * If some list still has a remaining list element iterate one more @@ -6281,7 +6281,7 @@ TEBCresume( * Set the variables and jump back to run the body */ - tmpPtr->internalRep.twoIntValue.int1 = iterNum + 1; + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); listTmpDepth = numLists + 1; -- cgit v0.12 From c5df69b71626521628a0033c5e3720beaa366998 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 6 Dec 2013 10:17:58 +0000 Subject: Oops, wrong macro. --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c3f5372..b6d8841 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6268,8 +6268,8 @@ TEBCresume( numLists = infoPtr->numLists; tmpPtr = OBJ_AT_DEPTH(1); - iterNum = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr1); - iterMax = INT2PTR(tmpPtr->internalRep.twoPtrValue.ptr2); + iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2); /* * If some list still has a remaining list element iterate one more -- cgit v0.12 From 3cfba0cf67f0c2170e26cbff26e5dcc8bc64bf61 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 6 Dec 2013 14:29:49 +0000 Subject: change NULL to INT2PTR(0), for clarity --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b6d8841..a3083bc 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6237,7 +6237,7 @@ TEBCresume( */ TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0); tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); PUSH_OBJECT(tmpPtr); /* iterCounts object */ -- cgit v0.12 From 5b08f1d1ef025223ce9bc15d06dbdb88c247822a Mon Sep 17 00:00:00 2001 From: mig Date: Tue, 10 Dec 2013 11:38:17 +0000 Subject: new INST_LMAP_COLLECT, speeds up lmap and eliminates the need for a temp var --- generic/tclCompCmds.c | 42 ++++++++++++++---------------------------- generic/tclCompile.c | 1 + generic/tclCompile.h | 3 ++- generic/tclExecute.c | 19 +++++++++++++++++++ 4 files changed, 36 insertions(+), 29 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bdab2ff..cd43cfc 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2458,8 +2458,6 @@ CompileEachloopCmd( ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - int collectVar = -1; /* Index of temp var holding the result var - * index. */ Tcl_Token *tokenPtr, *bodyTokenPtr; int jumpBackOffset, infoIndex, range; @@ -2575,13 +2573,6 @@ CompileEachloopCmd( * We will compile the foreach command. */ - if (collect == TCL_EACH_COLLECT) { - collectVar = AnonymousLocal(envPtr); - if (collectVar < 0) { - return TCL_ERROR; - } - } - code = TCL_OK; /* @@ -2612,6 +2603,14 @@ CompileEachloopCmd( infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); /* + * Create the collecting object, unshared. + */ + + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt4(INST_LIST, 0, envPtr); + } + + /* * Evaluate each value list and leave it on stack. */ @@ -2623,16 +2622,6 @@ CompileEachloopCmd( } } - /* - * Create temporary variable to capture return values from loop body. - */ - - if (collect == TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); /* @@ -2646,9 +2635,10 @@ CompileEachloopCmd( ExceptionRangeEnds(envPtr, range); if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); + TclEmitOpcode(INST_LMAP_COLLECT, envPtr); + } else { + TclEmitOpcode( INST_POP, envPtr); } - TclEmitOpcode( INST_POP, envPtr); /* * Bottom of loop code: assign each loop variable and check whether @@ -2672,15 +2662,11 @@ CompileEachloopCmd( infoPtr->loopCtTemp = -jumpBackOffset; /* - * The command's result is an empty string if not collecting, or the - * list of results from evaluating the loop body. + * The command's result is an empty string if not collecting. If + * collecting, it is automatically left on stack after FOREACH_END. */ - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { + if (collect != TCL_EACH_COLLECT) { PushStringLiteral(envPtr, ""); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7cd9796..c7b7875 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -554,6 +554,7 @@ InstructionDesc const tclInstructionTable[] = { {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, /* "Step" or begin next iteration of foreach loop. */ {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + {"lmap_collect", 1, 0, 0, {OPERAND_NONE}}, {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 8b1724b..7f62849 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -773,9 +773,10 @@ typedef struct ByteCode { #define INST_FOREACH_START 166 #define INST_FOREACH_STEP 167 #define INST_FOREACH_END 168 +#define INST_LMAP_COLLECT 169 /* The last opcode */ -#define LAST_INST_OPCODE 168 +#define LAST_INST_OPCODE 169 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a3083bc..9261f19 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6345,6 +6345,25 @@ TEBCresume( infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; NEXT_INST_V(1, numLists+2, 0); + + case INST_LMAP_COLLECT: + /* + * This instruction is only issued by lmap. The stack is: + * - result + * - infoPtr + * - loop counters + * - valLists + * - collecting obj (unshared) + * The instruction lappends the result to the collecting obj. + */ + + tmpPtr = OBJ_AT_DEPTH(1); + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + + objPtr = OBJ_AT_DEPTH(3 + numLists); + Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); + NEXT_INST_F(1, 1, 0); } case INST_BEGIN_CATCH4: -- cgit v0.12 From 05c6524f4576db17abf945a46f2a34d85d34a683 Mon Sep 17 00:00:00 2001 From: mig Date: Tue, 10 Dec 2013 12:05:06 +0000 Subject: fix stack computations for lmap --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c7b7875..6c2e2b6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -554,7 +554,7 @@ InstructionDesc const tclInstructionTable[] = { {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, /* "Step" or begin next iteration of foreach loop. */ {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, - {"lmap_collect", 1, 0, 0, {OPERAND_NONE}}, + {"lmap_collect", 1, -1, 0, {OPERAND_NONE}}, {NULL, 0, 0, 0, {OPERAND_NONE}} }; -- cgit v0.12 From 6af51247c19f071e11ea3f2b27724643bb7e0d70 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 13:49:20 +0000 Subject: simplifying: drop early the evaled script --- generic/tclCompCmds.c | 37 ++++++++----------------------------- 1 file changed, 8 insertions(+), 29 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index cd43cfc..0a0aa8e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,11 +610,10 @@ TclCompileCatchCmd( ExceptionRangeStarts(envPtr, range); TclEmitOpcode( INST_DUP, envPtr); TclEmitInvoke(envPtr, INST_EVAL_STK); + /* drop the script */ + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_POP, envPtr); } - /* Stack at this point: - * nonsimple: script result - * simple: result - */ if (resultIndex == -1) { /* @@ -632,14 +631,7 @@ TclCompileCatchCmd( TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); ExceptionRangeEnds(envPtr, range); TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Stack at this point: - * nonsimple: script returnCode - * simple: returnCode - */ - - goto dropScriptAtEnd; + return TCL_OK; } /* @@ -649,7 +641,6 @@ TclCompileCatchCmd( PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - /* Stack at this point: ?script? result TCL_OK */ /* * Emit the "error case" epilogue. Push the interpreter result and the @@ -658,7 +649,7 @@ TclCompileCatchCmd( TclAdjustStackDepth(-2, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); - /* Stack at this point: ?script? */ + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); @@ -666,7 +657,7 @@ TclCompileCatchCmd( * Update the target of the jump after the "no errors" code. */ - /* Stack at this point: ?script? result returnCode */ + /* Stack at this point: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); @@ -689,7 +680,7 @@ TclCompileCatchCmd( /* * At this point, the top of the stack is inconveniently ordered: - * ?script? result returnCode ?returnOptions? + * result returnCode ?returnOptions? * Reverse the stack to bring the result to the top. */ @@ -707,7 +698,7 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); /* - * Stack is now ?script? ?returnOptions? returnCode. + * Stack is now ?returnOptions? returnCode. * If the options dict has been requested, it is buried on the stack under * the return code. Reverse the stack to bring it to the top, store it and * remove it from the stack. @@ -719,18 +710,6 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); } - dropScriptAtEnd: - - /* - * Stack is now ?script? result. Get rid of the subst'ed script if it's - * hanging arond. - */ - - if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - return TCL_OK; } -- cgit v0.12 From 13a7f30bb1ad0a3bb814f20efe88d5eb02d9e453 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 14:51:15 +0000 Subject: store options early: simplify compiler, reduce stack manipulations --- generic/tclCompCmds.c | 32 ++++++-------------------------- 1 file changed, 6 insertions(+), 26 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0a0aa8e..65c50eb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -614,6 +614,7 @@ TclCompileCatchCmd( TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_POP, envPtr); } + ExceptionRangeEnds(envPtr, range); if (resultIndex == -1) { /* @@ -669,47 +670,26 @@ TclCompileCatchCmd( if (optsIndex != -1) { TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* * End the catch */ - ExceptionRangeEnds(envPtr, range); TclEmitOpcode( INST_END_CATCH, envPtr); /* * At this point, the top of the stack is inconveniently ordered: - * result returnCode ?returnOptions? - * Reverse the stack to bring the result to the top. - */ - - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - } else { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - } - - /* - * Store the result and remove it from the stack. + * result returnCode + * Reverse the stack to store the result. */ + TclEmitInstInt4( INST_REVERSE, 2, envPtr); Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); - /* - * Stack is now ?returnOptions? returnCode. - * If the options dict has been requested, it is buried on the stack under - * the return code. Reverse the stack to bring it to the top, store it and - * remove it from the stack. - */ - - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - return TCL_OK; } -- cgit v0.12 From d83a8d3b91859aa6d510256f3b26c4a3d98bdd5d Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 15:16:20 +0000 Subject: simplify: remove the special case --- generic/tclCompCmds.c | 25 ++++--------------------- 1 file changed, 4 insertions(+), 21 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 65c50eb..dbc876a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -616,25 +616,6 @@ TclCompileCatchCmd( } ExceptionRangeEnds(envPtr, range); - if (resultIndex == -1) { - /* - * Special case when neither result nor options are being saved. In - * that case, we can skip quite a bit of the command epilogue; all we - * have to do is drop the result and push the return code (and, of - * course, finish the catch context). - */ - - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitInstInt1( INST_JUMP1, 3, envPtr); - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - return TCL_OK; - } - /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, * and jump around the "error case" code. @@ -687,8 +668,10 @@ TclCompileCatchCmd( */ TclEmitInstInt4( INST_REVERSE, 2, envPtr); - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + if (resultIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); return TCL_OK; } -- cgit v0.12 From c7d612f81758056c1d7511f1f4f8dff108ef76d7 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 15:55:28 +0000 Subject: new test, and fix for bug --- generic/tclCompCmds.c | 15 +++++++++------ tests/compile.test | 30 ++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index dbc876a..7997efa 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -645,14 +645,8 @@ TclCompileCatchCmd( (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - /* - * Push the return options if the caller wants them. - */ - if (optsIndex != -1) { TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); } /* @@ -662,6 +656,15 @@ TclCompileCatchCmd( TclEmitOpcode( INST_END_CATCH, envPtr); /* + * Push the return options if the caller wants them. + */ + + if (optsIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + + /* * At this point, the top of the stack is inconveniently ordered: * result returnCode * Reverse the stack to store the result. diff --git a/tests/compile.test b/tests/compile.test index 36e24de..2852bf2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -167,6 +167,36 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*} -cleanup {namespace delete catchtest} } +test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{ + -setup { + namespace eval catchtest { + variable options1 {} + } + trace add variable catchtest::options1 write catchtest::failtrace + proc catchtest::failtrace {n1 n2 op} { + return -code error "trace on $n1 fails by request" + } + } + -body { + proc catchtest::x {} { + variable options1 + set count 0 + for {set i 0} {$i < 10} {incr i} { + set status2 [catch { + set status1 [catch { + return -code error -level 0 "original failure" + } result1 options1] + } result2 options2] + incr count + } + list $count $result2 + } + catchtest::x + } + -result {10 {can't set "options1": trace on options1 fails by request}} + -cleanup {namespace delete catchtest} +} + test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 -- cgit v0.12 From 1ef52b35f0c918fa1c081116f142afd4e244eaf1 Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 16:27:59 +0000 Subject: comments --- generic/tclCompCmds.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7997efa..e071bbd 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -645,6 +645,11 @@ TclCompileCatchCmd( (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } + /* + * Push the return options if the caller wants them. This needs to happen + * before INST_END_CATCH + */ + if (optsIndex != -1) { TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); } @@ -656,7 +661,8 @@ TclCompileCatchCmd( TclEmitOpcode( INST_END_CATCH, envPtr); /* - * Push the return options if the caller wants them. + * Save the result and return options if the caller wants them. This needs + * to happen after INST_END_CATCH (compile-3.6/7). */ if (optsIndex != -1) { -- cgit v0.12 From d2ffd68c98038a0690f6a6e2f9a32b6439a7fe7e Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 16:33:21 +0000 Subject: comments --- generic/tclCompCmds.c | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index e071bbd..43504bf 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -635,16 +635,13 @@ TclCompileCatchCmd( TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - /* - * Update the target of the jump after the "no errors" code. - */ - - /* Stack at this point: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } + /* Stack at this point: result returnCode */ + /* * Push the return options if the caller wants them. This needs to happen * before INST_END_CATCH -- cgit v0.12 From ee023de8d6942ebb02809d498f6dd46f634fa98d Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 11 Dec 2013 16:43:26 +0000 Subject: comments --- generic/tclCompCmds.c | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 43504bf..72b338c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -582,11 +582,7 @@ TclCompileCatchCmd( /* * We will compile the catch command. Declare the exception range that it * uses. - */ - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - - /* + * * If the body is a simple word, compile a BEGIN_CATCH instruction, * followed by the instructions to eval the body. * Otherwise, compile instructions to substitute the body text before @@ -599,6 +595,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -635,13 +632,13 @@ TclCompileCatchCmd( TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); + /* Stack at this point on both branches: result returnCode */ + if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } - /* Stack at this point: result returnCode */ - /* * Push the return options if the caller wants them. This needs to happen * before INST_END_CATCH -- cgit v0.12 From 959c0b7ee6f676289f4bcb26638947b88e7d576b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 12 Dec 2013 09:57:38 +0000 Subject: simple compilation of [string replace] --- generic/tclCmdMZ.c | 2 +- generic/tclCompCmdsSZ.c | 116 ++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ 3 files changed, 120 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index da8ffe3..cefe850 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3339,7 +3339,7 @@ TclInitStringCmd( {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, + {"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0}, {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ca4b316..e7b3ddc 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -658,6 +658,122 @@ TclCompileStringRangeCmd( return TCL_OK; } +int +TclCompileStringReplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL; + DefineLineInformation; /* TIP #280 */ + int idx1, idx2; + + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + return TCL_ERROR; + } + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(valueTokenPtr); + tokenPtr = TokenAfter(tokenPtr); + replacementTokenPtr = TokenAfter(tokenPtr); + } + + /* + * Parse the indices. Will only compile special cases if both are + * constants and not an _integer_ less than zero (since we reserve + * negative indices here for end-relative indexing) or an end-based index + * greater than 'end' itself. + */ + + tokenPtr = TokenAfter(valueTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + goto genericReplace; + } + + tokenPtr = TokenAfter(tokenPtr); + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + goto genericReplace; + } + + /* + * We handle these replacements specially: first character (where + * idx1=idx2=0) and suffixes (where idx1=idx2=INDEX_END). Anything else + * and the semantics get rather screwy. + */ + + if (idx1 == 0 && idx2 == 0) { + int notEq, end; + + /* + * Just working with the first character. + */ + + CompileWord(envPtr, valueTokenPtr, interp, 1); + if (replacementTokenPtr == NULL) { + /* Drop first */ + OP44( STR_RANGE_IMM, 1, INDEX_END); + return TCL_OK; + } + /* Replace first */ + CompileWord(envPtr, replacementTokenPtr, interp, 4); + OP4( OVER, 1); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_FALSE, notEq); + OP( POP); + JUMP1( JUMP, end); + FIXJUMP1(notEq); + TclAdjustStackDepth(1, envPtr); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, 1, INDEX_END); + OP1( STR_CONCAT1, 2); + FIXJUMP1(end); + return TCL_OK; + + } else if (idx1 == INDEX_END && idx2 == INDEX_END) { + int notEq, end; + + /* + * Just working with the last character. + */ + + CompileWord(envPtr, valueTokenPtr, interp, 1); + if (replacementTokenPtr == NULL) { + /* Drop last */ + OP44( STR_RANGE_IMM, 0, INDEX_END-1); + return TCL_OK; + } + /* Replace last */ + CompileWord(envPtr, replacementTokenPtr, interp, 4); + OP4( OVER, 1); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_FALSE, notEq); + OP( POP); + JUMP1( JUMP, end); + FIXJUMP1(notEq); + TclAdjustStackDepth(1, envPtr); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, 0, INDEX_END-1); + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + FIXJUMP1(end); + return TCL_OK; + + } else { + /* + * Too complicated to optimize, but we know the number of arguments is + * correct so we can issue a call of the "standard" implementation. + */ + + genericReplace: + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } +} + /* * Synch with tclCmdMZ.c */ diff --git a/generic/tclInt.h b/generic/tclInt.h index aac94ca..ad17415 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3621,6 +3621,9 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringReplaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From 9c336539e4efc2577c7977a99679a133bf4569c5 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 13 Dec 2013 18:39:12 +0000 Subject: Simplify the coding of the unchain operation. --- generic/tclCmdIL.c | 40 +++++++++------------------------------- 1 file changed, 9 insertions(+), 31 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 57434c1..fc2c367 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -105,7 +105,6 @@ typedef struct SortInfo { */ static CmdFrame * CmdFrameChain(CoroutineData *corPtr); -static void CmdFrameUnchain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1150,7 +1149,7 @@ InfoFrameCmd( { Interp *iPtr = (Interp *) interp; int level, topLevel, code = TCL_OK; - CmdFrame *runPtr, *framePtr; + CmdFrame *runPtr, *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; if (objc > 2) { @@ -1235,36 +1234,13 @@ InfoFrameCmd( Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); done: - if (corPtr) { + while (corPtr) { + CmdFrame *endPtr = corPtr->caller.cmdFramePtr; - if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { - iPtr->cmdFramePtr = NULL; + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; } else { - runPtr = iPtr->cmdFramePtr; - while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { - runPtr->level -= corPtr->caller.cmdFramePtr->level; - runPtr = runPtr->nextPtr; - } - runPtr->level = 1; - runPtr->nextPtr = NULL; - } - CmdFrameUnchain(corPtr); - - } - return code; -} - -static void -CmdFrameUnchain( - CoroutineData *corPtr) -{ - if (corPtr->callerEEPtr->corPtr) { - CmdFrame *endPtr = corPtr->callerEEPtr->corPtr->caller.cmdFramePtr; - - if (corPtr->caller.cmdFramePtr == endPtr) { - corPtr->caller.cmdFramePtr = NULL; - } else { - CmdFrame *runPtr = corPtr->caller.cmdFramePtr; + CmdFrame *runPtr = *cmdFramePtrPtr; while (runPtr->nextPtr != endPtr) { runPtr->level -= endPtr->level; @@ -1273,8 +1249,10 @@ CmdFrameUnchain( runPtr->level = 1; runPtr->nextPtr = NULL; } - CmdFrameUnchain(corPtr->callerEEPtr->corPtr); + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; + corPtr = corPtr->callerEEPtr->corPtr; } + return code; } static CmdFrame * -- cgit v0.12 From 12a14105a15ca9bae71b2020fdc9d1c1b1b95dff Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 15 Dec 2013 17:49:53 +0000 Subject: Improve descriptions of character escapes and ranges in Tcl.n. Improve output format handlers to cope with added escape for en-dashes. --- doc/Tcl.n | 39 ++++++++++++++++++++++----------------- tools/man2help2.tcl | 2 +- tools/tcltk-man2html-utils.tcl | 1 + 3 files changed, 24 insertions(+), 18 deletions(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index 8b17f93..c7fa9f6 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -108,8 +108,8 @@ Variable substitution may take any of the following forms: \fIName\fR is the name of a scalar variable; the name is a sequence of one or more characters that are a letter, digit, underscore, or namespace separators (two or more colons). -Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, -\fBA\fR\-\fBZ\fR and \fBa\fR\-\fBz\fR). +Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR, +\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR). .TP 15 \fB$\fIname\fB(\fIindex\fB)\fR . @@ -117,8 +117,8 @@ Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, the name of an element within that array. \fIName\fR must contain only letters, digits, underscores, and namespace separators, and may be an empty string. -Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\-\fB9\fR, -\fBA\fR\-\fBZ\fR and \fBa\fR\-\fBz\fR). +Letters and digits are \fIonly\fR the standard ASCII ones (\fB0\fR\(en\fB9\fR, +\fBA\fR\(en\fBZ\fR and \fBa\fR\(en\fBz\fR). Command substitutions, variable substitutions, and backslash substitutions are performed on the characters of \fIindex\fR. .TP 15 @@ -158,25 +158,25 @@ handled specially, along with the value that replaces each sequence. .RS .TP 7 \e\fBa\fR -Audible alert (bell) (0x7). +Audible alert (bell) (Unicode U+000007). .TP 7 \e\fBb\fR -Backspace (0x8). +Backspace (Unicode U+000008). .TP 7 \e\fBf\fR -Form feed (0xc). +Form feed (Unicode U+00000C). .TP 7 \e\fBn\fR -Newline (0xa). +Newline (Unicode U+00000A). .TP 7 \e\fBr\fR -Carriage-return (0xd). +Carriage-return (Unicode U+00000D). .TP 7 \e\fBt\fR -Tab (0x9). +Tab (Unicode U+000009). .TP 7 \e\fBv\fR -Vertical tab (0xb). +Vertical tab (Unicode U+00000B). .TP 7 \e\fB\fIwhiteSpace\fR . @@ -194,8 +194,9 @@ Backslash \e\fIooo\fR . The digits \fIooo\fR (one, two, or three of them) give a eight-bit octal -value for the Unicode character that will be inserted, in the range \fI000\fR -- \fI377\fR. The parser will stop just before this range overflows, or when +value for the Unicode character that will be inserted, in the range +\fI000\fR\(en\fI377\fR (i.e., the range U+000000\(enU+0000FF). +The parser will stop just before this range overflows, or when the maximum of three digits is reached. The upper bits of the Unicode character will be 0. .TP 7 @@ -203,23 +204,27 @@ character will be 0. . The hexadecimal digits \fIhh\fR (one or two of them) give an eight-bit hexadecimal value for the Unicode character that will be inserted. The upper -bits of the Unicode character will be 0. +bits of the Unicode character will be 0 (i.e., the character will be in the +range U+000000\(enU+0000FF). .TP 7 \e\fBu\fIhhhh\fR . The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a sixteen-bit hexadecimal value for the Unicode character that will be -inserted. The upper bits of the Unicode character will be 0. +inserted. The upper bits of the Unicode character will be 0 (i.e., the +character will be in the range U+000000\(enU+00FFFF). .TP 7 \e\fBU\fIhhhhhhhh\fR . The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a twenty-one-bit hexadecimal value for the Unicode character that will be -inserted, in the range U+0000..U+10FFFF. The parser will stop just +inserted, in the range U+000000\(enU+10FFFF. The parser will stop just before this range overflows, or when the maximum of eight digits is reached. The upper bits of the Unicode character will be 0. +.RS .PP -The range U+010000..U+10FFFD is reserved for the future. +The range U+010000\(enU+10FFFD is reserved for the future. +.RE .PP Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl index fe4e7ad..9c8f503 100644 --- a/tools/man2help2.tcl +++ b/tools/man2help2.tcl @@ -717,7 +717,7 @@ proc char {name} { textSetup puts -nonewline $file "\\'d7 " } - {\(em} { + {\(em} - {\(en} { textSetup puts -nonewline $file "-" } diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index bdd0079..8fd1245 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -142,6 +142,7 @@ proc process-text {text} { {\(+-} "±" \ {\(co} "©" \ {\(em} "—" \ + {\(en} "–" \ {\(fm} "′" \ {\(mu} "×" \ {\(mi} "−" \ -- cgit v0.12 From f3e8b534b38e07387ab2c0c94653917863c57411 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 16 Dec 2013 21:01:35 +0000 Subject: Refactoring work on the "chain" operation. --- generic/tclCmdIL.c | 101 +++++++++++++++++++++++++---------------------------- 1 file changed, 48 insertions(+), 53 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index fc2c367..28fb3ce 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,7 +104,7 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static CmdFrame * CmdFrameChain(CoroutineData *corPtr); +static void CmdFrameChain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1140,6 +1140,47 @@ TclInfoExistsCmd( *---------------------------------------------------------------------- */ +static void +Chain( + CmdFrame **cmdFramePtrPtr, + CoroutineData *corPtr) +{ + CmdFrame *tailPtr = corPtr->caller.cmdFramePtr; + CmdFrame *runPtr = *cmdFramePtrPtr; + int offset; + + if (tailPtr == NULL) { + return; + } + + if (runPtr == NULL) { + *cmdFramePtrPtr = tailPtr; + return; + } + + offset = tailPtr->level; + + while (runPtr->nextPtr) { + runPtr->level += offset; + runPtr = runPtr->nextPtr; + } + runPtr->level += offset; + runPtr->nextPtr = tailPtr; +} + +static void +CmdFrameChain( + CoroutineData *corPtr) +{ + CmdFrame **cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; + + corPtr = corPtr->callerEEPtr->corPtr; + if (corPtr) { + CmdFrameChain(corPtr); + Chain(cmdFramePtrPtr, corPtr); + } +} + static int InfoFrameCmd( ClientData dummy, /* Not used. */ @@ -1149,7 +1190,7 @@ InfoFrameCmd( { Interp *iPtr = (Interp *) interp; int level, topLevel, code = TCL_OK; - CmdFrame *runPtr, *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; + CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; if (objc > 2) { @@ -1157,36 +1198,13 @@ InfoFrameCmd( return TCL_ERROR; } - topLevel = ((iPtr->cmdFramePtr == NULL) - ? 0 - : iPtr->cmdFramePtr->level); - if (corPtr) { - /* - * A coroutine: must fix the level computations AND the cmdFrame chain, - * which is interrupted at the base. - */ - - CmdFrame *lastPtr = NULL; - CmdFrame *tailPtr = CmdFrameChain(corPtr); - int offset = tailPtr ? tailPtr->level : 0; - - runPtr = iPtr->cmdFramePtr; - - /* TODO - deal with overflow */ - topLevel += offset; - while (runPtr) { - runPtr->level += offset; - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr) { - lastPtr->nextPtr = tailPtr; - } else { - iPtr->cmdFramePtr = tailPtr; - } + CmdFrameChain(corPtr); + Chain(cmdFramePtrPtr, corPtr); } + topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; + if (objc == 1) { /* * Just "info frame". @@ -1234,6 +1252,7 @@ InfoFrameCmd( Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); done: + cmdFramePtrPtr = &iPtr->cmdFramePtr; while (corPtr) { CmdFrame *endPtr = corPtr->caller.cmdFramePtr; @@ -1254,30 +1273,6 @@ InfoFrameCmd( } return code; } - -static CmdFrame * -CmdFrameChain( - CoroutineData *corPtr) -{ - if (corPtr->callerEEPtr->corPtr) { - CmdFrame *tailPtr = CmdFrameChain(corPtr->callerEEPtr->corPtr); - CmdFrame *lastPtr = NULL; - CmdFrame *runPtr = corPtr->caller.cmdFramePtr; - int offset = tailPtr ? tailPtr->level : 0; - - while (runPtr) { - runPtr->level += offset; - lastPtr = runPtr; - runPtr = runPtr->nextPtr; - } - if (lastPtr) { - lastPtr->nextPtr = tailPtr; - } else { - corPtr->caller.cmdFramePtr = tailPtr; - } - } - return corPtr->caller.cmdFramePtr; -} /* *---------------------------------------------------------------------- -- cgit v0.12 From 974c8356eef0f2ca083bea7c55750256592e1f66 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 17 Dec 2013 21:19:36 +0000 Subject: Factor out the level offsetting into a final pass. Let the first pass of the "chain" operation just stitch things together and count levels. --- generic/tclCmdIL.c | 43 +++++++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 28fb3ce..e26c211 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,7 +104,7 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static void CmdFrameChain(CoroutineData *corPtr); +static int CmdFrameChain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1140,45 +1140,47 @@ TclInfoExistsCmd( *---------------------------------------------------------------------- */ -static void +static int Chain( CmdFrame **cmdFramePtrPtr, CoroutineData *corPtr) { CmdFrame *tailPtr = corPtr->caller.cmdFramePtr; CmdFrame *runPtr = *cmdFramePtrPtr; - int offset; if (tailPtr == NULL) { - return; + /* Think this can't happen. */ + return 0; } if (runPtr == NULL) { + int toReturn = tailPtr->level; + *cmdFramePtrPtr = tailPtr; - return; + tailPtr->level = 0; + return toReturn; } - offset = tailPtr->level; - while (runPtr->nextPtr) { - runPtr->level += offset; runPtr = runPtr->nextPtr; } - runPtr->level += offset; runPtr->nextPtr = tailPtr; + return tailPtr->level; } -static void +static int CmdFrameChain( CoroutineData *corPtr) { CmdFrame **cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; + int sum = 0; corPtr = corPtr->callerEEPtr->corPtr; if (corPtr) { - CmdFrameChain(corPtr); - Chain(cmdFramePtrPtr, corPtr); + sum += CmdFrameChain(corPtr); + sum += Chain(cmdFramePtrPtr, corPtr); } + return sum; } static int @@ -1189,9 +1191,10 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level, topLevel, code = TCL_OK; + int level, code = TCL_OK; CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); @@ -1199,11 +1202,19 @@ InfoFrameCmd( } if (corPtr) { - CmdFrameChain(corPtr); - Chain(cmdFramePtrPtr, corPtr); + topLevel += CmdFrameChain(corPtr); + topLevel += Chain(cmdFramePtrPtr, corPtr); } - topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; + } + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); + } + topLevel = iPtr->cmdFramePtr->level; if (objc == 1) { /* -- cgit v0.12 From 4cc4d69fe462a3661da5df84b1897b9959f6d5fd Mon Sep 17 00:00:00 2001 From: mig Date: Wed, 18 Dec 2013 15:34:39 +0000 Subject: Making the optimizer pluggable by extensions; please review for committing to trunk --- generic/tclBasic.c | 3 +++ generic/tclCompile.c | 4 +++- generic/tclCompile.h | 2 +- generic/tclInt.h | 9 ++++++++- generic/tclOptimize.c | 2 +- 5 files changed, 16 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a41351e..8ec94ca 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -526,6 +526,9 @@ Tcl_CreateInterp(void) iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; + iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6c2e2b6..525571d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -765,7 +765,9 @@ TclSetByteCodeFromAny( * instruction generator boundaries. */ - TclOptimizeBytecode(&compEnv); + if (iPtr->extra.optimizer) { + (iPtr->extra.optimizer)(&compEnv); + } /* * Invoke the compilation hook procedure if one exists. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7f62849..55dd37a 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1064,7 +1064,7 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE void TclOptimizeBytecode(CompileEnv *envPtr); +MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr); diff --git a/generic/tclInt.h b/generic/tclInt.h index 5c8dbfd..8ccfadb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1809,7 +1809,14 @@ typedef struct Interp { ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ - Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */ + union { + void (*optimizer)(void *envPtr); + Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The + * unused space in interp was repurposed for + * pluggable bytecode optimizers. The core + * contains one optimizer, which can be + * selectively overriden by extensions. */ + } extra; /* * Information related to procedures and variables. See tclProc.c and diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 3b16e6e..74de7a3 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -427,7 +427,7 @@ AdvanceJumps( void TclOptimizeBytecode( - CompileEnv *envPtr) + void *envPtr) { ConvertZeroEffectToNOP(envPtr); AdvanceJumps(envPtr); -- cgit v0.12 From 85c73dc9ce50fd5ec5798a10173e29ab8e2c1bd1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Dec 2013 18:09:09 +0000 Subject: Big simplification of the bug fix. --- generic/tclCmdIL.c | 100 ++++++++++++++++++----------------------------------- 1 file changed, 34 insertions(+), 66 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index e26c211..41c1eb6 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -104,7 +104,6 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static int CmdFrameChain(CoroutineData *corPtr); static int DictionaryCompare(const char *left, const char *right); static int IfConditionCallback(ClientData data[], Tcl_Interp *interp, int result); @@ -1140,49 +1139,6 @@ TclInfoExistsCmd( *---------------------------------------------------------------------- */ -static int -Chain( - CmdFrame **cmdFramePtrPtr, - CoroutineData *corPtr) -{ - CmdFrame *tailPtr = corPtr->caller.cmdFramePtr; - CmdFrame *runPtr = *cmdFramePtrPtr; - - if (tailPtr == NULL) { - /* Think this can't happen. */ - return 0; - } - - if (runPtr == NULL) { - int toReturn = tailPtr->level; - - *cmdFramePtrPtr = tailPtr; - tailPtr->level = 0; - return toReturn; - } - - while (runPtr->nextPtr) { - runPtr = runPtr->nextPtr; - } - runPtr->nextPtr = tailPtr; - return tailPtr->level; -} - -static int -CmdFrameChain( - CoroutineData *corPtr) -{ - CmdFrame **cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; - int sum = 0; - - corPtr = corPtr->callerEEPtr->corPtr; - if (corPtr) { - sum += CmdFrameChain(corPtr); - sum += Chain(cmdFramePtrPtr, corPtr); - } - return sum; -} - static int InfoFrameCmd( ClientData dummy, /* Not used. */ @@ -1194,27 +1150,36 @@ InfoFrameCmd( int level, code = TCL_OK; CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int topLevel = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level : 0; + int topLevel = 0; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; } - if (corPtr) { - topLevel += CmdFrameChain(corPtr); - topLevel += Chain(cmdFramePtrPtr, corPtr); + while (corPtr) { + while (*cmdFramePtrPtr) { + topLevel++; + cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); + } + if (corPtr->caller.cmdFramePtr) { + *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; + } + corPtr = corPtr->callerEEPtr->corPtr; } + topLevel += (*cmdFramePtrPtr)->level; - framePtr = iPtr->cmdFramePtr; - while (framePtr) { - framePtr->level = topLevel--; - framePtr = framePtr->nextPtr; - } - if (topLevel) { - Tcl_Panic("Broken frame level calculation"); + if (topLevel != iPtr->cmdFramePtr->level) { + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; + } + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); + } + topLevel = iPtr->cmdFramePtr->level; } - topLevel = iPtr->cmdFramePtr->level; if (objc == 1) { /* @@ -1264,22 +1229,25 @@ InfoFrameCmd( done: cmdFramePtrPtr = &iPtr->cmdFramePtr; + corPtr = iPtr->execEnvPtr->corPtr; while (corPtr) { CmdFrame *endPtr = corPtr->caller.cmdFramePtr; - if (*cmdFramePtrPtr == endPtr) { - *cmdFramePtrPtr = NULL; - } else { - CmdFrame *runPtr = *cmdFramePtrPtr; + if (endPtr) { + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; + } else { + CmdFrame *runPtr = *cmdFramePtrPtr; - while (runPtr->nextPtr != endPtr) { - runPtr->level -= endPtr->level; - runPtr = runPtr->nextPtr; + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; } - runPtr->level = 1; - runPtr->nextPtr = NULL; + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; } - cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; corPtr = corPtr->callerEEPtr->corPtr; } return code; -- cgit v0.12 From 40ee4723305e14d61c083785f230b614b2829361 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 Dec 2013 14:35:50 +0000 Subject: Add TclRegisterLiteral() to internal stub table (from "mig-optimize" branch, looks like a good idea anyway) --- generic/tclCompile.h | 2 -- generic/tclInt.decls | 6 ++++++ generic/tclIntDecls.h | 6 ++++++ generic/tclLiteral.c | 3 ++- generic/tclStubInit.c | 1 + 5 files changed, 15 insertions(+), 3 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 55dd37a..b421aaf 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1079,8 +1079,6 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *isScalarPtr); -MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, - char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index f0e907f..9f7b106 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1006,6 +1006,12 @@ declare 249 { declare 250 { void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) } + +# Allow extensions for optimization +declare 251 { + int TclRegisterLiteral(void *envPtr, + char *bytes, int length, int flags) +} ############################################################################## diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 47c6afd..f95f999 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -614,6 +614,9 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); +/* 251 */ +EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, + int length, int flags); typedef struct TclIntStubs { int magic; @@ -870,6 +873,7 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ + int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1299,6 +1303,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclDoubleDigits) /* 249 */ #define TclSetSlaveCancelFlags \ (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ +#define TclRegisterLiteral \ + (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 11da6f8..2b0cc7e 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -358,7 +358,7 @@ TclFetchLiteral( int TclRegisterLiteral( - CompileEnv *envPtr, /* Points to the CompileEnv in whose object + void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ register char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object @@ -372,6 +372,7 @@ TclRegisterLiteral( * the literal should not be shared accross * namespaces. */ { + CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 3f1c27b..e1918ef 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -551,6 +551,7 @@ static const TclIntStubs tclIntStubs = { TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ TclSetSlaveCancelFlags, /* 250 */ + TclRegisterLiteral, /* 251 */ }; static const TclIntPlatStubs tclIntPlatStubs = { -- cgit v0.12 From db7ebfac4369ff2b956e1f5d7a8865e88d4ffc50 Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 20 Dec 2013 21:59:28 +0000 Subject: remove INST_TRY_CVT_TO_NUMERIC when it is known not be necessary (cherrypick from mig-optimize) --- generic/tclCompCmds.c | 1 + generic/tclCompCmdsGR.c | 2 ++ generic/tclCompCmdsSZ.c | 1 + generic/tclCompile.h | 12 ++++++++++++ 4 files changed, 16 insertions(+) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 72b338c..b7fc9b5 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2276,6 +2276,7 @@ TclCompileForCmd( SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index d00327d..b7c89df 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -229,6 +229,7 @@ TclCompileIfCmd( SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } @@ -478,6 +479,7 @@ TclCompileIncrCmd( } else { SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); + TclClearNumConversion(envPtr); } } else { /* No incr amount given so use 1. */ haveImmValue = 1; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 754238f..3e4a55a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3071,6 +3071,7 @@ TclCompileWhileCmd( } SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b421aaf..287ab1d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1309,6 +1309,18 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } while (0) /* + * If the expr compiler finished with TRY_CONVERT, macro to remove it when the + * job is done by the following instruction. + */ + +#define TclClearNumConversion(envPtr) \ + do { \ + if (*(envPtr->codeNext - 1) == INST_TRY_CVT_TO_NUMERIC) { \ + envPtr->codeNext--; \ + } \ + } while (0) + +/* * Macros to update a (signed or unsigned) integer starting at a pointer. The * two variants depend on the number of bytes. The ANSI C "prototypes" for * these macros are: -- cgit v0.12 From db9c1d285e21754818474eaa9be0d31b7c05e7d5 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 22 Dec 2013 12:52:39 +0000 Subject: fix stack counting bug in new catch compiler, commit 62a51cdb45. --- generic/tclCompCmds.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b7fc9b5..94d3a69 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -533,7 +533,7 @@ TclCompileCatchCmd( { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range; + int resultIndex, optsIndex, range, dropScript = 0; DefineLineInformation; /* TIP #280 */ /* @@ -601,6 +601,7 @@ TclCompileCatchCmd( ExceptionRangeStarts(envPtr, range); BODY(cmdTokenPtr, 1); } else { + dropScript = 1; SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); @@ -608,6 +609,7 @@ TclCompileCatchCmd( TclEmitOpcode( INST_DUP, envPtr); TclEmitInvoke(envPtr, INST_EVAL_STK); /* drop the script */ + dropScript = 1; TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -626,8 +628,12 @@ TclCompileCatchCmd( * return code. */ - TclAdjustStackDepth(-2, envPtr); + TclAdjustStackDepth(-2 + dropScript, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); + if (dropScript) { + TclEmitOpcode( INST_POP, envPtr); + } + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); -- cgit v0.12 From 187d698fba3de0798b35122985b1616defa1f8e2 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 22 Dec 2013 13:03:19 +0000 Subject: remove duplicate statement in previous commit --- generic/tclCompCmds.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 94d3a69..d6f01a8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -601,7 +601,6 @@ TclCompileCatchCmd( ExceptionRangeStarts(envPtr, range); BODY(cmdTokenPtr, 1); } else { - dropScript = 1; SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); -- cgit v0.12 From 4c7d267ddb333ab1d5b6caddfdd8803def611dd0 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 22 Dec 2013 14:11:46 +0000 Subject: remove unnecessary messing around INST_CONTINUE and INST_BREAK: local continue/break are already converted to jumps, so that these are either caught or returned - in either case, the stacks are cleaned up properly by TEBC itself. --- generic/tclCompCmds.c | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index d6f01a8..c774a5e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -489,17 +489,14 @@ TclCompileBreakCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopBreakFixup(envPtr, auxPtr); - TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real break. */ - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_RETURN_IMM, TCL_BREAK, envPtr); - TclEmitInt4(0, envPtr); + TclEmitOpcode(INST_BREAK, envPtr); } + TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -735,17 +732,14 @@ TclCompileContinueCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopContinueFixup(envPtr, auxPtr); - TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real continue. */ - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_RETURN_IMM, TCL_CONTINUE, envPtr); - TclEmitInt4(0, envPtr); + TclEmitOpcode(INST_CONTINUE, envPtr); } + TclAdjustStackDepth(1, envPtr); return TCL_OK; } -- cgit v0.12 From 3b06f70775be10c7547c05c27e55d4ef0a65ee0c Mon Sep 17 00:00:00 2001 From: mig Date: Mon, 23 Dec 2013 11:28:12 +0000 Subject: Added new tools for managing and verifying the stack depth during compilation. Used it in some spots in the compiler and in TclCompileCatchCommand. --- generic/tclCompCmds.c | 10 ++++++++-- generic/tclCompile.c | 34 +++++++++++++++++++++++++--------- generic/tclCompile.h | 15 +++++++++++++++ 3 files changed, 48 insertions(+), 11 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c774a5e..323aa87 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -532,7 +532,8 @@ TclCompileCatchCmd( Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range, dropScript = 0; DefineLineInformation; /* TIP #280 */ - + int depth = TclGetStackDepth(envPtr); + /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. @@ -611,11 +612,13 @@ TclCompileCatchCmd( } ExceptionRangeEnds(envPtr, range); + /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, * and jump around the "error case" code. */ + TclCheckStackDepth(depth+1, envPtr); PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); @@ -624,12 +627,14 @@ TclCompileCatchCmd( * return code. */ - TclAdjustStackDepth(-2 + dropScript, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); + TclSetStackDepth(depth + dropScript, envPtr); + if (dropScript) { TclEmitOpcode( INST_POP, envPtr); } + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); @@ -678,6 +683,7 @@ TclCompileCatchCmd( } TclEmitOpcode( INST_POP, envPtr); + TclCheckStackDepth(depth+1, envPtr); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 525571d..f3e9db3 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1722,7 +1722,7 @@ TclCompileInvocation( int numWords, CompileEnv *envPtr) { - int wordIdx = 0; + int wordIdx = 0, depth = TclGetStackDepth(envPtr); DefineLineInformation; if (cmdObj) { @@ -1755,6 +1755,7 @@ TclCompileInvocation( } else { TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); } + TclCheckStackDepth(depth+1, envPtr); } static void @@ -1767,7 +1768,8 @@ CompileExpanded( { int wordIdx = 0; DefineLineInformation; - + int depth = TclGetStackDepth(envPtr); + StartExpanding(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1813,6 +1815,7 @@ CompileExpanded( */ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); + TclCheckStackDepth(depth+1, envPtr); } static int @@ -1824,6 +1827,7 @@ CompileCmdCompileProc( { int unwind = 0, incrOffset = -1; DefineLineInformation; + int depth = TclGetStackDepth(envPtr); /* * Emit of the INST_START_CMD instruction is controlled by the value of @@ -1871,6 +1875,7 @@ CompileCmdCompileProc( TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } } + TclCheckStackDepth(depth+1, envPtr); return TCL_OK; } @@ -1913,7 +1918,8 @@ CompileCommandTokens( int *clNext = envPtr->clNext; int cmdIdx = envPtr->numCommands; int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - + int depth = TclGetStackDepth(envPtr); + assert (parsePtr->numWords > 0); /* Pre-Compile */ @@ -2004,6 +2010,7 @@ CompileCommandTokens( eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; + TclCheckStackDepth(depth, envPtr); return cmdIdx; } @@ -2023,6 +2030,7 @@ TclCompileScript( * Initial value of -1 indicates this routine * has not yet generated any bytecode. */ const char *p = script; /* Where we are in our compile. */ + int depth = TclGetStackDepth(envPtr); if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2134,6 +2142,7 @@ TclCompileScript( envPtr->codeNext--; envPtr->currStackDepth++; } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -2244,6 +2253,7 @@ TclCompileTokens( #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; int *clPosition = NULL; + int depth = TclGetStackDepth(envPtr); /* * For the handling of continuation lines in literals we first check if @@ -2421,6 +2431,7 @@ TclCompileTokens( if (maxNumCL) { ckfree(clPosition); } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -3936,7 +3947,8 @@ TclEmitInvoke( ExceptionAux *auxBreakPtr, *auxContinuePtr; int arg1, arg2, wordCount = 0, expandCount = 0; int loopRange = 0, breakRange = 0, continueRange = 0; - + int cleanup, depth = TclGetStackDepth(envPtr); + /* * Parse the arguments. */ @@ -3944,30 +3956,31 @@ TclEmitInvoke( va_start(argList, opcode); switch (opcode) { case INST_INVOKE_STK1: - wordCount = arg1 = va_arg(argList, int); + wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; case INST_INVOKE_STK4: - wordCount = arg1 = va_arg(argList, int); + wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; case INST_INVOKE_REPLACE: arg1 = va_arg(argList, int); arg2 = va_arg(argList, int); wordCount = arg1 + arg2 - 1; + cleanup = arg1 + 1; break; default: Tcl_Panic("unexpected opcode"); case INST_EVAL_STK: - wordCount = 1; + wordCount = cleanup = 1; arg1 = arg2 = 0; break; case INST_RETURN_STK: - wordCount = 2; + wordCount = cleanup = 2; arg1 = arg2 = 0; break; case INST_INVOKE_EXPANDED: - wordCount = arg1 = va_arg(argList, int); + wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; expandCount = 1; break; @@ -4070,6 +4083,7 @@ TclEmitInvoke( ExceptionRangeTarget(envPtr, loopRange, breakOffset); TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); TclAddLoopBreakFixup(envPtr, auxBreakPtr); + TclAdjustStackDepth(1, envPtr); envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; @@ -4081,6 +4095,7 @@ TclEmitInvoke( ExceptionRangeTarget(envPtr, loopRange, continueOffset); TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); TclAddLoopContinueFixup(envPtr, auxContinuePtr); + TclAdjustStackDepth(1, envPtr); envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; @@ -4089,6 +4104,7 @@ TclEmitInvoke( TclFinalizeLoopExceptionRange(envPtr, loopRange); TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); } + TclCheckStackDepth(depth+1-cleanup, envPtr); } /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 287ab1d..b3c8442 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1169,6 +1169,21 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); (envPtr)->currStackDepth += (delta); \ } while (0) +#define TclGetStackDepth(envPtr) \ + ((envPtr)->currStackDepth) + +#define TclSetStackDepth(depth, envPtr) \ + (envPtr)->currStackDepth = (depth) + +#define TclCheckStackDepth(depth, envPtr) \ + do { \ + int dd = (depth); \ + if (dd != (envPtr)->currStackDepth) { \ + Tcl_Panic("bad stack depth computations: is %i, should be %i", \ + (envPtr)->currStackDepth, dd); \ + } \ + } while (0) + /* * Macro used to update the stack requirements. It is called by the macros * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. -- cgit v0.12 From 0dc5e35d3b0f0bda4129dd72223c109c778a4331 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 24 Dec 2013 18:57:46 +0000 Subject: interim commit; not yet working --- generic/tclExecute.c | 120 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 120 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 73f388b..d178934 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5157,6 +5157,126 @@ TEBCresume( int length3; Tcl_Obj *value3Ptr; + case INST_STR_REPLACE: + valuePtr = OBJ_AT_DEPTH(3); + length = Tcl_GetCharLength(valuePtr) - 1; + value3Ptr = OBJ_AT_TOS; + TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), + O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_AT_DEPTH(2), length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &toIdx) != TCL_OK) { + goto gotError; + } + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx > toIdx || fromIdx > length) { + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(1, 3, 0); + } + + if (fromIdx == 0 && toIdx == length) { + objResultPtr = value3Ptr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 4, 1); + } + + length3 = Tcl_GetCharLength(value3Ptr); + + /* + * Remove substring. In-place. + */ + + if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) { + Tcl_SetObjLength(valuePtr, fromIdx); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(1, 3, 0); + } + + // Splice in place. + + if (length3 == toIdx - fromIdx) { + unsigned char *bytes1, *bytes2; + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + // splice "in place" + if (TclIsPureByteArray(objResultPtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + } else { + } + NEXT_INST_F(1, 4, 1); + } else { + // splice "in place" + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(valuePtr); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + } else { + } + NEXT_INST_F(1, 3, 0); + } + } + + /* + * Get the unicode representation; this is where we guarantee to lose + * bytearrays. + */ + + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + length--; + + /* + * Remove substring using copying. + */ + + if (length3 == 0) { + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, + length - toIdx); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 4, 1); + } + + /* + * Splice string pieces by full copying. + */ + + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + Tcl_AppendObjToObj(objResultPtr, value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else if (Tcl_IsShared(value3Ptr)) { + objResultPtr = Tcl_DuplicateObj(value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + objResultPtr = value3Ptr; + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 4, 1); + case INST_STR_MAP: valuePtr = OBJ_AT_TOS; /* "Main" string. */ value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ -- cgit v0.12 From 7ccc50d8b67a7e642928d04bfb66ec3ee4052fbb Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Dec 2013 17:21:39 +0000 Subject: completed instruction implementation --- generic/tclCompile.c | 4 +++ generic/tclCompile.h | 3 ++- generic/tclExecute.c | 72 +++++++++++++++++++++++++++++++++++++--------------- 3 files changed, 57 insertions(+), 22 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index db97c45..5474535 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -606,6 +606,10 @@ InstructionDesc const tclInstructionTable[] = { /* [string totitle] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ + {"strReplace", 1, -3, 0, {OPERAND_NONE}}, + /* [string replace] core: replaces a non-empty range of one string + * with the contents of another. + * Stack: ... string fromIdx toIdx replacement => ... newString */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6226f7f..207b710 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -784,9 +784,10 @@ typedef struct ByteCode { #define INST_STR_UPPER 174 #define INST_STR_LOWER 175 #define INST_STR_TITLE 176 +#define INST_STR_REPLACE 177 /* The last opcode */ -#define LAST_INST_OPCODE 176 +#define LAST_INST_OPCODE 177 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d178934..3ba252f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5158,30 +5158,41 @@ TEBCresume( Tcl_Obj *value3Ptr; case INST_STR_REPLACE: - valuePtr = OBJ_AT_DEPTH(3); + value3Ptr = POP_OBJECT(); + valuePtr = OBJ_AT_DEPTH(2); length = Tcl_GetCharLength(valuePtr) - 1; - value3Ptr = OBJ_AT_TOS; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), - O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(value3Ptr))); - if (TclGetIntForIndexM(interp, OBJ_AT_DEPTH(2), length, + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { + TclDecrRefCount(value3Ptr); goto gotError; } + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); if (fromIdx < 0) { fromIdx = 0; } if (fromIdx > toIdx || fromIdx > length) { TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(1, 3, 0); + TclDecrRefCount(value3Ptr); + NEXT_INST_F(1, 0, 0); + } + + if (toIdx > length) { + toIdx = length; } if (fromIdx == 0 && toIdx == length) { - objResultPtr = value3Ptr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 4, 1); + TclDecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = value3Ptr; + TRACE_APPEND(("%.30s\n", O2S(value3Ptr))); + NEXT_INST_F(1, 0, 0); } length3 = Tcl_GetCharLength(value3Ptr); @@ -5191,35 +5202,52 @@ TEBCresume( */ if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) { + TclDecrRefCount(value3Ptr); Tcl_SetObjLength(valuePtr, fromIdx); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(1, 3, 0); + NEXT_INST_F(1, 0, 0); } - // Splice in place. + /* + * See if we can splice in place. This happens when the number of + * characters being replaced is the same as the number of characters + * in the string to be inserted. + */ if (length3 == toIdx - fromIdx) { unsigned char *bytes1, *bytes2; if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_DuplicateObj(valuePtr); - // splice "in place" if (TclIsPureByteArray(objResultPtr) && TclIsPureByteArray(value3Ptr)) { - bytes1 = Tcl_GetByteArrayFromObj(objResultPtr); - bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); } else { + ustring1 = Tcl_GetUnicode(objResultPtr); + ustring2 = Tcl_GetUnicode(value3Ptr); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); } - NEXT_INST_F(1, 4, 1); + Tcl_InvalidateStringRep(objResultPtr); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); } else { - // splice "in place" if (TclIsPureByteArray(valuePtr) && TclIsPureByteArray(value3Ptr)) { - bytes1 = Tcl_GetByteArrayFromObj(valuePtr); - bytes2 = Tcl_GetByteArrayFromObj(value3Ptr); + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); } else { + ustring1 = Tcl_GetUnicode(valuePtr); + ustring2 = Tcl_GetUnicode(value3Ptr); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); } - NEXT_INST_F(1, 3, 0); + Tcl_InvalidateStringRep(valuePtr); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); } } @@ -5246,8 +5274,9 @@ TEBCresume( objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, length - toIdx); } + TclDecrRefCount(value3Ptr); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 4, 1); + NEXT_INST_F(1, 1, 1); } /* @@ -5274,8 +5303,9 @@ TEBCresume( length - toIdx); } } + TclDecrRefCount(value3Ptr); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 4, 1); + NEXT_INST_F(1, 1, 1); case INST_STR_MAP: valuePtr = OBJ_AT_TOS; /* "Main" string. */ -- cgit v0.12 From 348916814c5f0e9bac693424abe20aefe1150869 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Dec 2013 16:59:15 +0000 Subject: use the new instruction --- generic/tclCompCmdsSZ.c | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 110476e..649a76a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -765,12 +765,25 @@ TclCompileStringReplaceCmd( } else { /* - * Too complicated to optimize, but we know the number of arguments is - * correct so we can issue a call of the "standard" implementation. + * Need to process indices at runtime. This could be because the + * indices are not constants, or because we need to resolve them to + * absolute indices to work out if a replacement is going to happen. + * In any case, to runtime it is. */ genericReplace: - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + CompileWord(envPtr, valueTokenPtr, interp, 1); + tokenPtr = TokenAfter(valueTokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + if (replacementTokenPtr != NULL) { + CompileWord(envPtr, replacementTokenPtr, interp, 4); + } else { + PUSH( ""); + } + OP( STR_REPLACE); + return TCL_OK; } } -- cgit v0.12 From 295782408448c9a034b86367186e93bc84f0ce7b Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Dec 2013 18:48:09 +0000 Subject: precondition was wrong, and needed to flush part of the string/internal rep --- generic/tclExecute.c | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3ba252f..bbc3731 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5214,7 +5214,7 @@ TEBCresume( * in the string to be inserted. */ - if (length3 == toIdx - fromIdx) { + if (length3 - 1 == toIdx - fromIdx) { unsigned char *bytes1, *bytes2; if (Tcl_IsShared(valuePtr)) { @@ -5225,10 +5225,21 @@ TEBCresume( bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); memcpy(bytes1 + fromIdx, bytes2, length3); } else { - ustring1 = Tcl_GetUnicode(objResultPtr); - ustring2 = Tcl_GetUnicode(value3Ptr); + ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); memcpy(ustring1 + fromIdx, ustring2, length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; } Tcl_InvalidateStringRep(objResultPtr); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -5240,10 +5251,21 @@ TEBCresume( bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); memcpy(bytes1 + fromIdx, bytes2, length3); } else { - ustring1 = Tcl_GetUnicode(valuePtr); - ustring2 = Tcl_GetUnicode(value3Ptr); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); memcpy(ustring1 + fromIdx, ustring2, length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; } Tcl_InvalidateStringRep(valuePtr); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); -- cgit v0.12 From 6b5eaa39012660c8f02bd6f4375089298006e987 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 08:12:52 +0000 Subject: corrected comment --- generic/tclCompCmdsSZ.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 649a76a..c4af5ce 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -700,8 +700,8 @@ TclCompileStringReplaceCmd( /* * We handle these replacements specially: first character (where - * idx1=idx2=0) and suffixes (where idx1=idx2=INDEX_END). Anything else - * and the semantics get rather screwy. + * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything + * else and the semantics get rather screwy. */ if (idx1 == 0 && idx2 == 0) { -- cgit v0.12 From 96f3f9a79df5d9ce6166a00452822684e177b743 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 08:16:21 +0000 Subject: allow generation by assembler --- generic/tclAssembly.c | 7 ++++--- generic/tclCompile.c | 8 ++++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index cd0a42d..b7bd1cd 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -453,9 +453,9 @@ static const TalInstDesc TalInstructionTable[] = { | INST_STORE_ARRAY4), 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, - {"strLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, - {"strTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, - {"strUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, + {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, + {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, + {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, @@ -466,6 +466,7 @@ static const TalInstDesc TalInstructionTable[] = { {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, + {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5474535..4ce5a66 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -594,19 +594,19 @@ InstructionDesc const tclInstructionTable[] = { * is number of values to concatenate. * Operation: push concat(stk1 stk2 ... stktop) */ - {"strUpper", 1, 0, 0, {OPERAND_NONE}}, + {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}}, /* [string toupper] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strLower", 1, 0, 0, {OPERAND_NONE}}, + {"strcaseLower", 1, 0, 0, {OPERAND_NONE}}, /* [string tolower] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strTitle", 1, 0, 0, {OPERAND_NONE}}, + {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}}, /* [string totitle] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strReplace", 1, -3, 0, {OPERAND_NONE}}, + {"strreplace", 1, -3, 0, {OPERAND_NONE}}, /* [string replace] core: replaces a non-empty range of one string * with the contents of another. * Stack: ... string fromIdx toIdx replacement => ... newString */ -- cgit v0.12 From 1749e8cdf33e8232f22acc08f9ce4301b00ba7eb Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 08:37:49 +0000 Subject: implement [namespace origin] in bytecode --- generic/tclAssembly.c | 1 + generic/tclCompCmdsGR.c | 22 ++++++++++++++++++++++ generic/tclCompile.c | 5 +++++ generic/tclCompile.h | 4 +++- generic/tclExecute.c | 26 ++++++++++++++++++++++++-- generic/tclInt.h | 3 +++ generic/tclNamesp.c | 2 +- 7 files changed, 59 insertions(+), 4 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b7bd1cd..89c286a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = { {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fc54620..df8895f 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1956,6 +1956,28 @@ TclCompileNamespaceCodeCmd( } int +TclCompileNamespaceOriginCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr); + return TCL_OK; +} + +int TclCompileNamespaceQualifiersCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4ce5a66..0732fe5 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -611,6 +611,11 @@ InstructionDesc const tclInstructionTable[] = { * with the contents of another. * Stack: ... string fromIdx toIdx replacement => ... newString */ + {"originCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Reports which command was the origin (via namespace import chain) + * of the command named on the top of the stack. + * Stack: ... cmdName => ... fullOriginalCmdName */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 207b710..fb66e90 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -786,8 +786,10 @@ typedef struct ByteCode { #define INST_STR_TITLE 176 #define INST_STR_REPLACE 177 +#define INST_ORIGIN_COMMAND 178 + /* The last opcode */ -#define LAST_INST_OPCODE 177 +#define LAST_INST_OPCODE 178 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bbc3731..14ff3dd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4402,15 +4402,37 @@ TEBCresume( TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - case INST_RESOLVE_COMMAND: { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + { + Tcl_Command cmd, origCmd; + case INST_RESOLVE_COMMAND: + cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); TclNewObj(objResultPtr); if (cmd != NULL) { Tcl_GetCommandFullName(interp, cmd, objResultPtr); } TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); + + case INST_ORIGIN_COMMAND: + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + if (cmd == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(OBJ_AT_TOS), NULL); + TRACE_APPEND(("ERROR: not command\n")); + goto gotError; + } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + TclNewObj(objResultPtr); + Tcl_GetCommandFullName(interp, origCmd, objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); + NEXT_INST_F(1, 1, 1); } case INST_TCLOO_SELF: { CallFrame *framePtr = iPtr->varFramePtr; diff --git a/generic/tclInt.h b/generic/tclInt.h index 1ad32df..94ee836 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3571,6 +3571,9 @@ MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceOriginCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index cd44455..8f2f10e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -171,7 +171,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = { {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0}, {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, -- cgit v0.12 From a8aff291ddf774fee8b1da5ccf150cc3fddae5af Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 11:40:44 +0000 Subject: Factor out the definition of the default string trim set; define it once only. --- generic/tclCmdMZ.c | 35 +--------------------------- generic/tclCompCmdsSZ.c | 32 +------------------------- generic/tclStringTrim.h | 61 +++++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 5 ++-- 4 files changed, 66 insertions(+), 67 deletions(-) create mode 100644 generic/tclStringTrim.h diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cefe850..d477216 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -18,6 +18,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include "tclStringTrim.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); @@ -31,40 +32,6 @@ static int TryPostHandler(ClientData data[], Tcl_Interp *interp, int result); static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); - -/* - * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing all Unicode space characters [TIP #413] - * - * Synch with tclCompCmdsSZ.c - */ - -#define DEFAULT_TRIM_SET \ - "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ - "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x85" /* next line (U+0085) */\ - "\xc2\xa0" /* non-breaking space (U+00a0) */\ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ - "\xe2\x80\x80" /* en quad (U+2000) */\ - "\xe2\x80\x81" /* em quad (U+2001) */\ - "\xe2\x80\x82" /* en space (U+2002) */\ - "\xe2\x80\x83" /* em space (U+2003) */\ - "\xe2\x80\x84" /* three-per-em space (U+2004) */\ - "\xe2\x80\x85" /* four-per-em space (U+2005) */\ - "\xe2\x80\x86" /* six-per-em space (U+2006) */\ - "\xe2\x80\x87" /* figure space (U+2007) */\ - "\xe2\x80\x88" /* punctuation space (U+2008) */\ - "\xe2\x80\x89" /* thin space (U+2009) */\ - "\xe2\x80\x8a" /* hair space (U+200a) */\ - "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\xa8" /* line separator (U+2028) */\ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ - "\xe2\x81\xa0" /* word joiner (U+2060) */\ - "\xe3\x80\x80" /* ideographic space (U+3000) */\ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ /* *---------------------------------------------------------------------- diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index c4af5ce..0f2790f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include "tclStringTrim.h" /* * Prototypes for procedures defined later in this file: @@ -787,37 +788,6 @@ TclCompileStringReplaceCmd( } } -/* - * Synch with tclCmdMZ.c - */ - -#define DEFAULT_TRIM_SET \ - "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ - "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x85" /* next line (U+0085) */\ - "\xc2\xa0" /* non-breaking space (U+00a0) */\ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ - "\xe2\x80\x80" /* en quad (U+2000) */\ - "\xe2\x80\x81" /* em quad (U+2001) */\ - "\xe2\x80\x82" /* en space (U+2002) */\ - "\xe2\x80\x83" /* em space (U+2003) */\ - "\xe2\x80\x84" /* three-per-em space (U+2004) */\ - "\xe2\x80\x85" /* four-per-em space (U+2005) */\ - "\xe2\x80\x86" /* six-per-em space (U+2006) */\ - "\xe2\x80\x87" /* figure space (U+2007) */\ - "\xe2\x80\x88" /* punctuation space (U+2008) */\ - "\xe2\x80\x89" /* thin space (U+2009) */\ - "\xe2\x80\x8a" /* hair space (U+200a) */\ - "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\xa8" /* line separator (U+2028) */\ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ - "\xe2\x81\xa0" /* word joiner (U+2060) */\ - "\xe3\x80\x80" /* ideographic space (U+3000) */\ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ - int TclCompileStringTrimLCmd( Tcl_Interp *interp, /* Used for error reporting. */ diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h new file mode 100644 index 0000000..63544a7 --- /dev/null +++ b/generic/tclStringTrim.h @@ -0,0 +1,61 @@ +/* + * tclStringTrim.h -- + * + * This file contains the definition of what characters are to be trimmed + * from a string by [string trim] by default. It's only needed by Tcl's + * implementation; it does not form a public or private API at all. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 Scriptics Corporation. + * Copyright (c) 2002 ActiveState Corporation. + * Copyright (c) 2003-2013 Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef TCL_STRING_TRIM_H +#define TCL_STRING_TRIM_H + +/* + * Default set of characters to trim in [string trim] and friends. This is a + * UTF-8 literal string containing all Unicode space characters. [TIP #413] + */ + +#define DEFAULT_TRIM_SET \ + "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ + "\xc0\x80" /* nul (U+0000) */\ + "\xc2\x85" /* next line (U+0085) */\ + "\xc2\xa0" /* non-breaking space (U+00a0) */\ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ + "\xe2\x80\x80" /* en quad (U+2000) */\ + "\xe2\x80\x81" /* em quad (U+2001) */\ + "\xe2\x80\x82" /* en space (U+2002) */\ + "\xe2\x80\x83" /* em space (U+2003) */\ + "\xe2\x80\x84" /* three-per-em space (U+2004) */\ + "\xe2\x80\x85" /* four-per-em space (U+2005) */\ + "\xe2\x80\x86" /* six-per-em space (U+2006) */\ + "\xe2\x80\x87" /* figure space (U+2007) */\ + "\xe2\x80\x88" /* punctuation space (U+2008) */\ + "\xe2\x80\x89" /* thin space (U+2009) */\ + "\xe2\x80\x8a" /* hair space (U+200a) */\ + "\xe2\x80\x8b" /* zero width space (U+200b) */\ + "\xe2\x80\xa8" /* line separator (U+2028) */\ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ + "\xe2\x81\xa0" /* word joiner (U+2060) */\ + "\xe3\x80\x80" /* ideographic space (U+3000) */\ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ + +#endif /* TCL_STRING_TRIM_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/unix/Makefile.in b/unix/Makefile.in index a0d0c87..2b8e6b9 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1035,6 +1035,7 @@ IOHDR=$(GENERIC_DIR)/tclIO.h MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h PARSEHDR=$(GENERIC_DIR)/tclParse.h NREHDR=$(GENERIC_DIR)/tclInt.h +TRIMHDR=$(GENERIC_DIR)/tclStringTrim.h regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ @@ -1080,7 +1081,7 @@ tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c -tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) +tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c tclDate.o: $(GENERIC_DIR)/tclDate.c @@ -1092,7 +1093,7 @@ tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c -tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) +tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsSZ.c tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(COMPILEHDR) -- cgit v0.12 From 97a9d67a6651017b5b10fe38078583043b1cb1d7 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2013 11:56:54 +0000 Subject: put the other definition of a trim set in the header file too --- generic/tclCompCmds.c | 7 ------- generic/tclStringTrim.h | 7 +++++++ generic/tclUtil.c | 16 ++++++++++------ unix/Makefile.in | 2 +- 4 files changed, 18 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 51ac9ed..05b6d07 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -65,13 +65,6 @@ const AuxDataType tclDictUpdateInfoType = { FreeDictUpdateInfo, /* freeProc */ PrintDictUpdateInfo /* printProc */ }; - -/* - * The definition of what whitespace is stripped when [concat]enating. Must be - * kept in synch with tclUtil.c - */ - -#define CONCAT_WS " \f\v\r\t\n" /* *---------------------------------------------------------------------- diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h index 63544a7..669f10b 100644 --- a/generic/tclStringTrim.h +++ b/generic/tclStringTrim.h @@ -50,6 +50,13 @@ "\xe3\x80\x80" /* ideographic space (U+3000) */\ "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +/* + * The whitespace trimming set used when [concat]enating. This is a subset of + * the above, and deliberately so. + */ + +#define CONCAT_TRIM_SET " \f\v\r\t\n" + #endif /* TCL_STRING_TRIM_H */ /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index b089132..2d00adf 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -14,6 +14,7 @@ #include "tclInt.h" #include "tclParse.h" +#include "tclStringTrim.h" #include /* @@ -1768,8 +1769,7 @@ TclTrimLeft( */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS " \f\v\r\t\n" -#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( @@ -1825,7 +1825,8 @@ Tcl_Concat( * Trim away the leading whitespace. */ - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); element += trim; elemLength -= trim; @@ -1834,7 +1835,8 @@ Tcl_Concat( * a final backslash character. */ - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; @@ -1959,7 +1961,8 @@ Tcl_ConcatObj( * Trim away the leading whitespace. */ - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); element += trim; elemLength -= trim; @@ -1968,7 +1971,8 @@ Tcl_ConcatObj( * a final backslash character. */ - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; diff --git a/unix/Makefile.in b/unix/Makefile.in index 2b8e6b9..71851e6 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1309,7 +1309,7 @@ tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c tclTrace.o: $(GENERIC_DIR)/tclTrace.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c -tclUtil.o: $(GENERIC_DIR)/tclUtil.c $(PARSEHDR) +tclUtil.o: $(GENERIC_DIR)/tclUtil.c $(PARSEHDR) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c tclUtf.o: $(GENERIC_DIR)/tclUtf.c $(GENERIC_DIR)/tclUniData.c -- cgit v0.12 From 30c59f7cd7e2c15c29aeea8b6754f97682d07c28 Mon Sep 17 00:00:00 2001 From: mig Date: Tue, 31 Dec 2013 12:14:50 +0000 Subject: clarify the resume sequence in TEBCresume; make checkInterp a local variable, remove it from the saved struct --- generic/tclExecute.c | 42 ++++++++++++++---------------------------- 1 file changed, 14 insertions(+), 28 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9261f19..657b5b2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -178,7 +178,6 @@ typedef struct TEBCdata { ptrdiff_t *catchTop; /* this level: they record the state when a */ int cleanup; /* new codePtr was received for NR */ Tcl_Obj *auxObjList; /* execution. */ - int checkInterp; CmdFrame cmdFrame; void *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as @@ -1992,7 +1991,6 @@ TclNRExecuteByteCode( TD->catchTop = initCatchTop; TD->cleanup = 0; TD->auxObjList = NULL; - TD->checkInterp = 0; /* * TIP #280: Initialize the frame. Do not push it yet: it will be pushed @@ -2078,9 +2076,6 @@ TEBCresume( #define auxObjList (TD->auxObjList) #define catchTop (TD->catchTop) #define codePtr (TD->codePtr) -#define checkInterp (TD->checkInterp) - /* Indicates when a check of interp readyness is - * necessary. Set by CACHE_STACK_INFO() */ /* * Globals: variables that store state, must remain valid at all times. @@ -2098,6 +2093,8 @@ TEBCresume( int cleanup = 0; Tcl_Obj *objResultPtr; + int checkInterp; /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ /* * Locals - variables that are used within opcodes or bounded sections of @@ -2129,10 +2126,18 @@ TEBCresume( } #endif - if (data[1] /* resume from invocation */) { + if (!data[1]) { + /* bytecode is starting from scratch */ + checkInterp = 0; + goto cleanup0; + } else { + /* resume from invocation */ + CACHE_STACK_INFO(); if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; + goto abnormalReturn; } + NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); if (bcFramePtr->cmdObj) { Tcl_DecrRefCount(bcFramePtr->cmdObj); @@ -2148,7 +2153,6 @@ TEBCresume( codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - CACHE_STACK_INFO(); if (result == TCL_OK) { /* * Push the call's object result and continue execution with the @@ -2180,30 +2184,12 @@ TEBCresume( } #endif NEXT_INST_V(0, cleanup, -1); + } else { + pc--; + goto processExceptionReturn; } - - /* - * Result not TCL_OK: fall through - */ } - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - goto abnormalReturn; - } - - if (result != TCL_OK) { - pc--; - goto processExceptionReturn; - } - - /* - * Loop executing instructions until a "done" instruction, a TCL_RETURN, - * or some error. - */ - - goto cleanup0; - /* * Targets for standard instruction endings; unrolled for speed in the * most frequent cases (instructions that consume up to two stack -- cgit v0.12 From 0fa7053fd789959b2c0f1efcb486958e16e22ba0 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2013 16:26:55 +0000 Subject: more peephole optimizations in TEBC, and better instruction execution traces --- generic/tclExecute.c | 360 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 212 insertions(+), 148 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 657b5b2..6d98cea 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -384,6 +384,8 @@ VarHashCreateVar( printf a; \ break; \ } +# define TRACE_ERROR(interp) \ + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ @@ -400,6 +402,7 @@ VarHashCreateVar( #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) # define TRACE_APPEND(a) +# define TRACE_ERROR(interp) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ @@ -2745,9 +2748,9 @@ TEBCresume( */ objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(objPtr))); if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } (void) POP_OBJECT(); @@ -2791,6 +2794,7 @@ TEBCresume( PUSH_OBJECT(objv[i]); } + TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } @@ -3135,7 +3139,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } cleanup = 1; @@ -3161,7 +3165,7 @@ TEBCresume( TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } @@ -3188,7 +3192,7 @@ TEBCresume( part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -3337,7 +3341,7 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } cleanup = ((part2Ptr == NULL)? 2 : 3); @@ -3387,7 +3391,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } goto doCallPtrSetVar; @@ -3435,7 +3439,7 @@ TEBCresume( part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } #ifndef TCL_COMPILE_DEBUG @@ -3512,7 +3516,7 @@ TEBCresume( if (!varPtr) { Tcl_AddErrorInfo(interp, "\n (reading value of variable to increment)"); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3538,7 +3542,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3650,8 +3654,7 @@ TEBCresume( TclNewLongObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); @@ -3688,8 +3691,7 @@ TEBCresume( } if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); @@ -3700,8 +3702,7 @@ TEBCresume( CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -3722,6 +3723,8 @@ TEBCresume( */ case INST_EXIST_SCALAR: + cleanup = 0; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -3738,16 +3741,11 @@ TEBCresume( varPtr = NULL; } } - - /* - * Tricky! Arrays always exist. - */ - - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 0, 1); + goto afterExistsPeephole; case INST_EXIST_ARRAY: + cleanup = 1; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); @@ -3758,7 +3756,7 @@ TEBCresume( if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (!varPtr || !ReadTraced(varPtr)) { - goto doneExistArray; + goto afterExistsPeephole; } } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", @@ -3775,13 +3773,11 @@ TEBCresume( varPtr = NULL; } } - doneExistArray: - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 1, 1); + goto afterExistsPeephole; case INST_EXIST_ARRAY_STK: cleanup = 2; + pcAdjustment = 1; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); @@ -3789,6 +3785,7 @@ TEBCresume( case INST_EXIST_STK: cleanup = 1; + pcAdjustment = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("\"%.30s\" => ", O2S(part1Ptr))); @@ -3808,9 +3805,31 @@ TEBCresume( varPtr = NULL; } } - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + afterExistsPeephole: { + int found = (varPtr && !TclIsVarUndefined(varPtr)); + + pc += pcAdjustment; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_V((found? 2 : TclGetInt1AtPtr(pc+1)), cleanup, 0); + case INST_JUMP_TRUE1: + NEXT_INST_V((found? TclGetInt1AtPtr(pc+1) : 2), cleanup, 0); + case INST_JUMP_FALSE4: + NEXT_INST_V((found? 5 : TclGetInt4AtPtr(pc+1)), cleanup, 0); + case INST_JUMP_TRUE4: + NEXT_INST_V((found? TclGetInt4AtPtr(pc+1) : 5), cleanup, 0); + } +#endif + objResultPtr = TCONST(found ? 1 : 0); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); + NEXT_INST_V(0, cleanup, 1); + } /* * End of INST_EXIST instructions. @@ -3828,7 +3847,7 @@ TEBCresume( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); + TRACE(("%s %u => ", (flags?"normal":"noerr"), opnd)); if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { /* * No errors, no traces, no searches: just make the variable cease @@ -3841,6 +3860,7 @@ TEBCresume( goto slowUnsetScalar; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 0, 0); } @@ -3861,7 +3881,7 @@ TEBCresume( while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%s %u \"%.30s\"\n", + TRACE(("%s %u \"%.30s\" => ", (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); @@ -3877,12 +3897,14 @@ TEBCresume( goto slowUnsetArray; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { /* * Don't need to do anything here. */ + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } } @@ -3906,7 +3928,7 @@ TEBCresume( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), + TRACE(("%s \"%.30s(%.30s)\" => ", (flags?"normal":"noerr"), O2S(part1Ptr), O2S(part2Ptr))); goto doUnsetStk; @@ -3915,7 +3937,7 @@ TEBCresume( cleanup = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); + TRACE(("%s \"%.30s\" => ", (flags?"normal":"noerr"), O2S(part1Ptr))); doUnsetStk: DECACHE_STACK_INFO(); @@ -3924,11 +3946,12 @@ TEBCresume( goto errorInUnset; } CACHE_STACK_INFO(); + TRACE_APPEND(("OK\n")); NEXT_INST_V(2, cleanup, 0); errorInUnset: CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; /* @@ -3990,8 +4013,7 @@ TEBCresume( TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); CACHE_STACK_INFO(); if (result == TCL_ERROR) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -4024,7 +4046,7 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } doArrayMake: @@ -4037,8 +4059,7 @@ TEBCresume( TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - TRACE_APPEND(("ERROR: bad array ref: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TclSetVarArray(varPtr); @@ -4066,9 +4087,11 @@ TEBCresume( Namespace *savedNsPtr; case INST_UPVAR: - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { + TRACE_ERROR(interp); goto gotError; } @@ -4083,13 +4106,16 @@ TEBCresume( /*createPart2*/ 1, &varPtr); iPtr->varFramePtr = savedFramePtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4104,16 +4130,18 @@ TEBCresume( /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_VARIABLE: - TRACE(("variable ")); + TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } @@ -4131,7 +4159,7 @@ TEBCresume( * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1);; + opnd = TclGetInt4AtPtr(pc+1); varPtr = LOCAL(opnd); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { @@ -4143,6 +4171,7 @@ TEBCresume( Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { + TRACE_APPEND(("already linked\n")); NEXT_INST_F(5, 1, 0); } if (TclIsVarInHash(linkPtr)) { @@ -4159,6 +4188,7 @@ TEBCresume( } } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4167,6 +4197,7 @@ TEBCresume( * variables - and [variable] did not push it at all. */ + TRACE_APPEND(("link made\n")); NEXT_INST_F(5, 1, 0); } @@ -4213,31 +4244,29 @@ TEBCresume( doCondJump: valuePtr = OBJ_AT_TOS; + TRACE(("%d => ", jmpOffset[ + (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ - ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) - ? 0 : 1]), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], - O2S(valuePtr), + TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], - O2S(valuePtr), + TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); } } @@ -4256,7 +4285,7 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); + TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); @@ -4351,9 +4380,8 @@ TEBCresume( register CallFrame *framePtr = iPtr->varFramePtr; register CallFrame *rootFramePtr = iPtr->rootFramePtr; - valuePtr = OBJ_AT_TOS; - if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(OBJ_AT_TOS)), Tcl_GetObjResult(interp)); goto gotError; } @@ -4366,11 +4394,11 @@ TEBCresume( /* Empty loop body */ } if (framePtr == rootFramePtr) { - Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), - "\"", NULL); - TRACE_APPEND(("ERROR: bad level\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); + TRACE_ERROR(interp); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(valuePtr), NULL); + TclGetString(OBJ_AT_TOS), NULL); goto gotError; } objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); @@ -4466,19 +4494,19 @@ TEBCresume( NEXT_INST_V(5, opnd, 1); case INST_LIST_LENGTH: - valuePtr = OBJ_AT_TOS; - if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Extract the desired list element. @@ -4496,8 +4524,7 @@ TEBCresume( objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); if (!objResultPtr) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4505,8 +4532,7 @@ TEBCresume( * Stash the list element on the stack. */ - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode @@ -4518,6 +4544,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); + TRACE(("\%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list @@ -4525,8 +4552,7 @@ TEBCresume( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4549,8 +4575,7 @@ TEBCresume( TclNewObj(objResultPtr); } - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), - objResultPtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ @@ -4565,10 +4590,11 @@ TEBCresume( * Do the 'lindex' operation. */ + TRACE(("%d => ", opnd)); objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), numIndices, &OBJ_AT_DEPTH(numIndices - 1)); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4576,7 +4602,7 @@ TEBCresume( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd, -1); case INST_LSET_FLAT: @@ -4586,6 +4612,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc + 1); numIndices = opnd - 2; + TRACE(("%d => ", opnd)); /* * Get the old value of variable, and remove the stack ref. This is @@ -4604,7 +4631,7 @@ TEBCresume( objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4612,7 +4639,7 @@ TEBCresume( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, numIndices+1, -1); case INST_LSET_LIST: /* 'lset' with 4 args */ @@ -4632,6 +4659,8 @@ TEBCresume( valuePtr = OBJ_AT_TOS; value2Ptr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(value2Ptr), O2S(valuePtr), O2S(objPtr))); /* * Compute the new variable value. @@ -4639,8 +4668,7 @@ TEBCresume( objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); if (!objResultPtr) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4648,7 +4676,7 @@ TEBCresume( * Set result. */ - TRACE(("=> %s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in @@ -4661,6 +4689,8 @@ TEBCresume( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); + TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), + TclGetInt4AtPtr(pc+5))); /* * Get the contents of the list, making sure that it really is a list @@ -4668,8 +4698,7 @@ TEBCresume( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4726,8 +4755,6 @@ TEBCresume( List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; if (listPtr->refCount == 1) { - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); for (index=toIdx+1; index ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -4753,9 +4779,9 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; s1 = TclGetStringFromObj(valuePtr, &s1len); + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } match = 0; @@ -4786,7 +4812,7 @@ TEBCresume( match = !match; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -4818,7 +4844,7 @@ TEBCresume( objResultPtr = Tcl_DuplicateObj(valuePtr); if (Tcl_ListObjAppendList(interp, objResultPtr, value2Ptr) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(objResultPtr); goto gotError; } @@ -4826,7 +4852,7 @@ TEBCresume( NEXT_INST_F(1, 2, 1); } else { if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); @@ -4980,6 +5006,7 @@ TEBCresume( case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr))); /* * Get char length to calulate what 'end' means. @@ -4987,6 +5014,7 @@ TEBCresume( length = Tcl_GetCharLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -5012,18 +5040,18 @@ TEBCresume( objResultPtr = Tcl_NewStringObj(buf, length); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_STR_RANGE: - TRACE(("\"%.20s\" %s %s =>", + TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, &fromIdx) != TCL_OK || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -5626,8 +5654,7 @@ TEBCresume( TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -5799,8 +5826,7 @@ TEBCresume( TRACE_APPEND(("EXPONENT OF ZERO\n")); goto exponOfZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -6055,6 +6081,7 @@ TEBCresume( */ opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; @@ -6081,8 +6108,8 @@ TEBCresume( listVarPtr = LOCAL(listTmpIndex); listPtr = listVarPtr->value.objPtr; if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (listLen > iterNum * numVars) { @@ -6137,9 +6164,9 @@ TEBCresume( if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); + TRACE_APPEND(( + "ERROR init. index temp %d: %s\n", + varIndex, O2S(Tcl_GetObjResult(interp)))); TclDecrRefCount(listPtr); goto gotError; } @@ -6151,7 +6178,7 @@ TEBCresume( listTmpIndex++; } } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, + TRACE_APPEND(("%d lists, iter %d, %s loop\n", opnd, numLists, iterNum, (continueLoop? "continue" : "exit"))); /* @@ -6320,10 +6347,14 @@ TEBCresume( NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); } +#ifdef TCL_COMPILE_DEBUG + NEXT_INST_F(1, 0, 0); +#else /* * FALL THROUGH */ pc++; +#endif case INST_FOREACH_END: /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ @@ -6440,6 +6471,7 @@ TEBCresume( case INST_DICT_GET: case INST_DICT_EXISTS: { register Tcl_Interp *interp2 = interp; + register int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); @@ -6452,7 +6484,8 @@ TEBCresume( &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { if (*pc == INST_DICT_EXISTS) { - goto dictNotExists; + found = 0; + goto afterDictExists; } TRACE_WITH_OBJ(( "ERROR tracing dictionary path into \"%s\": ", @@ -6464,34 +6497,56 @@ TEBCresume( if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { if (*pc == INST_DICT_EXISTS) { - objResultPtr = TCONST(objResultPtr ? 1 : 0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + found = (objResultPtr ? 1 : 0); + goto afterDictExists; } - if (objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + if (!objResultPtr) { + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; } - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } else if (*pc != INST_DICT_EXISTS) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; } else { - if (*pc == INST_DICT_EXISTS) { - dictNotExists: - objResultPtr = TCONST(0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + found = 0; } - goto gotError; + afterDictExists: +#ifndef TCL_COMPILE_DEBUG + /* + * The INST_DICT_EXISTS instruction is usually followed by a + * conditional jump, so we can take advantage of this to do some + * peephole optimization (note that we're careful to not close out + * someone doing something else). + */ + + pc += 5; + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_V((found ? 2 : TclGetInt1AtPtr(pc+1)), opnd+1, 0); + case INST_JUMP_FALSE4: + NEXT_INST_V((found ? 5 : TclGetInt4AtPtr(pc+1)), opnd+1, 0); + case INST_JUMP_TRUE1: + NEXT_INST_V((found ? TclGetInt1AtPtr(pc+1) : 2), opnd+1, 0); + case INST_JUMP_TRUE4: + NEXT_INST_V((found ? TclGetInt4AtPtr(pc+1) : 5), opnd+1, 0); + default: + pc -= 5; + /* fall through to non-debug handling */ + } +#endif + TRACE_APPEND(("%d\n", found)); + objResultPtr = TCONST(found); + NEXT_INST_V(5, opnd+1, 1); } case INST_DICT_SET: @@ -6588,8 +6643,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6598,7 +6652,7 @@ TEBCresume( NEXT_INST_V(10, cleanup, 0); } #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(9, cleanup, 1); case INST_DICT_APPEND: @@ -6631,6 +6685,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6679,6 +6734,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); @@ -6688,6 +6744,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6724,8 +6781,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6745,6 +6801,7 @@ TEBCresume( if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { ckfree(searchPtr); + TRACE_ERROR(interp); goto gotError; } TclNewObj(statePtr); @@ -6814,12 +6871,12 @@ TEBCresume( case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => \n", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { @@ -6828,11 +6885,13 @@ TEBCresume( TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { + TRACE_ERROR(interp); goto gotError; } } if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } if (length != duiPtr->length) { @@ -6841,6 +6900,7 @@ TEBCresume( for (i=0 ; ivarIndices[i]); @@ -6856,21 +6916,23 @@ TEBCresume( valuePtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); + TRACE_ERROR(interp); goto gotError; } CACHE_STACK_INFO(); } + TRACE_APPEND(("OK\n")); NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { @@ -6879,11 +6941,13 @@ TEBCresume( CACHE_STACK_INFO(); } if (dictPtr == NULL) { + TRACE_APPEND(("storage was unset\n")); NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } allocdict = Tcl_IsShared(dictPtr); @@ -6929,26 +6993,26 @@ TEBCresume( if (allocdict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } } + TRACE_APPEND(("written back\n")); NEXT_INST_F(9, 1, 0); case INST_DICT_EXPAND: dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; + TRACE(("%.30s %.30s =>", O2S(dictPtr), O2S(listPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } - TRACE((" => ")); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -6959,14 +7023,14 @@ TEBCresume( TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; } varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; } @@ -6976,7 +7040,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(keysPtr); if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6990,7 +7054,7 @@ TEBCresume( TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } while (TclIsVarLink(varPtr)) { @@ -7001,7 +7065,7 @@ TEBCresume( objc, objv, keysPtr); CACHE_STACK_INFO(); if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("OK\n")); -- cgit v0.12 From d7977520d36dfb4586c6ae79c3fa3e6fc33f3b26 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2013 17:28:16 +0000 Subject: more cleaning up of error-case instruction tracing --- generic/tclExecute.c | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 82808f6..82daad7 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4391,12 +4391,11 @@ TEBCresume( register CallFrame *framePtr = iPtr->varFramePtr; register CallFrame *rootFramePtr = iPtr->rootFramePtr; + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(OBJ_AT_TOS)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } - TRACE(("%d => ", level)); if (level <= 0) { level += framePtr->level; } @@ -5204,6 +5203,7 @@ TEBCresume( || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { TclDecrRefCount(value3Ptr); + TRACE_ERROR(interp); goto gotError; } TclDecrRefCount(OBJ_AT_TOS); @@ -5587,6 +5587,7 @@ TEBCresume( cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Compile and match the regular expression. @@ -5597,23 +5598,17 @@ TEBCresume( Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); if (regExpr == NULL) { - goto regexpFailure; + TRACE_ERROR(interp); + goto gotError; } - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif + TRACE_ERROR(interp); goto gotError; } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. -- cgit v0.12 From 16764976baae41730e54afdca94fdf9fd18dceed Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2013 23:34:57 +0000 Subject: another jump peephole, this time with string comparisons --- generic/tclExecute.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6d98cea..c7d0918 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4987,6 +4987,20 @@ TEBCresume( break; } } + +#ifndef TCL_COMPILE_DEBUG + switch (*(pc+1)) { + case INST_JUMP_FALSE1: + NEXT_INST_F((match? 3 : TclGetInt1AtPtr(pc+2)+1), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((match? TclGetInt1AtPtr(pc+2)+1 : 3), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((match? 6 : TclGetInt4AtPtr(pc+2)+1), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((match? TclGetInt4AtPtr(pc+2)+1 : 6), 2, 0); + } +#endif + if (match < 0) { TclNewIntObj(objResultPtr, -1); } else { -- cgit v0.12 From 5f9ff26a4f64abc4d9b6c5e2f5b58e522f2b9537 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jan 2014 16:19:14 +0000 Subject: factor out a common peephole stanza --- generic/tclExecute.c | 216 +++++++++++++++++++-------------------------------- 1 file changed, 79 insertions(+), 137 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c7d0918..411cb8b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -319,6 +319,70 @@ VarHashCreateVar( } \ } while (0) +#ifndef TCL_COMPILE_DEBUG +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F(0, (cleanup), 1); \ + } \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V(0, (cleanup), 1); \ + } \ + } while (0) +#else /* TCL_COMPILE_DEBUG */ +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F((pcAdjustment), (cleanup), 1); \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V((pcAdjustment), (cleanup), 1); \ + } while (0) +#endif + /* * Macros used to cache often-referenced Tcl evaluation stack information * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() @@ -3813,22 +3877,8 @@ TEBCresume( afterExistsPeephole: { int found = (varPtr && !TclIsVarUndefined(varPtr)); - pc += pcAdjustment; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_V((found? 2 : TclGetInt1AtPtr(pc+1)), cleanup, 0); - case INST_JUMP_TRUE1: - NEXT_INST_V((found? TclGetInt1AtPtr(pc+1) : 2), cleanup, 0); - case INST_JUMP_FALSE4: - NEXT_INST_V((found? 5 : TclGetInt4AtPtr(pc+1)), cleanup, 0); - case INST_JUMP_TRUE4: - NEXT_INST_V((found? TclGetInt4AtPtr(pc+1) : 5), cleanup, 0); - } -#endif - objResultPtr = TCONST(found ? 1 : 0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(0, cleanup, 1); + TRACE_APPEND(("%d\n", found ? 1 : 0)); + JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup); } /* @@ -4820,21 +4870,7 @@ TEBCresume( * for branching. */ - pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 1, 2); case INST_LIST_CONCAT: value2Ptr = OBJ_AT_TOS; @@ -4988,27 +5024,10 @@ TEBCresume( } } -#ifndef TCL_COMPILE_DEBUG - switch (*(pc+1)) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 3 : TclGetInt1AtPtr(pc+2)+1), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+2)+1 : 3), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 6 : TclGetInt4AtPtr(pc+2)+1), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+2)+1 : 6), 2, 0); - } -#endif + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), + (match < 0 ? -1 : match > 0 : 1 : 0))); - if (match < 0) { - TclNewIntObj(objResultPtr, -1); - } else { - objResultPtr = TCONST(match > 0); - } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; @@ -5268,21 +5287,7 @@ TEBCresume( * Peep-hole optimisation: if you're about to jump, do jump from here. */ - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 2, 2); case INST_REGEXP: cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ @@ -5321,21 +5326,7 @@ TEBCresume( * Adjustment is 2 due to the nocase byte. */ - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 2, 2); } /* @@ -5433,21 +5424,7 @@ TEBCresume( */ foundResult: - pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(iResult); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(iResult, 1, 2); } case INST_MOD: @@ -6535,7 +6512,8 @@ TEBCresume( found = 0; } afterDictExists: -#ifndef TCL_COMPILE_DEBUG + TRACE_APPEND(("%d\n", found)); + /* * The INST_DICT_EXISTS instruction is usually followed by a * conditional jump, so we can take advantage of this to do some @@ -6543,24 +6521,7 @@ TEBCresume( * someone doing something else). */ - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_V((found ? 2 : TclGetInt1AtPtr(pc+1)), opnd+1, 0); - case INST_JUMP_FALSE4: - NEXT_INST_V((found ? 5 : TclGetInt4AtPtr(pc+1)), opnd+1, 0); - case INST_JUMP_TRUE1: - NEXT_INST_V((found ? TclGetInt1AtPtr(pc+1) : 2), opnd+1, 0); - case INST_JUMP_TRUE4: - NEXT_INST_V((found ? TclGetInt4AtPtr(pc+1) : 5), opnd+1, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - TRACE_APPEND(("%d\n", found)); - objResultPtr = TCONST(found); - NEXT_INST_V(5, opnd+1, 1); + JUMP_PEEPHOLE_V(found, 5, opnd+1); } case INST_DICT_SET: @@ -6851,8 +6812,9 @@ TEBCresume( PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); -#ifndef TCL_COMPILE_DEBUG /* * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always * followed by a conditional jump, so we can take advantage of this to @@ -6860,27 +6822,7 @@ TEBCresume( * out someone doing something else). */ - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - objResultPtr = TCONST(done); - /* TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); + JUMP_PEEPHOLE_F(done, 5, 0); case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); -- cgit v0.12 From 019149dcdede4ca73450dc77d0ec916ed5757ac2 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 03:10:43 +0000 Subject: more fixes to instruction tracing; ensure all places that need DECACHE_STACK_INFO have it. jan.nijtmans: Branch moved aside an hidden, so future bisects are not affected by this branch mistakes. --- generic/tclExecute.c | 213 +++++++++++++++++++++++++++++---------------------- 1 file changed, 123 insertions(+), 90 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 411cb8b..37588c5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2220,41 +2220,41 @@ TEBCresume( codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - if (result == TCL_OK) { - /* - * Push the call's object result and continue execution with the - * next instruction. - */ + if (result != TCL_OK) { + pc--; + goto processExceptionReturn; + } - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); + /* + * Push the call's object result and continue execution with the next + * instruction. + */ - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult to - * avoid any side effects caused by the resetting of errorInfo and - * errorCode [Bug 804681], which are not needed here. We chose - * instead to manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps - * the refCount it had in its role of iPtr->objResultPtr. - */ + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); - objResultPtr = Tcl_GetObjResult(interp); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; + /* + * Reset the interp's result to avoid possible duplications of large + * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any + * side effects caused by the resetting of errorInfo and errorCode + * [Bug 804681], which are not needed here. We chose instead to + * manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps the + * refCount it had in its role of iPtr->objResultPtr. + */ + + objResultPtr = Tcl_GetObjResult(interp); + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; #ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - TclDecrRefCount(objResultPtr); - NEXT_INST_V(1, cleanup, 0); - } -#endif - NEXT_INST_V(0, cleanup, -1); - } else { - pc--; - goto processExceptionReturn; + if (*pc == INST_POP) { + TclDecrRefCount(objResultPtr); + NEXT_INST_V(1, cleanup, 0); } +#endif + NEXT_INST_V(0, cleanup, -1); } /* @@ -2474,8 +2474,10 @@ TEBCresume( TRACE_APPEND(("ERROR: yield outside coroutine\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yield can only be called in a coroutine", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); + CACHE_STACK_INFO(); goto gotError; } @@ -2520,7 +2522,9 @@ TEBCresume( TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + CACHE_STACK_INFO(); goto gotError; } @@ -2598,7 +2602,7 @@ TEBCresume( case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); case INST_REVERSE: { @@ -2613,6 +2617,7 @@ TEBCresume( *b = tmpPtr; a++; b--; } + TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } @@ -2783,6 +2788,7 @@ TEBCresume( objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); + TRACE(("=> mark depth as %d\n", CURR_DEPTH)); NEXT_INST_F(1, 0, 0); case INST_EXPAND_DROP: @@ -2799,6 +2805,7 @@ TEBCresume( /* Ugly abuse! */ starting = 1; #endif + TRACE(("=> drop %d items\n", objc)); NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { @@ -3578,8 +3585,10 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); if (!varPtr) { + DECACHE_STACK_INFO(); Tcl_AddErrorInfo(interp, "\n (reading value of variable to increment)"); + CACHE_STACK_INFO(); TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; @@ -3897,7 +3906,7 @@ TEBCresume( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%s %u => ", (flags?"normal":"noerr"), opnd)); + TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd)); if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { /* * No errors, no traces, no searches: just make the variable cease @@ -3978,7 +3987,7 @@ TEBCresume( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\" => ", (flags?"normal":"noerr"), + TRACE(("%s \"%.30s(%.30s)\" => ", (flags ? "normal" : "noerr"), O2S(part1Ptr), O2S(part2Ptr))); goto doUnsetStk; @@ -3987,7 +3996,8 @@ TEBCresume( cleanup = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\" => ", (flags?"normal":"noerr"), O2S(part1Ptr))); + TRACE(("%s \"%.30s\" => ", (flags ? "normal" : "noerr"), + O2S(part1Ptr))); doUnsetStk: DECACHE_STACK_INFO(); @@ -4010,7 +4020,7 @@ TEBCresume( case INST_DICT_DONE: opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u\n", opnd)); + TRACE(("%u => OK\n", opnd)); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -4108,7 +4118,9 @@ TEBCresume( TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } @@ -4447,8 +4459,10 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); TRACE_ERROR(interp); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); goto gotError; } objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); @@ -4475,7 +4489,9 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "self may only be called from inside a method", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); goto gotError; } contextPtr = framePtr->clientData; @@ -5024,16 +5040,15 @@ TEBCresume( } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), (match < 0 ? -1 : match > 0 : 1 : 0))); - JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); case INST_STR_INDEX: @@ -5150,27 +5165,27 @@ TEBCresume( value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ if (value3Ptr == value2Ptr) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } else if (valuePtr == value2Ptr) { objResultPtr = value3Ptr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); if (length == 0) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); if (length2 > length || length2 == 0) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } else if (length2 == length) { if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { objResultPtr = valuePtr; } else { objResultPtr = value3Ptr; } - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); @@ -5199,6 +5214,7 @@ TEBCresume( Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); } + doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); NEXT_INST_V(1, 3, 1); @@ -5221,7 +5237,6 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); @@ -5293,6 +5308,7 @@ TEBCresume( cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + TRACE(("%.20s %.20s => ", O2S(valuePtr), O2S(value2Ptr))); /* * Compile and match the regular expression. @@ -5303,23 +5319,17 @@ TEBCresume( Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); if (regExpr == NULL) { - goto regexpFailure; + TRACE_ERROR(interp); + goto gotError; } - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif + TRACE_ERROR(interp); goto gotError; } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -5424,6 +5434,8 @@ TEBCresume( */ foundResult: + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), + iResult)); JUMP_PEEPHOLE_F(iResult, 1, 2); } @@ -5511,13 +5523,13 @@ TEBCresume( if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5559,13 +5571,13 @@ TEBCresume( if (l2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5582,12 +5594,12 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { int shift = (int) l2; @@ -5835,7 +5847,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), + TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5844,18 +5856,20 @@ TEBCresume( } /* TODO: Consider peephole opt. */ objResultPtr = TCONST(!b); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 1, 1); } case INST_BITNOT: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { /* * ... ~$NonInteger => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5866,23 +5880,28 @@ TEBCresume( l1 = *((const long *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, ~l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, ~l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } case INST_UMINUS: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s \n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5892,23 +5911,28 @@ TEBCresume( switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); case TCL_NUMBER_LONG: l1 = *((const long *) ptr1); if (l1 != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, -l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, -l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5921,6 +5945,7 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { if (*pc == INST_UPLUS) { @@ -5928,7 +5953,7 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5937,7 +5962,7 @@ TEBCresume( } /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + TRACE_APPEND(("not numeric\n")); NEXT_INST_F(1, 0, 0); } if (IsErroringNaNType(type1)) { @@ -5946,7 +5971,7 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5956,8 +5981,7 @@ TEBCresume( * Numeric conversion of NaN -> error. */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); + TRACE_APPEND(("ERROR: IEEE floating pt error\n")); DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); CACHE_STACK_INFO(); @@ -5975,7 +5999,7 @@ TEBCresume( */ if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { @@ -5990,11 +6014,11 @@ TEBCresume( valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, new Tcl_Obj\n")); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } @@ -6011,6 +6035,7 @@ TEBCresume( */ result = TCL_BREAK; cleanup = 0; + TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: @@ -6021,6 +6046,7 @@ TEBCresume( */ result = TCL_CONTINUE; cleanup = 0; + TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { @@ -6204,6 +6230,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; + TRACE(("%u => ", opnd)); /* * Compute the number of iterations that will be run: iterMax @@ -6216,8 +6243,8 @@ TEBCresume( numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))); goto gotError; } if (Tcl_IsShared(listPtr)) { @@ -6253,6 +6280,7 @@ TEBCresume( TclNewObj(tmpPtr); tmpPtr->internalRep.otherValuePtr = infoPtr; PUSH_OBJECT(tmpPtr); /* infoPtr object */ + TRACE_APPEND(("jump to loop step\n")); /* * Jump directly to the INST_FOREACH_STEP instruction; the C code just @@ -6270,6 +6298,7 @@ TEBCresume( tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; + TRACE(("=> ")); tmpPtr = OBJ_AT_DEPTH(1); iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); @@ -6323,9 +6352,8 @@ TEBCresume( if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR init. index temp %d: %.30s", + varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } CACHE_STACK_INFO(); @@ -6334,10 +6362,12 @@ TEBCresume( } listTmpDepth--; } + TRACE_APPEND(("jump to loop start\n")); /* loopCtTemp being 'misused' for storing the jump size */ NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); } + TRACE_APPEND(("loop has no more iterations\n")); #ifdef TCL_COMPILE_DEBUG NEXT_INST_F(1, 0, 0); #else @@ -6352,6 +6382,7 @@ TEBCresume( tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; + TRACE(("=> loop terminated\n")); NEXT_INST_V(1, numLists+2, 0); case INST_LMAP_COLLECT: @@ -6368,6 +6399,7 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = tmpPtr->internalRep.otherValuePtr; numLists = infoPtr->numLists; + TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); @@ -6433,7 +6465,8 @@ TEBCresume( if (code < TCL_ERROR || code > TCL_CONTINUE) { code = TCL_CONTINUE + 1; } - NEXT_INST_F(2*code -1, 1, 0); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); + NEXT_INST_F(2*code-1, 1, 0); } /* @@ -6450,10 +6483,10 @@ TEBCresume( case INST_DICT_VERIFY: dictPtr = OBJ_AT_TOS; - TRACE(("=> ")); + TRACE(("\"%.30s\" => ", O2S(dictPtr))); if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { - TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n", - O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp)))); + TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6479,7 +6512,7 @@ TEBCresume( goto afterDictExists; } TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%s\": ", + "ERROR tracing dictionary path into \"%.30s\": ", O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); goto gotError; @@ -6492,10 +6525,10 @@ TEBCresume( goto afterDictExists; } if (!objResultPtr) { - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "key \"%s\" not known in dictionary", TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), NULL); CACHE_STACK_INFO(); @@ -6595,8 +6628,8 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR updating dictionary: %s\n", + O2S(Tcl_GetObjResult(interp)))); goto checkForCatch; } @@ -6959,7 +6992,7 @@ TEBCresume( case INST_DICT_EXPAND: dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; - TRACE(("%.30s %.30s =>", O2S(dictPtr), O2S(listPtr))); + TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -6969,7 +7002,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_DICT_RECOMBINE_STK: @@ -7117,10 +7150,10 @@ TEBCresume( if (traceInstructions) { objPtr = Tcl_GetObjResult(interp); if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ", result, O2S(objPtr))); } else { - TRACE_APPEND(("%s, result= \"%s\"\n", + TRACE_APPEND(("%s, result=\"%.30s\"\n", StringForResultCode(result), O2S(objPtr))); } } @@ -7133,8 +7166,8 @@ TEBCresume( */ divideByZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); CACHE_STACK_INFO(); goto gotError; @@ -7145,9 +7178,9 @@ TEBCresume( */ exponOfZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponentiation of zero by negative power", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); CACHE_STACK_INFO(); -- cgit v0.12 From 61fd69a37510ad47b187a6072edf47a4aebc19ce Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 08:35:01 +0000 Subject: oops... --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37588c5..94ddab1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6244,7 +6244,7 @@ TEBCresume( listPtr = OBJ_AT_DEPTH(listTmpDepth); if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", - i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))); + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (Tcl_IsShared(listPtr)) { -- cgit v0.12 From 292e2af7bb58a0e65d97b00604f9e59dc2ffa9ce Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 08:50:08 +0000 Subject: ... and more silly errors --- generic/tclExecute.c | 8 ++++---- unix/Makefile.in | 1 + 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 94ddab1..37a7397 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2788,7 +2788,7 @@ TEBCresume( objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); - TRACE(("=> mark depth as %d\n", CURR_DEPTH)); + TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); case INST_EXPAND_DROP: @@ -5041,7 +5041,7 @@ TEBCresume( } TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), - (match < 0 ? -1 : match > 0 : 1 : 0))); + (match < 0 ? -1 : match > 0 ? 1 : 0))); JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: @@ -6195,8 +6195,8 @@ TEBCresume( listTmpIndex++; } } - TRACE_APPEND(("%d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); + TRACE_APPEND(("%d lists, iter %d, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); /* * Run-time peep-hole optimisation: the compiler ALWAYS follows diff --git a/unix/Makefile.in b/unix/Makefile.in index a0d0c87..f74d516 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1195,6 +1195,7 @@ tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDld.c tclLoadDyld.o: $(UNIX_DIR)/tclLoadDyld.c + @echo Warnings are expected from compiling tclLoadDyld.c: deprecated API use $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDyld.c tclLoadNone.o: $(GENERIC_DIR)/tclLoadNone.c -- cgit v0.12 From c3ba561b42a9a5ebac6660b70f30f37c923e0551 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 2 Jan 2014 15:30:53 +0000 Subject: redevelop code to have more in common with the interpreted [string is] and to remove non-working types --- generic/tclCompCmdsSZ.c | 147 +++++++++++++++++++++++++----------------------- 1 file changed, 78 insertions(+), 69 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 440b5bf..06cca50 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -435,56 +435,59 @@ TclCompileStringIsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int numWords = parsePtr->numWords; - enum IsType { - TypeBool, TypeBoolFalse, TypeBoolTrue, - TypeFloat, - TypeInteger, TypeNarrowInt, TypeWideInt, - TypeList /*, TypeDict */ + static const char *const isClasses[] = { + "alnum", "alpha", "ascii", "control", + "boolean", "digit", "double", "entier", + "false", "graph", "integer", "list", + "lower", "print", "punct", "space", + "true", "upper", "wideinteger", "wordchar", + "xdigit", NULL + }; + enum isClasses { + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, + STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, + STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, + STR_IS_XDIGIT }; - enum IsType t; JumpFixup jumpFixup; - int start, range; - int allowEmpty = 0; + int t, range, allowEmpty = 0; + Tcl_Obj *isClass; - if (numWords < 2 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { return TCL_ERROR; } -#define GotLiteral(tokenPtr,word) \ - ((tokenPtr)[1].size > 1 && (tokenPtr)[1].start[0] == word[0] && \ - strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) - - if (GotLiteral(tokenPtr, "boolean")) { - t = TypeBool; - } else if (GotLiteral(tokenPtr, "double")) { - t = TypeFloat; - } else if (GotLiteral(tokenPtr, "entier")) { - t = TypeInteger; - } else if (GotLiteral(tokenPtr, "false")) { - t = TypeBoolFalse; - } else if (GotLiteral(tokenPtr, "integer")) { - t = TypeNarrowInt; - return TCL_ERROR; // Not yet implemented - } else if (GotLiteral(tokenPtr, "list")) { - t = TypeList; - } else if (GotLiteral(tokenPtr, "true")) { - t = TypeBoolTrue; - } else if (GotLiteral(tokenPtr, "wideinteger")) { - t = TypeWideInt; - return TCL_ERROR; // Not yet implemented - } else { - /* - * We don't handle character class checks in bytecode currently. - */ - + isClass = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) { + Tcl_DecrRefCount(isClass); return TCL_ERROR; + } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0, + &t) != TCL_OK) { + Tcl_DecrRefCount(isClass); + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; } - if (numWords != 3 && numWords != 4) { + Tcl_DecrRefCount(isClass); + +#define GotLiteral(tokenPtr, word) \ + ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \ + (tokenPtr)[1].size > 1 && \ + (tokenPtr)[1].start[0] == word[0] && \ + strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) + + /* + * Cannot handle the -failindex option at all, and that's the only legal + * way to have more than 4 arguments. + */ + + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { return TCL_ERROR; } + tokenPtr = TokenAfter(tokenPtr); - if (numWords == 3) { - allowEmpty = (t != TypeList); + if (parsePtr->numWords == 3) { + allowEmpty = (t != STR_IS_LIST); } else { if (!GotLiteral(tokenPtr, "-strict")) { return TCL_ERROR; @@ -494,18 +497,47 @@ TclCompileStringIsCmd( #undef GotLiteral /* + * Some types are not currently handled. Character classes are a prime + * example of this. + */ + + switch (t) { + case STR_IS_ALNUM: + case STR_IS_ALPHA: + case STR_IS_ASCII: + case STR_IS_CONTROL: + case STR_IS_DIGIT: + case STR_IS_GRAPH: + case STR_IS_LOWER: + case STR_IS_PRINT: + case STR_IS_PUNCT: + case STR_IS_SPACE: + case STR_IS_UPPER: + case STR_IS_WORD: + case STR_IS_XDIGIT: + return TCL_ERROR; + + case STR_IS_BOOL: + case STR_IS_FALSE: + case STR_IS_INT: + case STR_IS_TRUE: + case STR_IS_WIDE: + /* Not yet implemented */ + return TCL_ERROR; + } + + /* * Push the word to check. */ - CompileWord(envPtr, tokenPtr, interp, numWords-1); + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); /* * Next, do the type check. First, we push a catch range; most of the * type-check operations throw an exception on failure. */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - start = 0; + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -514,22 +546,7 @@ TclCompileStringIsCmd( */ switch (t) { - case TypeBool: - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LNOT, envPtr); - TclEmitOpcode( INST_POP, envPtr); - break; - case TypeBoolFalse: - TclEmitOpcode( INST_DUP, envPtr); - start = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); - break; - case TypeBoolTrue: - TclEmitOpcode( INST_DUP, envPtr); - start = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - break; - case TypeFloat: + case STR_IS_DOUBLE: /* * Careful! Preserve behavior of NaN which is a double (that is, true * for the purposes of a type check) but most math ops fail on it. The @@ -550,16 +567,12 @@ TclCompileStringIsCmd( TclEmitOpcode( INST_UMINUS, envPtr); TclEmitOpcode( INST_POP, envPtr); break; - case TypeInteger: + case STR_IS_ENTIER: TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_BITNOT, envPtr); TclEmitOpcode( INST_POP, envPtr); break; - case TypeNarrowInt: - Tcl_Panic("not yet implemented"); - case TypeWideInt: - Tcl_Panic("not yet implemented"); - case TypeList: + case STR_IS_LIST: TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitOpcode( INST_POP, envPtr); @@ -579,10 +592,6 @@ TclCompileStringIsCmd( PushLiteral(envPtr, "1", 1); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); ExceptionRangeTarget(envPtr, range, catchOffset); - if (start != 0) { - TclStoreInt1AtPtr(CurrentOffset(envPtr) - start, - envPtr->codeStart + start + 1); - } TclEmitOpcode( INST_END_CATCH, envPtr); if (allowEmpty) { PushLiteral(envPtr, "", 0); -- cgit v0.12 From 46e4bced044a19d781735a5c6f55a3a307dff7dc Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 5 Jan 2014 12:01:04 +0000 Subject: reducing TEBCdata: pc and cleanup now passed in the NREcallback --- generic/tclExecute.c | 40 ++++++++++++++++------------------------ 1 file changed, 16 insertions(+), 24 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37a7397..3601b22 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -174,28 +174,24 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { typedef struct TEBCdata { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ - const unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ - int cleanup; /* new codePtr was received for NR */ - Tcl_Obj *auxObjList; /* execution. */ - CmdFrame cmdFrame; + ptrdiff_t *catchTop; /* These fields are used on return TO this */ + Tcl_Obj *auxObjList; /* this level: they record the state when a */ + CmdFrame cmdFrame; /* new codePtr was received for NR */ + /* execution. */ void *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ } TEBCdata; #define TEBC_YIELD() \ - do { \ - esPtr->tosPtr = tosPtr; \ - TD->pc = pc; \ - TD->cleanup = cleanup; \ - TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \ + do { \ + esPtr->tosPtr = tosPtr; \ + TclNRAddCallback(interp, TEBCresume, \ + TD, pc, INT2PTR(cleanup), NULL); \ } while (0) #define TEBC_DATA_DIG() \ do { \ - pc = TD->pc; \ - cleanup = TD->cleanup; \ tosPtr = esPtr->tosPtr; \ } while (0) @@ -2032,10 +2028,6 @@ TclNRExecuteByteCode( * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - if (iPtr->execEnvPtr->rewind) { - return TCL_ERROR; - } - codePtr->refCount++; /* @@ -2054,9 +2046,7 @@ TclNRExecuteByteCode( esPtr->tosPtr = initTosPtr; TD->codePtr = codePtr; - TD->pc = codePtr->codeStart; TD->catchTop = initCatchTop; - TD->cleanup = 0; TD->auxObjList = NULL; /* @@ -2086,8 +2076,8 @@ TclNRExecuteByteCode( * Push the callback for bytecode execution */ - TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0), - NULL, NULL); + TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, + /* cleanup */ INT2PTR(0), NULL); return TCL_OK; } @@ -2150,7 +2140,8 @@ TEBCresume( Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ - const unsigned char *pc; /* The current program counter. */ + const unsigned char *pc = data[1]; + /* The current program counter. */ unsigned char inst; /* The currently running instruction */ /* @@ -2158,7 +2149,7 @@ TEBCresume( * executing an instruction. */ - int cleanup = 0; + int cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; int checkInterp; /* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() */ @@ -2186,16 +2177,17 @@ TEBCresume( TEBC_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG - if (!data[1] && (tclTraceExec >= 2)) { + if (!pc && (tclTraceExec >= 2)) { PrintByteCodeInfo(codePtr); fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif - if (!data[1]) { + if (!pc) { /* bytecode is starting from scratch */ checkInterp = 0; + pc = codePtr->codeStart; goto cleanup0; } else { /* resume from invocation */ -- cgit v0.12 From f63ef2c79888c0b68ff4e0ae7815e11e2075de65 Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 5 Jan 2014 14:10:42 +0000 Subject: skip the switch(result) on returning TCL_OK from a proc --- generic/tclProc.c | 72 +++++++++++++++++++++++++------------------------------ 1 file changed, 32 insertions(+), 40 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 1314719..ce1c767 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1855,9 +1855,39 @@ InterpProcNR2( } /* - * Process the result code. + * Free the stack-allocated compiled locals and CallFrame. It is important + * to pop the call frame without freeing it first: the compiledLocals + * cannot be freed before the frame is popped, as the local variables must + * be deleted. But the compiledLocals must be freed first, as they were + * allocated later on the stack. */ + if (result != TCL_OK) { + goto process; + } + + done: + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Obj *r = Tcl_GetObjResult(interp); + + TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, + TclGetString(r), r); + } + + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ + return result; + + /* + * Process any non-TCL_OK result code. + */ + + process: switch (result) { case TCL_RETURN: /* @@ -1892,46 +1922,8 @@ InterpProcNR2( */ errorProc(interp, procNameObj); - - default: - /* - * Process other results (OK and non-standard) by doing nothing - * special, skipping directly to the code afterwards that cleans up - * associated memory. - * - * Non-standard results are processed by passing them through quickly. - * This means they all work as exceptions, unwinding the stack quickly - * and neatly. Who knows how well they are handled by third-party code - * though... - */ - - (void) 0; /* do nothing */ - } - - if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - Tcl_Obj *r = Tcl_GetObjResult(interp); - - TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, - TclGetString(r), r); } - - /* - * Free the stack-allocated compiled locals and CallFrame. It is important - * to pop the call frame without freeing it first: the compiledLocals - * cannot be freed before the frame is popped, as the local variables must - * be deleted. But the compiledLocals must be freed first, as they were - * allocated later on the stack. - */ - - freePtr = iPtr->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - - return result; + goto done; } /* -- cgit v0.12 From 92f27b7095220ef6e508c9a0216e0fce97b3d2ae Mon Sep 17 00:00:00 2001 From: mig Date: Sun, 5 Jan 2014 15:01:52 +0000 Subject: fix arraySet compiler to set -errorcode instead of -errorCode in return options --- generic/tclCompCmds.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 323aa87..3d5bfe0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -278,7 +278,7 @@ TclCompileArraySetCmd( if (isDataValid && !isDataEven) { PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); goto done; @@ -373,7 +373,7 @@ TclCompileArraySetCmd( offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); TclAdjustStackDepth(-1, envPtr); -- cgit v0.12 From c01192cf149de63a2a22afde7ac9adecd73f051d Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 5 Jan 2014 17:31:38 +0000 Subject: factor out a common stanza --- generic/tclExecute.c | 61 ++++++++++++++++++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 21 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f25b588..612a5cb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1996,6 +1996,41 @@ TclIncrObj( /* *---------------------------------------------------------------------- * + * ArgumentBCEnter -- + * + * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates + * a code sequence that is fairly common in the code but *not* commonly + * called. + * + * Results: + * None + * + * Side effects: + * May register information about the bytecode in the command frame. + * + *---------------------------------------------------------------------- + */ + +static void +ArgumentBCEnter( + Tcl_Interp *interp, + ByteCode *codePtr, + TEBCdata *tdPtr, + const unsigned char *pc, + int objc, + Tcl_Obj **objv) +{ + int cmd; + + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, + pc - codePtr->codeStart); + } +} + +/* + *---------------------------------------------------------------------- + * * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It @@ -2205,7 +2240,7 @@ TEBCresume( } iPtr->cmdFramePtr = bcFramePtr->nextPtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + TclArgumentBCRelease(interp, bcFramePtr); } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; @@ -2487,11 +2522,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } pc++; @@ -2961,11 +2992,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } DECACHE_STACK_INFO(); @@ -3110,11 +3137,7 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; @@ -4559,11 +4582,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } pcAdjustment = 2; -- cgit v0.12 From 23573493d5f31cddea12c4e9b6f8ae5a5d3f50c9 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 7 Jan 2014 13:59:30 +0000 Subject: reduce the overhead of NR-enabled TclOO [next] --- generic/tclExecute.c | 136 +++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 127 insertions(+), 9 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 612a5cb..5b42124 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -800,7 +800,8 @@ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; - +static Tcl_NRPostProc FinalizeOONext; +static Tcl_NRPostProc FinalizeOONextFilter; static Tcl_NRPostProc TEBCresume; /* @@ -4535,6 +4536,7 @@ TEBCresume( */ { + Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; @@ -4578,6 +4580,53 @@ TEBCresume( } contextPtr = framePtr->clientData; + if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless + * the interpreter is being torn down, in which case we might be + * getting here because of methods/destructors doing a [next] (or + * equivalent) unexpectedly. + */ + + const char *methodType; + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: no TclOO next impl\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("next_in_chain ")); + } else { + fprintf(stdout, "%d: (%u) invoking next_in_chain ", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; @@ -4591,14 +4640,31 @@ TEBCresume( iPtr->varFramePtr = framePtr->callerVarPtr; pc += pcAdjustment; TEBC_YIELD(); - TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, - NULL, NULL, NULL); - /* TODO: consider merging another layer of processing */ - return TclNRObjectContextInvokeNext(interp, - (Tcl_ObjectContext) contextPtr, opnd, &OBJ_AT_DEPTH(opnd-1), 1); - } - { - Object *oPtr; + oPtr = contextPtr->oPtr; + if (oPtr->flags & FILTER_HANDLING) { + TclNRAddCallback(interp, FinalizeOONextFilter, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } else { + TclNRAddCallback(interp, FinalizeOONext, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } + if (contextPtr->callPtr->chain[++contextPtr->index].isFilter + || contextPtr->callPtr->flags & FILTER_HANDLING) { + oPtr->flags |= FILTER_HANDLING; + } else { + oPtr->flags &= ~FILTER_HANDLING; + } + contextPtr->skip = 1; + { + register Method *const mPtr = + contextPtr->callPtr->chain[contextPtr->index].mPtr; + + return mPtr->typePtr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, opnd, + &OBJ_AT_DEPTH(opnd-1)); + } case INST_TCLOO_IS_OBJECT: oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); @@ -7766,6 +7832,58 @@ TEBCresume( #undef auxObjList #undef catchTop #undef TCONST + +static int +FinalizeOONext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags &= ~FILTER_HANDLING; + return result; +} + +static int +FinalizeOONextFilter( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags |= FILTER_HANDLING; + return result; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From 8bb7405765b9aed27270dfd145037e3c5884a34a Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 7 Jan 2014 14:13:37 +0000 Subject: make function static once more; not needed outside of source file --- generic/tclInt.h | 1 - generic/tclOOBasic.c | 21 +++++++++------------ 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index f10beae..3aaa30b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2734,7 +2734,6 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; -MODULE_SCOPE Tcl_NRPostProc TclOONextRestoreFrame; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 49c917b..6084cf2 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -17,14 +17,11 @@ #include "tclOOInt.h" static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); -static int AfterNRDestructor(ClientData data[], - Tcl_Interp *interp, int result); -static int DecrRefsPostClassConstructor(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeConstruction(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeEval(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc AfterNRDestructor; +static Tcl_NRPostProc DecrRefsPostClassConstructor; +static Tcl_NRPostProc FinalizeConstruction; +static Tcl_NRPostProc FinalizeEval; +static Tcl_NRPostProc NextRestoreFrame; /* * ---------------------------------------------------------------------- @@ -806,7 +803,7 @@ TclOONextObjCmd( * that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, NULL,NULL,NULL); + TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL); iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } @@ -875,7 +872,7 @@ TclOONextToObjCmd( * context. Note that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, TclOONextRestoreFrame, framePtr, + TclNRAddCallback(interp, NextRestoreFrame, framePtr, contextPtr, INT2PTR(contextPtr->index), NULL); contextPtr->index = i-1; iPtr->varFramePtr = framePtr->callerVarPtr; @@ -905,8 +902,8 @@ TclOONextToObjCmd( return TCL_ERROR; } -int -TclOONextRestoreFrame( +static int +NextRestoreFrame( ClientData data[], Tcl_Interp *interp, int result) -- cgit v0.12 From b9663aff14aff96677a1252092a006ae19f81a8c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Jan 2014 11:04:44 +0000 Subject: Make DEFAULT_TRIM_SET a MODULE_SCOPE string constant, so its value can be shared in tclCmdMZ.o and TclCompCmdsSZ.o and it no longer pollutes the tclStringTrim.h header file. --- generic/tclCmdMZ.c | 45 +++++++++++++++++++++++++++++++++++++++------ generic/tclCompCmdsSZ.c | 6 +++--- generic/tclStringTrim.h | 27 +-------------------------- 3 files changed, 43 insertions(+), 35 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d477216..c02cd1a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -32,6 +32,39 @@ static int TryPostHandler(ClientData data[], Tcl_Interp *interp, int result); static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); + +/* + * Default set of characters to trim in [string trim] and friends. This is a + * UTF-8 literal string containing all Unicode space characters [TIP #413] + */ + +const char tclDefaultTrimSet[] = + "\x09\x0a\x0b\x0c\x0d " /* ASCII */ + "\xc0\x80" /* nul (U+0000) */ + "\xc2\x85" /* next line (U+0085) */ + "\xc2\xa0" /* non-breaking space (U+00a0) */ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */ + "\xe2\x80\x80" /* en quad (U+2000) */ + "\xe2\x80\x81" /* em quad (U+2001) */ + "\xe2\x80\x82" /* en space (U+2002) */ + "\xe2\x80\x83" /* em space (U+2003) */ + "\xe2\x80\x84" /* three-per-em space (U+2004) */ + "\xe2\x80\x85" /* four-per-em space (U+2005) */ + "\xe2\x80\x86" /* six-per-em space (U+2006) */ + "\xe2\x80\x87" /* figure space (U+2007) */ + "\xe2\x80\x88" /* punctuation space (U+2008) */ + "\xe2\x80\x89" /* thin space (U+2009) */ + "\xe2\x80\x8a" /* hair space (U+200a) */ + "\xe2\x80\x8b" /* zero width space (U+200b) */ + "\xe2\x80\xa8" /* line separator (U+2028) */ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */ + "\xe2\x81\xa0" /* word joiner (U+2060) */ + "\xe3\x80\x80" /* ideographic space (U+3000) */ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +; /* *---------------------------------------------------------------------- @@ -3158,8 +3191,8 @@ StringTrimCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3206,8 +3239,8 @@ StringTrimLCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3252,8 +3285,8 @@ StringTrimRCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0f2790f..c54a06a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -810,7 +810,7 @@ TclCompileStringTrimLCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM_LEFT); return TCL_OK; @@ -838,7 +838,7 @@ TclCompileStringTrimRCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM_RIGHT); return TCL_OK; @@ -866,7 +866,7 @@ TclCompileStringTrimCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); } else { - PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET)); + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } OP( STR_TRIM); return TCL_OK; diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h index 669f10b..030e4ec 100644 --- a/generic/tclStringTrim.h +++ b/generic/tclStringTrim.h @@ -23,32 +23,7 @@ * UTF-8 literal string containing all Unicode space characters. [TIP #413] */ -#define DEFAULT_TRIM_SET \ - "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ - "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x85" /* next line (U+0085) */\ - "\xc2\xa0" /* non-breaking space (U+00a0) */\ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ - "\xe2\x80\x80" /* en quad (U+2000) */\ - "\xe2\x80\x81" /* em quad (U+2001) */\ - "\xe2\x80\x82" /* en space (U+2002) */\ - "\xe2\x80\x83" /* em space (U+2003) */\ - "\xe2\x80\x84" /* three-per-em space (U+2004) */\ - "\xe2\x80\x85" /* four-per-em space (U+2005) */\ - "\xe2\x80\x86" /* six-per-em space (U+2006) */\ - "\xe2\x80\x87" /* figure space (U+2007) */\ - "\xe2\x80\x88" /* punctuation space (U+2008) */\ - "\xe2\x80\x89" /* thin space (U+2009) */\ - "\xe2\x80\x8a" /* hair space (U+200a) */\ - "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\xa8" /* line separator (U+2028) */\ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ - "\xe2\x81\xa0" /* word joiner (U+2060) */\ - "\xe3\x80\x80" /* ideographic space (U+3000) */\ - "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of -- cgit v0.12 From acf1cebeab93607fc83206e77534b5fada8726ef Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 9 Jan 2014 10:49:04 +0000 Subject: use compact form --- generic/tclCompCmdsSZ.c | 51 ++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 26 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 06cca50..345dd9f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -451,8 +451,7 @@ TclCompileStringIsCmd( STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT }; - JumpFixup jumpFixup; - int t, range, allowEmpty = 0; + int t, range, allowEmpty = 0, end; Tcl_Obj *isClass; if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { @@ -538,7 +537,7 @@ TclCompileStringIsCmd( */ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); /* @@ -554,28 +553,28 @@ TclCompileStringIsCmd( * this is true for). */ - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_NEQ, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 5, envPtr); + OP( DUP); + OP( DUP); + OP( NEQ); + OP1( JUMP_TRUE1, 5); /* * Type check for all other double values. */ - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_UMINUS, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP( UMINUS); + OP( POP); break; case STR_IS_ENTIER: - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_BITNOT, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP( BITNOT); + OP( POP); break; case STR_IS_LIST: - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP( LIST_LENGTH); + OP( POP); break; } @@ -587,20 +586,20 @@ TclCompileStringIsCmd( */ ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "1", 1); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + OP( END_CATCH); + OP( POP); + PUSH( "1"); + JUMP1( JUMP, end); ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_END_CATCH, envPtr); + OP( END_CATCH); if (allowEmpty) { - PushLiteral(envPtr, "", 0); - TclEmitOpcode( INST_STR_EQ, envPtr); + PUSH( ""); + OP( STR_EQ); } else { - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "0", 1); + OP( POP); + PUSH( "0"); } - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + FIXJUMP1( end); return TCL_OK; } -- cgit v0.12 From c3c6e803684022dcc788ddbfc4a59a6d0dfde102 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 10 Jan 2014 15:58:41 +0000 Subject: a different approach --- generic/tclAssembly.c | 4 +- generic/tclCompCmdsSZ.c | 150 ++++++++++++++++++++++++++---------------------- generic/tclCompile.c | 4 ++ generic/tclCompile.h | 4 +- generic/tclExecute.c | 8 +++ 5 files changed, 98 insertions(+), 72 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 89c286a..70379c6 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = { {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1}, {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, @@ -516,7 +517,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_RESOLVE_COMMAND, /* 154 */ INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ INST_CONCAT_STK, /* 169 */ - INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */ + INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ + INST_NUM_TYPE /* 180 */ }; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 345dd9f..1436a20 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -500,7 +500,7 @@ TclCompileStringIsCmd( * example of this. */ - switch (t) { + switch ((enum isClasses) t) { case STR_IS_ALNUM: case STR_IS_ALPHA: case STR_IS_ASCII: @@ -514,93 +514,103 @@ TclCompileStringIsCmd( case STR_IS_UPPER: case STR_IS_WORD: case STR_IS_XDIGIT: + /* Not yet implemented */ return TCL_ERROR; case STR_IS_BOOL: case STR_IS_FALSE: - case STR_IS_INT: case STR_IS_TRUE: - case STR_IS_WIDE: /* Not yet implemented */ return TCL_ERROR; - } - - /* - * Push the word to check. - */ - - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); - /* - * Next, do the type check. First, we push a catch range; most of the - * type-check operations throw an exception on failure. - */ - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - - /* - * Issue the type-check itself for the specific type. - */ + case STR_IS_DOUBLE: { + int satisfied, isEmpty; - switch (t) { - case STR_IS_DOUBLE: - /* - * Careful! Preserve behavior of NaN which is a double (that is, true - * for the purposes of a type check) but most math ops fail on it. The - * key is that it is not == to itself (and is the only value which - * this is true for). - */ + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + if (allowEmpty) { + OP( DUP); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_TRUE, isEmpty); + OP( NUM_TYPE); + JUMP1( JUMP_TRUE, satisfied); + PUSH( "0"); + JUMP1( JUMP, end); + FIXJUMP1( isEmpty); + OP( POP); + FIXJUMP1( satisfied); + } else { + OP( NUM_TYPE); + JUMP1( JUMP_TRUE, satisfied); + PUSH( "0"); + JUMP1( JUMP, end); + TclAdjustStackDepth(-1, envPtr); + FIXJUMP1( satisfied); + } + PUSH( "1"); + FIXJUMP1( end); + return TCL_OK; + } - OP( DUP); - OP( DUP); - OP( NEQ); - OP1( JUMP_TRUE1, 5); + case STR_IS_INT: + case STR_IS_WIDE: + case STR_IS_ENTIER: + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + if (allowEmpty) { + int testNumType; + + OP( DUP); + OP( NUM_TYPE); + OP( DUP); + JUMP1( JUMP_TRUE, testNumType); + OP( POP); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP, end); + TclAdjustStackDepth(1, envPtr); + FIXJUMP1( testNumType); + OP4( REVERSE, 2); + OP( POP); + } else { + OP( NUM_TYPE); + OP( DUP); + JUMP1( JUMP_FALSE, end); + } - /* - * Type check for all other double values. - */ + switch (t) { + case STR_IS_INT: + PUSH( "1"); + OP( EQ); + break; + case STR_IS_WIDE: + PUSH( "2"); + OP( LE); + break; + case STR_IS_ENTIER: + PUSH( "3"); + OP( LE); + break; + } + FIXJUMP1( end); + return TCL_OK; - OP( DUP); - OP( UMINUS); - OP( POP); - break; - case STR_IS_ENTIER: - OP( DUP); - OP( BITNOT); - OP( POP); - break; case STR_IS_LIST: + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); OP( DUP); OP( LIST_LENGTH); OP( POP); - break; - } - - /* - * Based on whether the exception was thrown (or conditional branch taken, - * in the case of true/false checks), push the correct boolean value. This - * is also where we deal with what happens with empty values in non-strict - * mode. - */ - - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - OP( POP); - PUSH( "1"); - JUMP1( JUMP, end); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( END_CATCH); - if (allowEmpty) { - PUSH( ""); - OP( STR_EQ); - } else { + ExceptionRangeEnds(envPtr, range); + ExceptionRangeTarget(envPtr, range, catchOffset); OP( POP); - PUSH( "0"); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); + return TCL_OK; } - FIXJUMP1( end); - return TCL_OK; + return TCL_ERROR; } int diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee67e24..c01571f 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -621,6 +621,10 @@ InstructionDesc const tclInstructionTable[] = { /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ + {"numericType", 1, 0, 0, {OPERAND_NONE}}, + /* Pushes the numeric type code of the word at the top of the stack. + * Stack: ... value => ... typeCode */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6ecadf4..6bf5daf 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -792,8 +792,10 @@ typedef struct ByteCode { #define INST_TCLOO_NEXT 179 +#define INST_NUM_TYPE 180 + /* The last opcode */ -#define LAST_INST_OPCODE 179 +#define LAST_INST_OPCODE 180 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5b42124..2707ec1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5776,6 +5776,14 @@ TEBCresume( int type1, type2; long l1, l2, lResult; + case INST_NUM_TYPE: + if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { + type1 = 0; + } + TclNewIntObj(objResultPtr, type1); + TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); + NEXT_INST_F(1, 1, 1); + case INST_EQ: case INST_NEQ: case INST_LT: -- cgit v0.12 From aa2c40934df3fdefbb39338f7eef44e79c3c551e Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 13 Jan 2014 08:06:43 +0000 Subject: extend [string is] to booleans --- generic/tclAssembly.c | 1 + generic/tclCompCmdsSZ.c | 51 +++++++++++++++++++++++++++++++++++++++++++++---- generic/tclCompile.c | 3 +++ generic/tclCompile.h | 3 ++- generic/tclExecute.c | 11 +++++++++++ 5 files changed, 64 insertions(+), 5 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 70379c6..f10bca8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -478,6 +478,7 @@ static const TalInstDesc TalInstructionTable[] = { {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, + {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2}, {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 1436a20..91bb94c 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -514,14 +514,57 @@ TclCompileStringIsCmd( case STR_IS_UPPER: case STR_IS_WORD: case STR_IS_XDIGIT: - /* Not yet implemented */ - return TCL_ERROR; + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); case STR_IS_BOOL: case STR_IS_FALSE: case STR_IS_TRUE: - /* Not yet implemented */ - return TCL_ERROR; + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + OP( TRY_CVT_TO_BOOLEAN); + switch (t) { + int over, over2; + + case STR_IS_BOOL: + if (allowEmpty) { + JUMP1( JUMP_TRUE, over); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP, over2); + FIXJUMP1(over); + OP( POP); + PUSH( "1"); + FIXJUMP1(over2); + } else { + OP4( REVERSE, 2); + OP( POP); + } + return TCL_OK; + case STR_IS_TRUE: + JUMP1( JUMP_TRUE, over); + if (allowEmpty) { + PUSH( ""); + OP( STR_EQ); + } else { + OP( POP); + PUSH( "0"); + } + FIXJUMP1( over); + OP( LNOT); + OP( LNOT); + return TCL_OK; + case STR_IS_FALSE: + JUMP1( JUMP_TRUE, over); + if (allowEmpty) { + PUSH( ""); + OP( STR_NEQ); + } else { + OP( POP); + PUSH( "1"); + } + FIXJUMP1( over); + OP( LNOT); + return TCL_OK; + } case STR_IS_DOUBLE: { int satisfied, isEmpty; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c01571f..39fa241 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -624,6 +624,9 @@ InstructionDesc const tclInstructionTable[] = { {"numericType", 1, 0, 0, {OPERAND_NONE}}, /* Pushes the numeric type code of the word at the top of the stack. * Stack: ... value => ... typeCode */ + {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, + /* Try converting stktop to boolean if possible. No errors. + * Stack: ... value => ... value isStrictBool */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6bf5daf..a08a93a 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -793,9 +793,10 @@ typedef struct ByteCode { #define INST_TCLOO_NEXT 179 #define INST_NUM_TYPE 180 +#define INST_TRY_CVT_TO_BOOLEAN 181 /* The last opcode */ -#define LAST_INST_OPCODE 180 +#define LAST_INST_OPCODE 181 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2707ec1..989b7b6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6461,6 +6461,17 @@ TEBCresume( * ----------------------------------------------------------------- */ + case INST_TRY_CVT_TO_BOOLEAN: + valuePtr = OBJ_AT_TOS; + if (valuePtr->typePtr == &tclBooleanType) { + objResultPtr = TCONST(1); + } else { + int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(result); + } + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_BREAK: /* DECACHE_STACK_INFO(); -- cgit v0.12 From e0791bfa1b98a28520902dbb5018ffdcb5925860 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 15 Jan 2014 19:04:52 +0000 Subject: [2992970] Restore the safety of Tcl_AppendObjToObj(x, x) for bytearrays. Also moves overflow checking to TclAppendBytesToByteArray() and adds the ability to call TABTBA() with bytes==NULL, for appending unspecified bytes. That is, the string grows, but the new bytes are of undetermined value. Like Tcl_NewByteArrayObj(NULL, length) this option is useful for manipulating buffers. The TABTBA growth algorithm is also enhanced a bit, copying over a fuller implementation from GrowStringBuffer() in tclStringObj.c --- generic/tclBinary.c | 74 ++++++++++++++++++++++---------------------------- generic/tclStringObj.c | 42 ++++++++++++++++++++-------- 2 files changed, 64 insertions(+), 52 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 4e977f2..981f174 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -610,9 +610,7 @@ UpdateStringOfByteArray( * * This function appends an array of bytes to a byte array object. Note * that the object *must* be unshared, and the array of bytes *must not* - * refer to the object being appended to. Also the caller must have - * already checked that the final length of the bytearray after the - * append operations is complete will not overflow the int range. + * refer to the object being appended to. * * Results: * None. @@ -631,6 +629,7 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; + int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -639,64 +638,57 @@ TclAppendBytesToByteArray( Tcl_Panic("%s must be called with definite number of bytes to append", "TclAppendBytesToByteArray"); } + if (len == 0) { + /* Append zero bytes is a no-op. */ + return; + } if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } byteArrayPtr = GET_BYTEARRAY(objPtr); + if (len > INT_MAX - byteArrayPtr->used) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ - if (byteArrayPtr->used + len > byteArrayPtr->allocated) { - unsigned int attempt, used = byteArrayPtr->used; - ByteArray *tmpByteArrayPtr = NULL; + if (needed > byteArrayPtr->allocated) { + ByteArray *ptr = NULL; + int attempt; - attempt = byteArrayPtr->allocated; - if (attempt < 1) { - /* - * No allocated bytes, so must be none used too. We use this - * method to calculate how many bytes to allocate because we can - * end up with a zero-length buffer otherwise, when doubling can - * cause trouble. [Bug 3067036] - */ - - attempt = len + 1; - } else { - do { - attempt *= 2; - } while (attempt < used+len); + if (needed <= INT_MAX/2) { + /* Try to allocate double the total space that is needed. */ + attempt = 2 * needed; + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } + if (ptr == NULL) { + /* Try to allocate double the increment that is needed (plus). */ + unsigned int limit = INT_MAX - needed; + unsigned int extra = len + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); - if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) { - tmpByteArrayPtr = attemptckrealloc(byteArrayPtr, - BYTEARRAY_SIZE(attempt)); + attempt = needed + growth; + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } - - if (tmpByteArrayPtr == NULL) { - attempt = used + len; - if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) { - Tcl_Panic("attempt to allocate a bigger buffer than we can handle"); - } - tmpByteArrayPtr = ckrealloc(byteArrayPtr, - BYTEARRAY_SIZE(attempt)); + if (ptr == NULL) { + /* Last chance: Try to allocate exactly what is needed. */ + attempt = needed; + ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } - - byteArrayPtr = tmpByteArrayPtr; + byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - byteArrayPtr->used = used; SET_BYTEARRAY(objPtr, byteArrayPtr); } - /* - * Do the append if there's any point. - */ - - if (len > 0) { + if (bytes) { memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); - byteArrayPtr->used += len; - TclInvalidateStringRep(objPtr); } + byteArrayPtr->used += len; + TclInvalidateStringRep(objPtr); } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index e495c2e..1512f0c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1281,23 +1281,43 @@ Tcl_AppendObjToObj( if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) && TclIsPureByteArray(appendObjPtr)) { - unsigned char *bytesSrc; - int lengthSrc, lengthTotal; + int lengthSrc; /* - * We do not assume that objPtr and appendObjPtr must be distinct! - * This makes this code a bit more complex than it otherwise would be, - * but in turn makes it much safer. + * You might expect the code here to be + * + + bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); + TclAppendBytesToByteArray(objPtr, bytes, length); + + * + * and essentially all of the time that would be fine. However, + * it would run into trouble in the case where objPtr and + * appendObjPtr point to the same thing. That may never be a + * good idea. It seems to violate Copy On Write, and we don't + * have any tests for the situation, since making any Tcl commands + * that call Tcl_AppendObjToObj() do that appears impossible + * (They honor Copy On Write!). For the sake of extensions that + * go off into that realm, though, here's a more complex approach + * that can handle all the cases. */ + /* Get lengths */ (void) Tcl_GetByteArrayFromObj(objPtr, &length); (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); - lengthTotal = length + lengthSrc; - if (((length > lengthSrc) ? length : lengthSrc) > lengthTotal) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - bytesSrc = Tcl_GetByteArrayFromObj(appendObjPtr, NULL); - TclAppendBytesToByteArray(objPtr, bytesSrc, lengthSrc); + + /* Grow buffer enough for the append */ + TclAppendBytesToByteArray(objPtr, NULL, lengthSrc); + + /* Reset objPtr back to the original value */ + Tcl_SetByteArrayLength(objPtr, length); + + /* + * Now do the append secure that buffer growth cannot cause + * any trouble. + */ + TclAppendBytesToByteArray(objPtr, + Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc); return; } -- cgit v0.12 From ab8fd1e3f28322c8d57229cd2e171fea351097af Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 19 Jan 2014 18:39:24 +0000 Subject: added compilation for [nextto] --- generic/tclAssembly.c | 1 + generic/tclCompCmdsGR.c | 25 +++++++++ generic/tclCompile.c | 14 ++++- generic/tclCompile.h | 3 +- generic/tclExecute.c | 132 +++++++++++++++++++++++++++++++++++++++++++----- generic/tclInt.h | 3 ++ generic/tclOO.c | 3 +- generic/tclOOBasic.c | 20 ++++++-- 8 files changed, 179 insertions(+), 22 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 89c286a..7b775a9 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -26,6 +26,7 @@ *- jumpTable testing *- syntax (?) *- returnCodeBranch + *- tclooNext, tclooNextClass */ #include "tclInt.h" diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index b8a7e0f..b3e273f 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -3075,6 +3075,31 @@ TclCompileObjectNextCmd( } int +TclCompileObjectNextToCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { + return TCL_ERROR; + } + + for (i=0 ; inumWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr); + return TCL_OK; +} + +int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ee67e24..bd97e3e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -618,8 +618,18 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... cmdName => ... fullOriginalCmdName */ {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, - /* Push the identity of the current TclOO object (i.e., the name of - * its current public access command) on the stack. */ + /* Call the next item on the TclOO call chain, passing opnd arguments + * (min 1, max 255, *includes* "next"). The result of the invoked + * method implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "next" arg2 arg3 -- argN => ... result */ + {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call the following item on the TclOO call chain defined by class + * className, passing opnd arguments (min 2, max 255, *includes* + * "nextto" and the class name). The result of the invoked method + * implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6ecadf4..b047855 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -791,9 +791,10 @@ typedef struct ByteCode { #define INST_ORIGIN_COMMAND 178 #define INST_TCLOO_NEXT 179 +#define INST_TCLOO_NEXT_CLASS 180 /* The last opcode */ -#define LAST_INST_OPCODE 179 +#define LAST_INST_OPCODE 180 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5b42124..ac0ea12 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4539,6 +4539,7 @@ TEBCresume( Object *oPtr; CallFrame *framePtr; CallContext *contextPtr; + int skip, newDepth; case INST_TCLOO_SELF: framePtr = iPtr->varFramePtr; @@ -4563,9 +4564,111 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + case INST_TCLOO_NEXT_CLASS: + opnd = TclGetUInt1AtPtr(pc+1); + framePtr = iPtr->varFramePtr; + valuePtr = OBJ_AT_DEPTH(opnd - 2); + objv = &OBJ_AT_DEPTH(opnd - 1); + skip = 2; + TRACE(("%d => ", opnd)); + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE_APPEND(("ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "nextto may only be called from inside a method", + -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); + if (oPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); + goto gotError; + } else { + Class *classPtr = oPtr->classPtr; + struct MInvoke *miPtr; + int i; + const char *methodType; + + if (classPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + for (i=contextPtr->index+1 ; icallPtr->numChain ; i++) { + miPtr = contextPtr->callPtr->chain + i; + if (!miPtr->isFilter && + miPtr->mPtr->declaringClassPtr == classPtr) { + newDepth = i; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < opnd; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + goto doInvokeNext; + } + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", + O2S(valuePtr))); + for (i=contextPtr->index ; i>=0 ; i--) { + miPtr = contextPtr->callPtr->chain + i; + if (miPtr->isFilter + || miPtr->mPtr->declaringClassPtr != classPtr) { + continue; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s implementation by \"%s\" not reachable from here", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s has no non-filter implementation by \"%s\"", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + case INST_TCLOO_NEXT: opnd = TclGetUInt1AtPtr(pc+1); + objv = &OBJ_AT_DEPTH(opnd - 1); framePtr = iPtr->varFramePtr; + skip = 1; TRACE(("%d => ", opnd)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { @@ -4580,7 +4683,8 @@ TEBCresume( } contextPtr = framePtr->clientData; - if (contextPtr->index+1 >= contextPtr->callPtr->numChain) { + newDepth = contextPtr->index + 1; + if (newDepth >= contextPtr->callPtr->numChain) { /* * We're at the end of the chain; generate an error message unless * the interpreter is being torn down, in which case we might be @@ -4605,33 +4709,31 @@ TEBCresume( Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); CACHE_STACK_INFO(); goto gotError; - } - #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + } else if (tclTraceExec >= 2) { int i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("next_in_chain ")); } else { - fprintf(stdout, "%d: (%u) invoking next_in_chain ", + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); } - for (i = 0; i < objc; i++) { + for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); fflush(stdout); - } #endif /*TCL_COMPILE_DEBUG*/ + } + doInvokeNext: bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); + ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); } pcAdjustment = 2; @@ -4640,6 +4742,7 @@ TEBCresume( iPtr->varFramePtr = framePtr->callerVarPtr; pc += pcAdjustment; TEBC_YIELD(); + oPtr = contextPtr->oPtr; if (oPtr->flags & FILTER_HANDLING) { TclNRAddCallback(interp, FinalizeOONextFilter, @@ -4650,20 +4753,21 @@ TEBCresume( framePtr, contextPtr, INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip)); } - if (contextPtr->callPtr->chain[++contextPtr->index].isFilter + contextPtr->skip = skip; + contextPtr->index = newDepth; + if (contextPtr->callPtr->chain[newDepth].isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) { oPtr->flags |= FILTER_HANDLING; } else { oPtr->flags &= ~FILTER_HANDLING; } - contextPtr->skip = 1; + { register Method *const mPtr = - contextPtr->callPtr->chain[contextPtr->index].mPtr; + contextPtr->callPtr->chain[newDepth].mPtr; return mPtr->typePtr->callProc(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); + (Tcl_ObjectContext) contextPtr, opnd, objv); } case INST_TCLOO_IS_OBJECT: diff --git a/generic/tclInt.h b/generic/tclInt.h index 3aaa30b..7932a58 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3592,6 +3592,9 @@ MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclOO.c b/generic/tclOO.c index 9a0682d..de00733 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -440,8 +440,9 @@ InitFoundation( cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", NULL, TclOONextObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectNextCmd; - Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", NULL, TclOONextToObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextToCmd; cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 6084cf2..0b0516b 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -821,6 +821,7 @@ TclOONextToObjCmd( CallContext *contextPtr; int i; Tcl_Object object; + const char *methodType; /* * Start with sanity checks on the calling context to make sure that we @@ -886,19 +887,30 @@ TclOONextToObjCmd( * is on the chain but unreachable, or not on the chain at all. */ + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + for (i=contextPtr->index ; i>=0 ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method implementation by \"%s\" not reachable from here", - TclGetString(objv[1]))); + "%s implementation by \"%s\" not reachable from here", + methodType, TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", + NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method has no non-filter implementation by \"%s\"", - TclGetString(objv[1]))); + "%s has no non-filter implementation by \"%s\"", + methodType, TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); return TCL_ERROR; } -- cgit v0.12 From 61bfac2613d3cc063099ad9e6de3110491b6f5df Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 21 Jan 2014 15:07:59 +0000 Subject: implementation of [yieldto] in bytecode --- generic/tclBasic.c | 2 +- generic/tclCompCmdsSZ.c | 45 +++++++++++++++++++++++++++++++ generic/tclCompile.c | 7 +++++ generic/tclCompile.h | 4 ++- generic/tclExecute.c | 71 ++++++++++++++++++++++++++++++++++++++++++------- generic/tclInt.h | 3 +++ 6 files changed, 121 insertions(+), 11 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7c02706..e355229 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -259,7 +259,7 @@ static const CmdInfo builtInCmds[] = { {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, - {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE}, + {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, /* * Commands in the OS-interface. Note that many of these are unsafe. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0f2790f..5c132b4 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3447,6 +3447,51 @@ TclCompileYieldCmd( /* *---------------------------------------------------------------------- * + * TclCompileYieldToCmd -- + * + * Procedure called to compile the "yieldto" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "yieldto" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileYieldToCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int i; + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + OP( NS_CURRENT); + for (i = 1 ; i < parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + OP4( LIST, i); + OP( YIELD_TO_INVOKE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * CompileUnaryOpCmd -- * * Utility routine to compile the unary operator commands. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bd97e3e..f75ac83 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -631,6 +631,13 @@ InstructionDesc const tclInstructionTable[] = { * arguments (similar to invokeStk). * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ + {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, invoking the given command/args with resolution in the given + * namespace (all packed into a list), and places the list of values + * that are the response back on top of the stack when it resumes. + * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b047855..7994e2c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -793,8 +793,10 @@ typedef struct ByteCode { #define INST_TCLOO_NEXT 179 #define INST_TCLOO_NEXT_CLASS 180 +#define INST_YIELD_TO_INVOKE 181 + /* The last opcode */ -#define LAST_INST_OPCODE 180 +#define LAST_INST_OPCODE 181 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ac0ea12..575f227 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2494,9 +2494,12 @@ TEBCresume( TRACE_APPEND(("\n")); goto processExceptionReturn; - case INST_YIELD: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + { + CoroutineData *corPtr; + int yieldParameter; + case INST_YIELD: + corPtr = iPtr->execEnvPtr->corPtr; TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); if (!corPtr) { TRACE_APPEND(("ERROR: yield outside coroutine\n")); @@ -2510,11 +2513,63 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE_APPEND(("YIELD...\n")); + } else { + fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(OBJ_AT_TOS)); + } + fflush(stdout); + } +#endif + yieldParameter = 0; + Tcl_SetObjResult(interp, OBJ_AT_TOS); + goto doYield; + + case INST_YIELD_TO_INVOKE: + corPtr = iPtr->execEnvPtr->corPtr; + valuePtr = OBJ_AT_TOS; + if (!corPtr) { + TRACE(("[%.30s] => ERROR: yield outside coroutine\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); + } else { + /* FIXME: What is the right thing to trace? */ + fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(valuePtr)); + } + fflush(stdout); } #endif + + /* + * Install a tailcall record in the caller and continue with the + * yield. The yield is switched into multi-return mode (via the + * 'yieldParameter'). + */ + + Tcl_IncrRefCount(valuePtr); + iPtr->execEnvPtr = corPtr->callerEEPtr; + TclSetTailcall(interp, valuePtr); + iPtr->execEnvPtr = corPtr->eePtr; + yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + + doYield: /* TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ @@ -2529,11 +2584,8 @@ TEBCresume( pc++; cleanup = 1; TEBC_YIELD(); - - Tcl_SetObjResult(interp, OBJ_AT_TOS); TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(0), NULL, NULL); - + INT2PTR(yieldParameter), NULL, NULL); return TCL_OK; } @@ -2553,6 +2605,7 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG + /* FIXME: What is the right thing to trace? */ { register int i; diff --git a/generic/tclInt.h b/generic/tclInt.h index 7932a58..6ddb015 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3688,6 +3688,9 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From c7ed456462861ff7aaef003c61d8fc526466017d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 21 Jan 2014 18:16:37 +0000 Subject: Silence compiler warnings. --- generic/tclListObj.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d6ffa95..289cf2d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1031,8 +1031,8 @@ TclLindexList( { int index; /* Index into the list. */ - Tcl_Obj **indices; /* Array of list indices. */ - int indexCount; /* Size of the array of list indices. */ + Tcl_Obj **indices = NULL; /* Array of list indices. */ + int indexCount = -1; /* Size of the array of list indices. */ Tcl_Obj *indexListCopy; /* @@ -1117,8 +1117,8 @@ TclLindexFlat( Tcl_IncrRefCount(listPtr); for (i=0 ; i Date: Tue, 21 Jan 2014 21:32:53 +0000 Subject: Backport of bytearray append machinery to support bug fixes in ReadBytes. --- generic/tclBinary.c | 92 +++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclIO.c | 17 +++------- generic/tclInt.h | 2 ++ 3 files changed, 98 insertions(+), 13 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index dbb296b..68289f2 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -549,6 +549,98 @@ UpdateStringOfByteArray( /* *---------------------------------------------------------------------- * + * TclAppendBytesToByteArray -- + * + * This function appends an array of bytes to a byte array object. Note + * that the object *must* be unshared, and the array of bytes *must not* + * refer to the object being appended to. + * + * Results: + * None. + * + * Side effects: + * Allocates enough memory for an array of bytes of the requested total + * size, or possibly larger. [Bug 2992970] + * + *---------------------------------------------------------------------- + */ + +#define TCL_MIN_GROWTH 1024 +void +TclAppendBytesToByteArray( + Tcl_Obj *objPtr, + const unsigned char *bytes, + int len) +{ + ByteArray *byteArrayPtr; + int needed; + + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); + } + if (len < 0) { + Tcl_Panic("%s must be called with definite number of bytes to append", + "TclAppendBytesToByteArray"); + } + if (len == 0) { + /* Append zero bytes is a no-op. */ + return; + } + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); + } + byteArrayPtr = GET_BYTEARRAY(objPtr); + + if (len > INT_MAX - byteArrayPtr->used) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + needed = byteArrayPtr->used + len; + /* + * If we need to, resize the allocated space in the byte array. + */ + + if (needed > byteArrayPtr->allocated) { + ByteArray *ptr = NULL; + int attempt; + + if (needed <= INT_MAX/2) { + /* Try to allocate double the total space that is needed. */ + attempt = 2 * needed; + ptr = (ByteArray *) attemptckrealloc((void *) byteArrayPtr, + BYTEARRAY_SIZE(attempt)); + } + if (ptr == NULL) { + /* Try to allocate double the increment that is needed (plus). */ + unsigned int limit = INT_MAX - needed; + unsigned int extra = len + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); + + attempt = needed + growth; + ptr = (ByteArray *) attemptckrealloc((void *) byteArrayPtr, + BYTEARRAY_SIZE(attempt)); + } + if (ptr == NULL) { + /* Last chance: Try to allocate exactly what is needed. */ + attempt = needed; + ptr = (ByteArray *) ckrealloc((void *)byteArrayPtr, + BYTEARRAY_SIZE(attempt)); + } + byteArrayPtr = ptr; + byteArrayPtr->allocated = attempt; + SET_BYTEARRAY(objPtr, byteArrayPtr); + } + + if (bytes) { + memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); + } + byteArrayPtr->used += len; + TclInvalidateStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_BinaryObjCmd -- * * This procedure implements the "binary" Tcl command. diff --git a/generic/tclIO.c b/generic/tclIO.c index f1d8909..c1b7ee9 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5586,20 +5586,8 @@ ReadBytes( toRead = srcLen; } + TclAppendBytesToByteArray(objPtr, NULL, toRead); dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); - if (toRead > length - offset - 1) { - /* - * Double the existing size of the object or make enough room to hold - * all the characters we may get from the source buffer, whichever is - * larger. - */ - - length = offset * 2; - if (offset < toRead) { - length = offset + toRead + 1; - } - dst = (char *) Tcl_SetByteArrayLength(objPtr, length); - } dst += offset; if (statePtr->flags & INPUT_NEED_NL) { @@ -5607,6 +5595,7 @@ ReadBytes( if ((srcLen == 0) || (*src != '\n')) { *dst = '\r'; *offsetPtr += 1; + Tcl_SetByteArrayLength(objPtr, *offsetPtr); return 1; } *dst++ = '\n'; @@ -5619,11 +5608,13 @@ ReadBytes( dstWrote = toRead; if (TranslateInputEOL(statePtr, dst, src, &dstWrote, &srcRead) != 0) { if (dstWrote == 0) { + Tcl_SetByteArrayLength(objPtr, *offsetPtr); return -1; } } bufPtr->nextRemoved += srcRead; *offsetPtr += dstWrote; + Tcl_SetByteArrayLength(objPtr, *offsetPtr); return dstWrote; } diff --git a/generic/tclInt.h b/generic/tclInt.h index dc28b97..64d39a0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2477,6 +2477,8 @@ MODULE_SCOPE char tclEmptyString; *---------------------------------------------------------------- */ +MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, + const unsigned char *bytes, int len); MODULE_SCOPE void TclAdvanceContinuations(int* line, int** next, int loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); -- cgit v0.12 From abe23bfb4ef65eb899170e5ae7c4efc030294b31 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 21 Jan 2014 22:08:16 +0000 Subject: There is no need for ReadBytes() or its caller(s) to track how many bytes are actually stored in objPtr. The ByteArray Tcl_ObjType already has the machinery to take care of this. --- generic/tclIO.c | 47 ++++++++++++++++++----------------------------- 1 file changed, 18 insertions(+), 29 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c1b7ee9..4a5d8f1 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -208,7 +208,7 @@ static int HaveVersion(const Tcl_ChannelType *typePtr, static void PeekAhead(Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr); static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, - int charsLeft, int *offsetPtr); + int charsLeft); static int ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft, int *offsetPtr, int *factorPtr); static void RecycleBuffer(ChannelState *statePtr, @@ -5448,12 +5448,10 @@ DoReadChars( */ TclGetString(objPtr); + offset = 0; } - offset = 0; } else { - if (encoding == NULL) { - Tcl_GetByteArrayFromObj(objPtr, &offset); - } else { + if (encoding) { TclGetStringFromObj(objPtr, &offset); } } @@ -5462,7 +5460,7 @@ DoReadChars( copiedNow = -1; if (statePtr->inQueueHead != NULL) { if (encoding == NULL) { - copiedNow = ReadBytes(statePtr, objPtr, toRead, &offset); + copiedNow = ReadBytes(statePtr, objPtr, toRead); } else { copiedNow = ReadChars(statePtr, objPtr, toRead, &offset, &factor); @@ -5510,9 +5508,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED); - if (encoding == NULL) { - Tcl_SetByteArrayLength(objPtr, offset); - } else { + if (encoding) { Tcl_SetObjLength(objPtr, offset); } @@ -5540,13 +5536,11 @@ DoReadChars( * allocated to hold data read from the channel as needed. * * Results: - * The return value is the number of bytes appended to the object and - * *offsetPtr is filled with the total number of bytes in the object - * (greater than the return value if there were already bytes in the - * object). + * The return value is the number of bytes appended to the object, or + * -1 to indicate that zero bytes were read due to an EOF. * * Side effects: - * None. + * The storage of bytes in objPtr can cause (re-)allocation of memory. * *--------------------------------------------------------------------------- */ @@ -5559,24 +5553,18 @@ ReadBytes( * been allocated to hold data, not how many * bytes of data have been stored in the * object. */ - int bytesToRead, /* Maximum number of bytes to store, or < 0 to + int bytesToRead) /* Maximum number of bytes to store, or < 0 to * get all available bytes. Bytes are obtained * from the first buffer in the queue - even * if this number is larger than the number of * bytes available in the first buffer, only * the bytes from the first buffer are * returned. */ - int *offsetPtr) /* On input, contains how many bytes of objPtr - * have been used to hold data. On output, - * filled with how many bytes are now being - * used. */ { - int toRead, srcLen, offset, length, srcRead, dstWrote; + int toRead, srcLen, length, srcRead, dstWrote; ChannelBuffer *bufPtr; char *src, *dst; - offset = *offsetPtr; - bufPtr = statePtr->inQueueHead; src = RemovePoint(bufPtr); srcLen = BytesLeft(bufPtr); @@ -5586,16 +5574,17 @@ ReadBytes( toRead = srcLen; } + (void) Tcl_GetByteArrayFromObj(objPtr, &length); TclAppendBytesToByteArray(objPtr, NULL, toRead); - dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); - dst += offset; + dst = (char *) Tcl_GetByteArrayFromObj(objPtr, NULL); + dst += length; if (statePtr->flags & INPUT_NEED_NL) { ResetFlag(statePtr, INPUT_NEED_NL); if ((srcLen == 0) || (*src != '\n')) { *dst = '\r'; - *offsetPtr += 1; - Tcl_SetByteArrayLength(objPtr, *offsetPtr); + length += 1; + Tcl_SetByteArrayLength(objPtr, length); return 1; } *dst++ = '\n'; @@ -5608,13 +5597,13 @@ ReadBytes( dstWrote = toRead; if (TranslateInputEOL(statePtr, dst, src, &dstWrote, &srcRead) != 0) { if (dstWrote == 0) { - Tcl_SetByteArrayLength(objPtr, *offsetPtr); + Tcl_SetByteArrayLength(objPtr, length); return -1; } } bufPtr->nextRemoved += srcRead; - *offsetPtr += dstWrote; - Tcl_SetByteArrayLength(objPtr, *offsetPtr); + length += dstWrote; + Tcl_SetByteArrayLength(objPtr, length); return dstWrote; } -- cgit v0.12 From 78a75740ae5c82cc161e49e5e28a306fa9f2a580 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 22 Jan 2014 09:07:45 +0000 Subject: [a90d9331bc]: must not crash when yieldto called in vanishing namespace --- generic/tclBasic.c | 18 ++++------ generic/tclExecute.c | 11 +++++++ tests/coroutine.test | 92 +++++++++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 105 insertions(+), 16 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e355229..cb9428c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8431,11 +8431,13 @@ TclNRYieldToObjCmd( return TCL_ERROR; } - /* - * Add the tailcall in the caller env, then just yield. - * - * This is essentially code from TclNRTailcallObjCmd - */ + if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + return TCL_ERROR; + } /* * Add the tailcall in the caller env, then just yield. @@ -8444,15 +8446,9 @@ TclNRYieldToObjCmd( */ listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("yieldto failed to find the proper namespace"); - } TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - /* * Add the callback in the caller's env, then instruct TEBC to yield. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 575f227..6749120 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2542,6 +2542,17 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } + if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { + TRACE(("[%.30s] => ERROR: yield in deleted\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { diff --git a/tests/coroutine.test b/tests/coroutine.test index a360fd5..05b58c9 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -1,4 +1,4 @@ -# Commands covered: coroutine, yield, [info coroutine] +# Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files @@ -612,7 +612,6 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} - test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { proc foo {a b} {catch yield; return 1} } -cleanup { @@ -620,7 +619,6 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { } -body { coroutine demo lsort -command foo {a b} } -result {b a} - test coroutine-7.5 {return codes} { set result {} foreach code {0 1 2 3 4 5} { @@ -628,14 +626,12 @@ test coroutine-7.5 {return codes} { } set result } {0 1 2 3 4 5} - test coroutine-7.6 {Early yield crashes} { proc foo args {} trace add execution foo enter {catch yield} coroutine demo foo rename foo {} } {} - test coroutine-7.7 {Bug 2486550} -setup { interp hide {} yield } -body { @@ -644,6 +640,92 @@ test coroutine-7.7 {Bug 2486550} -setup { demo interp expose {} yield } -result ok +test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} # cleanup -- cgit v0.12 From 6e072443704a589149fea001df51f9870b78c323 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 22 Jan 2014 09:14:57 +0000 Subject: minor tidying up --- generic/tclBasic.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cb9428c..46b532b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8416,8 +8416,7 @@ TclNRYieldToObjCmd( { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; + Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); @@ -8431,7 +8430,7 @@ TclNRYieldToObjCmd( return TCL_ERROR; } - if (((Namespace *) TclGetCurrentNamespace(interp))->flags & NS_DYING) { + if (((Namespace *) nsPtr)->flags & NS_DYING) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto called in deleted namespace", -1)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", -- cgit v0.12 From 75c91591589708f766539aef319bfb7d80d7f0a8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Jan 2014 13:48:16 +0000 Subject: remove unused variable --- generic/tclBasic.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cb9428c..1aea752 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8417,7 +8417,6 @@ TclNRYieldToObjCmd( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); -- cgit v0.12 From 8af83eeffaedc4ee57ade8026a6f7166b86306d6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 24 Jan 2014 17:38:59 +0000 Subject: Eliminate the copy to a staging buffer when that serves no functional purpose. --- generic/tclIO.c | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index f1d8909..13494ca 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3787,16 +3787,17 @@ WriteChars( consumedSomething = 1; while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) { consumedSomething = 0; - stage = statePtr->outputStage; - stageMax = statePtr->bufSize; - stageLen = stageMax; - - toWrite = stageLen; - if (toWrite > srcLen) { - toWrite = srcLen; - } if (translate) { + stage = statePtr->outputStage; + stageMax = statePtr->bufSize; + stageLen = stageMax; + + toWrite = stageLen; + if (toWrite > srcLen) { + toWrite = srcLen; + } + if (savedLF) { /* * A '\n' was left over from last call to TranslateOutputEOL() @@ -3822,8 +3823,9 @@ WriteChars( stageLen = stageMax; } } else { - memcpy(stage, src, toWrite); - stageLen = toWrite; + stage = (char *) src; + stageLen = srcLen; + toWrite = stageLen; } src += toWrite; srcLen -= toWrite; -- cgit v0.12 From 9d0cf098518e48651256d556d750716978ea57df Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 25 Jan 2014 21:41:12 +0000 Subject: sync tcl.m4 with Tk version --- unix/configure | 2 ++ unix/tcl.m4 | 2 ++ 2 files changed, 4 insertions(+) diff --git a/unix/configure b/unix/configure index 7f8922b..6800fe2 100755 --- a/unix/configure +++ b/unix/configure @@ -6939,6 +6939,7 @@ fi TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' + TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a' echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 if test "${ac_cv_cygwin+set}" = set; then @@ -7652,6 +7653,7 @@ fi SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" + TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index e9795b8..c57111b 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1247,6 +1247,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' + TK_SHLIB_LD_EXTRAS='-Wl,--out-implib,$[@].a' AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, AC_TRY_COMPILE([ @@ -1563,6 +1564,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" + TK_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" -- cgit v0.12 From 8703cd164100a81207d646099206dcc3acdf05bb Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 27 Jan 2014 17:35:27 +0000 Subject: Revise the Tcl_Append* machinery to tolerate NULL bytes to append. Then have ReadChars() use that machinery to resize buffer receiving input, rather than invent its own version. Simplify ReadChars() callers. --- generic/tclIO.c | 67 +++++++++++--------------------------------------- generic/tclStringObj.c | 29 ++++++++++++++-------- 2 files changed, 34 insertions(+), 62 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 972cbd8..40573d7 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -210,7 +210,7 @@ static void PeekAhead(Channel *chanPtr, char **dstEndPtr, static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft); static int ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr, - int charsLeft, int *offsetPtr, int *factorPtr); + int charsLeft, int *factorPtr); static void RecycleBuffer(ChannelState *statePtr, ChannelBuffer *bufPtr, int mustDiscard); static int StackSetBlockMode(Channel *chanPtr, int mode); @@ -5425,7 +5425,7 @@ DoReadChars( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int offset, factor, copied, copiedNow, result; + int factor, copied, copiedNow, result; Tcl_Encoding encoding; #define UTF_EXPANSION_FACTOR 1024 @@ -5447,14 +5447,11 @@ DoReadChars( * We're going to access objPtr->bytes directly, so we must ensure * that this is actually a string object (otherwise it might have * been pure Unicode). + * + * Probably not needed anymore. */ TclGetString(objPtr); - offset = 0; - } - } else { - if (encoding) { - TclGetStringFromObj(objPtr, &offset); } } @@ -5464,8 +5461,7 @@ DoReadChars( if (encoding == NULL) { copiedNow = ReadBytes(statePtr, objPtr, toRead); } else { - copiedNow = ReadChars(statePtr, objPtr, toRead, &offset, - &factor); + copiedNow = ReadChars(statePtr, objPtr, toRead, &factor); } /* @@ -5510,9 +5506,6 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED); - if (encoding) { - Tcl_SetObjLength(objPtr, offset); - } /* * Update the notifier state so we don't block while there is still data @@ -5651,17 +5644,13 @@ ReadChars( * available in the first buffer, only the * characters from the first buffer are * returned. */ - int *offsetPtr, /* On input, contains how many bytes of objPtr - * have been used to hold data. On output, - * filled with how many bytes are now being - * used. */ int *factorPtr) /* On input, contains a guess of how many * bytes need to be allocated to hold the * result of converting N source bytes to * UTF-8. On output, contains another guess * based on the data seen so far. */ { - int toRead, factor, offset, spaceLeft, srcLen, dstNeeded; + int toRead, factor, srcLen, dstNeeded, numBytes; int srcRead, dstWrote, numChars, dstRead; ChannelBuffer *bufPtr; char *src, *dst; @@ -5669,7 +5658,6 @@ ReadChars( int encEndFlagSuppressed = 0; factor = *factorPtr; - offset = *offsetPtr; bufPtr = statePtr->inQueueHead; src = RemovePoint(bufPtr); @@ -5687,37 +5675,9 @@ ReadChars( */ dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - spaceLeft = objPtr->length - offset; - - if (dstNeeded > spaceLeft) { - /* - * Double the existing size of the object or make enough room to hold - * all the characters we want from the source buffer, whichever is - * larger. - */ - - int length = offset + ((offset < dstNeeded) ? dstNeeded : offset); - - if (Tcl_AttemptSetObjLength(objPtr, length) == 0) { - length = offset + dstNeeded; - if (Tcl_AttemptSetObjLength(objPtr, length) == 0) { - dstNeeded = TCL_UTF_MAX - 1 + toRead; - length = offset + dstNeeded; - Tcl_SetObjLength(objPtr, length); - } - } - spaceLeft = length - offset; - } - if (toRead == srcLen) { - /* - * Want to convert the whole buffer in one pass. If we have enough - * space, convert it using all available space in object rather than - * using the factor. - */ - - dstNeeded = spaceLeft; - } - dst = objPtr->bytes + offset; + (void) TclGetStringFromObj(objPtr, &numBytes); + Tcl_AppendToObj(objPtr, NULL, dstNeeded); + dst = TclGetString(objPtr) + numBytes; /* * [Bug 1462248]: The cause of the crash reported in this bug is this: @@ -5788,7 +5748,7 @@ ReadChars( *dst = '\r'; } statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - *offsetPtr += 1; + Tcl_SetObjLength(objPtr, numBytes + 1); if (encEndFlagSuppressed) { statePtr->inputEncodingFlags |= TCL_ENCODING_END; @@ -5829,6 +5789,7 @@ ReadChars( SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); } + Tcl_SetObjLength(objPtr, numBytes); return -1; } @@ -5853,7 +5814,8 @@ ReadChars( memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; - return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr); + Tcl_SetObjLength(objPtr, numBytes); + return ReadChars(statePtr, objPtr, charsToRead, factorPtr); } dstRead = dstWrote; @@ -5866,6 +5828,7 @@ ReadChars( */ if (dstWrote == 0) { + Tcl_SetObjLength(objPtr, numBytes); return -1; } statePtr->inputEncodingState = oldState; @@ -5905,7 +5868,7 @@ ReadChars( if (dstWrote > srcRead + 1) { *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; } - *offsetPtr += dstWrote; + Tcl_SetObjLength(objPtr, numBytes + dstWrote); return numChars; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index a929d04..d96d814 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1139,7 +1139,8 @@ Tcl_AppendLimitedToObj( if (ellipsis == NULL) { ellipsis = "..."; } - toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; + toCopy = (bytes == NULL) ? limit + : Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; } /* @@ -1386,7 +1387,8 @@ AppendUnicodeToUnicodeRep( * due to the reallocs below. */ int offset = -1; - if (unicode >= stringPtr->unicode && unicode <= stringPtr->unicode + if (unicode && unicode >= stringPtr->unicode + && unicode <= stringPtr->unicode + stringPtr->uallocated / sizeof(Tcl_UniChar)) { offset = unicode - stringPtr->unicode; } @@ -1405,8 +1407,10 @@ AppendUnicodeToUnicodeRep( * trailing null. */ - memcpy(stringPtr->unicode + stringPtr->numChars, unicode, - appendNumChars * sizeof(Tcl_UniChar)); + if (unicode) { + memcpy(stringPtr->unicode + stringPtr->numChars, unicode, + appendNumChars * sizeof(Tcl_UniChar)); + } stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; stringPtr->allocated = 0; @@ -1478,8 +1482,8 @@ AppendUtfToUnicodeRep( int numBytes) /* Number of bytes of "bytes" to convert. */ { Tcl_DString dsPtr; - int numChars; - Tcl_UniChar *unicode; + int numChars = numBytes; + Tcl_UniChar *unicode = NULL; if (numBytes < 0) { numBytes = (bytes ? strlen(bytes) : 0); @@ -1489,8 +1493,11 @@ AppendUtfToUnicodeRep( } Tcl_DStringInit(&dsPtr); - numChars = Tcl_NumUtfChars(bytes, numBytes); - unicode = (Tcl_UniChar *)Tcl_UtfToUniCharDString(bytes, numBytes, &dsPtr); + if (bytes) { + numChars = Tcl_NumUtfChars(bytes, numBytes); + unicode = (Tcl_UniChar *) Tcl_UtfToUniCharDString(bytes, numBytes, + &dsPtr); + } AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); Tcl_DStringFree(&dsPtr); } @@ -1547,7 +1554,7 @@ AppendUtfToUtfRep( * due to the reallocs below. */ int offset = -1; - if (bytes >= objPtr->bytes + if (bytes && bytes >= objPtr->bytes && bytes <= objPtr->bytes + objPtr->length) { offset = bytes - objPtr->bytes; } @@ -1585,7 +1592,9 @@ AppendUtfToUtfRep( stringPtr->numChars = -1; stringPtr->hasUnicode = 0; - memcpy(objPtr->bytes + oldLength, bytes, (size_t) numBytes); + if (bytes) { + memcpy(objPtr->bytes + oldLength, bytes, (size_t) numBytes); + } objPtr->bytes[newLength] = 0; objPtr->length = newLength; } -- cgit v0.12 From b555fa4d44d0b13c0c4e61643e22f6c3479baf4e Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 11:04:57 +0000 Subject: WIP --- generic/tclIO.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 13494ca..fdb0ddd 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3779,6 +3779,74 @@ WriteChars( translate = (statePtr->flags & CHANNEL_LINEBUFFERED) || (statePtr->outputTranslation != TCL_TRANSLATE_LF); +#if 0 + consumedSomething = 1; + while (consumedSomething && (srcLen + saved + endEncoding > 0)) { + void *lastNewLine; + int srcLimit; + + /* Get space to write into */ + bufPtr = statePtr->curOutPtr; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(statePtr->bufSize); + statePtr->curOutPtr = bufPtr; + if (saved) { + /* + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. + */ + + memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + bufPtr->nextAdded += saved; + saved = 0; + } + } + dst = InsertPoint(bufPtr); + dstLen = SpaceLeft(bufPtr); + + /* + * We have dstLen bytes to write to. The most source bytes + * that could possibly fill that is TCL_UTF_MAX * dstLen. + */ + + srcLimit = TCL_UTF_MAX * dstLen; + if (srcLen < srcLimit) { + srcLimit = srcLen; + } + lastNewLine = memchr(src, '\n', srcLimit); + + if (lastNewLine) { + srcLimit = lastNewLine - src; + } + + result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + + statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + + if ((result != 0) && (srcRead + dstWrote == 0)) { + fprintf(stdout, "WDTH?\n"); fflush(stdout); + } + bufPtr->nextAdded += dstWrote; + if (IsBufferOverflowing(bufPtr)) { + /* + * When translating from UTF-8 to external encoding, we + * allowed the translation to produce a character that crossed + * the end of the output buffer, so that we would get a + * completely full buffer before flushing it. The extra bytes + * will be moved to the beginning of the next buffer. + */ + + saved = -SpaceLeft(bufPtr); + memcpy(safe, dst + dstLen, (size_t) saved); + bufPtr->nextAdded = bufPtr->bufLength; + } + + + } +#else /* * Loop over all UTF-8 characters in src, storing them in staging buffer * with proper EOL translation. @@ -3933,6 +4001,7 @@ WriteChars( } } } +#endif /* * If nothing was written and it happened because there was no progress in -- cgit v0.12 From 15c8e0fd00cb9a49203a6de6cd05ec758daf519e Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 18:51:59 +0000 Subject: Working code with no staging buffer use. --- generic/tclIO.c | 128 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 97 insertions(+), 31 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index fdb0ddd..7203739 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3756,18 +3756,21 @@ WriteChars( char *dst, *stage; int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote; int stageLen, toWrite, stageRead, endEncoding, result; - int consumedSomething, translate; + int consumedSomething, translate, flushed, needNlFlush; Tcl_Encoding encoding; char safe[BUFFER_PADDING]; + char *nextNewLine = NULL; if (srcLen) { WillWrite(chanPtr); } + flushed = 0; total = 0; sawLF = 0; savedLF = 0; saved = 0; + needNlFlush = 0; encoding = statePtr->encoding; /* @@ -3779,46 +3782,39 @@ WriteChars( translate = (statePtr->flags & CHANNEL_LINEBUFFERED) || (statePtr->outputTranslation != TCL_TRANSLATE_LF); -#if 0 +#if 1 + if (translate) { + nextNewLine = memchr(src, '\n', srcLen); + } consumedSomething = 1; while (consumedSomething && (srcLen + saved + endEncoding > 0)) { - void *lastNewLine; - int srcLimit; + int srcRead; + int srcLimit = srcLen; + + consumedSomething = 0; + if (nextNewLine) { + srcLimit = nextNewLine - src; + } /* Get space to write into */ bufPtr = statePtr->curOutPtr; if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); statePtr->curOutPtr = bufPtr; - if (saved) { - /* - * Here's some translated bytes left over from the last buffer - * that we need to stick at the beginning of this buffer. - */ + } + if (saved) { + /* + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. + */ - memcpy(InsertPoint(bufPtr), safe, (size_t) saved); - bufPtr->nextAdded += saved; - saved = 0; - } + memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + bufPtr->nextAdded += saved; + saved = 0; } dst = InsertPoint(bufPtr); dstLen = SpaceLeft(bufPtr); - /* - * We have dstLen bytes to write to. The most source bytes - * that could possibly fill that is TCL_UTF_MAX * dstLen. - */ - - srcLimit = TCL_UTF_MAX * dstLen; - if (srcLen < srcLimit) { - srcLimit = srcLen; - } - lastNewLine = memchr(src, '\n', srcLimit); - - if (lastNewLine) { - srcLimit = lastNewLine - src; - } - result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, @@ -3827,9 +3823,59 @@ WriteChars( statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; if ((result != 0) && (srcRead + dstWrote == 0)) { - fprintf(stdout, "WDTH?\n"); fflush(stdout); + /* We're reading from invalid/incomplete UTF-8 */ + break; } + + consumedSomething = 1; bufPtr->nextAdded += dstWrote; + src += srcRead; + srcLen -= srcRead; + total += dstWrote; + dst += dstWrote; + dstLen -= dstWrote; + + if (src == nextNewLine && dstLen > 0) { + static char crln[3] = "\r\n"; + char *nl = NULL; + int nlLen = 0; + + switch (statePtr->outputTranslation) { + case TCL_TRANSLATE_LF: + nl = crln + 1; + nlLen = 1; + break; + case TCL_TRANSLATE_CR: + nl = crln; + nlLen = 1; + break; + case TCL_TRANSLATE_CRLF: + nl = crln; + nlLen = 2; + break; + default: + Tcl_Panic("unknown output translation requested"); + break; + } + + result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + + if (srcRead != nlLen) { + Tcl_Panic("Can This Happen?"); + } + + bufPtr->nextAdded += dstWrote; + src++; + srcLen--; + total += dstWrote; + dst += dstWrote; + dstLen -= dstWrote; + nextNewLine = memchr(src, '\n', srcLen); + needNlFlush = 1; + } if (IsBufferOverflowing(bufPtr)) { /* * When translating from UTF-8 to external encoding, we @@ -3843,8 +3889,28 @@ WriteChars( memcpy(safe, dst + dstLen, (size_t) saved); bufPtr->nextAdded = bufPtr->bufLength; } - - + + if ((srcLen + saved == 0) && (result == 0)) { + endEncoding = 0; + } + + /* FLUSH ! */ + if (IsBufferFull(bufPtr)) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + flushed += statePtr->bufSize; + if (saved == 0 || src[-1] != '\n') { + needNlFlush = 0; + } + } + } + if ((flushed < total) && (statePtr->flags & CHANNEL_UNBUFFERED || + (needNlFlush && statePtr->flags & CHANNEL_LINEBUFFERED))) { + SetFlag(statePtr, BUFFER_READY); + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } } #else /* -- cgit v0.12 From 589975911949b9661152610ca04cf5e8e233a109 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 20:19:39 +0000 Subject: tidy things up --- generic/tclIO.c | 211 +++++--------------------------------------------------- 1 file changed, 17 insertions(+), 194 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7203739..c7c11e7 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3752,46 +3752,30 @@ WriteChars( { ChannelState *statePtr = chanPtr->state; /* State info for channel */ - ChannelBuffer *bufPtr; - char *dst, *stage; - int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote; - int stageLen, toWrite, stageRead, endEncoding, result; - int consumedSomething, translate, flushed, needNlFlush; - Tcl_Encoding encoding; - char safe[BUFFER_PADDING]; char *nextNewLine = NULL; + int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0; + Tcl_Encoding encoding = statePtr->encoding; if (srcLen) { WillWrite(chanPtr); } - flushed = 0; - total = 0; - sawLF = 0; - savedLF = 0; - saved = 0; - needNlFlush = 0; - encoding = statePtr->encoding; - /* * Write the terminated escape sequence even if srcLen is 0. */ endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0); - translate = (statePtr->flags & CHANNEL_LINEBUFFERED) - || (statePtr->outputTranslation != TCL_TRANSLATE_LF); - -#if 1 - if (translate) { + if ((statePtr->flags & CHANNEL_LINEBUFFERED) + || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) { nextNewLine = memchr(src, '\n', srcLen); } - consumedSomething = 1; - while (consumedSomething && (srcLen + saved + endEncoding > 0)) { - int srcRead; - int srcLimit = srcLen; - consumedSomething = 0; + while (srcLen + saved + endEncoding > 0) { + ChannelBuffer *bufPtr; + char *dst, safe[BUFFER_PADDING]; + int result, srcRead, dstLen, dstWrote, srcLimit = srcLen; + if (nextNewLine) { srcLimit = nextNewLine - src; } @@ -3820,14 +3804,18 @@ WriteChars( &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + /* See chan-io-1.[89]. Tcl Bug 506297. */ statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; - if ((result != 0) && (srcRead + dstWrote == 0)) { + if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { /* We're reading from invalid/incomplete UTF-8 */ + if (total == 0) { + Tcl_SetErrno(EINVAL); + return -1; + } break; } - consumedSomething = 1; bufPtr->nextAdded += dstWrote; src += srcRead; srcLen -= srcRead; @@ -3876,6 +3864,7 @@ WriteChars( nextNewLine = memchr(src, '\n', srcLen); needNlFlush = 1; } + if (IsBufferOverflowing(bufPtr)) { /* * When translating from UTF-8 to external encoding, we @@ -3890,11 +3879,10 @@ WriteChars( bufPtr->nextAdded = bufPtr->bufLength; } - if ((srcLen + saved == 0) && (result == 0)) { + if ((srcLen + saved == 0) && (result == TCL_OK)) { endEncoding = 0; } - /* FLUSH ! */ if (IsBufferFull(bufPtr)) { if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; @@ -3912,172 +3900,7 @@ WriteChars( return -1; } } -#else - /* - * Loop over all UTF-8 characters in src, storing them in staging buffer - * with proper EOL translation. - */ - - consumedSomething = 1; - while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) { - consumedSomething = 0; - - if (translate) { - stage = statePtr->outputStage; - stageMax = statePtr->bufSize; - stageLen = stageMax; - - toWrite = stageLen; - if (toWrite > srcLen) { - toWrite = srcLen; - } - - if (savedLF) { - /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in the staging buffer. If the channel - * is line-based, we will need to flush the output buffer (after - * translating the staging buffer). - */ - - *stage++ = '\n'; - stageLen--; - sawLF++; - } - if (TranslateOutputEOL(statePtr, stage, src, &stageLen, &toWrite)) { - sawLF++; - } - - stage -= savedLF; - stageLen += savedLF; - savedLF = 0; - - if (stageLen > stageMax) { - savedLF = 1; - stageLen = stageMax; - } - } else { - stage = (char *) src; - stageLen = srcLen; - toWrite = stageLen; - } - src += toWrite; - srcLen -= toWrite; - - /* - * Loop over all UTF-8 characters in staging buffer, converting them - * to external encoding, storing them in output buffer. - */ - - while (stageLen + saved + endEncoding > 0) { - bufPtr = statePtr->curOutPtr; - if (bufPtr == NULL) { - bufPtr = AllocChannelBuffer(statePtr->bufSize); - statePtr->curOutPtr = bufPtr; - } - dst = InsertPoint(bufPtr); - dstLen = SpaceLeft(bufPtr); - if (saved != 0) { - /* - * Here's some translated bytes left over from the last buffer - * that we need to stick at the beginning of this buffer. - */ - - memcpy(dst, safe, (size_t) saved); - bufPtr->nextAdded += saved; - dst += saved; - dstLen -= saved; - saved = 0; - } - - result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen, - statePtr->outputEncodingFlags, - &statePtr->outputEncodingState, dst, - dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL); - - /* - * Fix for SF #506297, reported by Martin Forssen - * . - * - * The encoding chosen in the script exposing the bug writes out - * three intro characters when TCL_ENCODING_START is set, but does - * not consume any input as TCL_ENCODING_END is cleared. As some - * output was generated the enclosing loop calls UtfToExternal - * again, again with START set. Three more characters in the out - * and still no use of input ... To break this infinite loop we - * remove TCL_ENCODING_START from the set of flags after the first - * call (no condition is required, the later calls remove an unset - * flag, which is a no-op). This causes the subsequent calls to - * UtfToExternal to consume and convert the actual input. - */ - - statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; - - /* - * The following code must be executed only when result is not 0. - */ - - if ((result != 0) && (stageRead + dstWrote == 0)) { - /* - * We have an incomplete UTF-8 character at the end of the - * staging buffer. It will get moved to the beginning of the - * staging buffer followed by more bytes from src. - */ - - src -= stageLen; - srcLen += stageLen; - stageLen = 0; - savedLF = 0; - break; - } - bufPtr->nextAdded += dstWrote; - if (IsBufferOverflowing(bufPtr)) { - /* - * When translating from UTF-8 to external encoding, we - * allowed the translation to produce a character that crossed - * the end of the output buffer, so that we would get a - * completely full buffer before flushing it. The extra bytes - * will be moved to the beginning of the next buffer. - */ - - saved = -SpaceLeft(bufPtr); - memcpy(safe, dst + dstLen, (size_t) saved); - bufPtr->nextAdded = bufPtr->bufLength; - } - if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { - return -1; - } - - total += dstWrote; - stage += stageRead; - stageLen -= stageRead; - sawLF = 0; - - consumedSomething = 1; - - /* - * If all translated characters are written to the buffer, - * endEncoding is set to 0 because the escape sequence may be - * output. - */ - - if ((stageLen + saved == 0) && (result == 0)) { - endEncoding = 0; - } - } - } -#endif - - /* - * If nothing was written and it happened because there was no progress in - * the UTF conversion, we throw an error. - */ - - if (!consumedSomething && (total == 0)) { - Tcl_SetErrno(EINVAL); - return -1; - } return total; } -- cgit v0.12 From 9df81fccd3a1cfd90a732c1116cb3bf467bbe802 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Jan 2014 20:23:26 +0000 Subject: The outputStage field is now unused, so never allocate it. --- generic/tclIO.c | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c7c11e7..4ae9ec0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1489,12 +1489,7 @@ Tcl_CreateChannel( statePtr->timer = NULL; statePtr->csPtrR = NULL; statePtr->csPtrW = NULL; - statePtr->outputStage = NULL; - if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = (char *) - ckalloc((unsigned) (statePtr->bufSize + 2)); - } /* * As we are creating the channel, it is obviously the top for now. @@ -2757,10 +2752,6 @@ CloseChannel( } Tcl_FreeEncoding(statePtr->encoding); - if (statePtr->outputStage != NULL) { - ckfree((char *) statePtr->outputStage); - statePtr->outputStage = NULL; - } } /* @@ -7151,15 +7142,6 @@ Tcl_SetChannelBufferSize( statePtr = ((Channel *) chan)->state; statePtr->bufSize = sz; - - if (statePtr->outputStage != NULL) { - ckfree((char *) statePtr->outputStage); - statePtr->outputStage = NULL; - } - if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = (char *) - ckalloc((unsigned) (statePtr->bufSize + 2)); - } } /* @@ -7800,17 +7782,6 @@ Tcl_SetChannelOption( statePtr->inQueueTail = NULL; } - /* - * If encoding or bufsize changes, need to update output staging buffer. - */ - - if (statePtr->outputStage != NULL) { - ckfree(statePtr->outputStage); - statePtr->outputStage = NULL; - } - if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = ckalloc((unsigned) (statePtr->bufSize + 2)); - } return TCL_OK; } -- cgit v0.12 From 60e360f12b1c25a8e89f5893a564ca17d3b99217 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 29 Jan 2014 13:59:32 +0000 Subject: Compile [string is] with character classes in a non-awful way. Needs more work to make resulting bytecode disassemble nicely. --- generic/tclCompCmdsSZ.c | 99 ++++++++++++++++++++++++++++++++++++++++++++----- generic/tclCompile.c | 5 +++ generic/tclCompile.h | 37 +++++++++++++++++- generic/tclExecute.c | 19 ++++++++++ 4 files changed, 150 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 1a69a89..639b4a5 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -452,6 +452,7 @@ TclCompileStringIsCmd( STR_IS_XDIGIT }; int t, range, allowEmpty = 0, end; + InstStringClassType strClassType; Tcl_Obj *isClass; if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { @@ -486,7 +487,7 @@ TclCompileStringIsCmd( tokenPtr = TokenAfter(tokenPtr); if (parsePtr->numWords == 3) { - allowEmpty = (t != STR_IS_LIST); + allowEmpty = 1; } else { if (!GotLiteral(tokenPtr, "-strict")) { return TCL_ERROR; @@ -496,30 +497,77 @@ TclCompileStringIsCmd( #undef GotLiteral /* - * Some types are not currently handled. Character classes are a prime - * example of this. + * Compile the code. There are several main classes of check here. + * 1. Character classes + * 2. Booleans + * 3. Integers + * 4. Floats + * 5. Lists */ + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + switch ((enum isClasses) t) { case STR_IS_ALNUM: + strClassType = STR_CLASS_ALNUM; + goto compileStrClass; case STR_IS_ALPHA: + strClassType = STR_CLASS_ALPHA; + goto compileStrClass; case STR_IS_ASCII: + strClassType = STR_CLASS_ASCII; + goto compileStrClass; case STR_IS_CONTROL: + strClassType = STR_CLASS_CONTROL; + goto compileStrClass; case STR_IS_DIGIT: + strClassType = STR_CLASS_DIGIT; + goto compileStrClass; case STR_IS_GRAPH: + strClassType = STR_CLASS_GRAPH; + goto compileStrClass; case STR_IS_LOWER: + strClassType = STR_CLASS_LOWER; + goto compileStrClass; case STR_IS_PRINT: + strClassType = STR_CLASS_PRINT; + goto compileStrClass; case STR_IS_PUNCT: + strClassType = STR_CLASS_PUNCT; + goto compileStrClass; case STR_IS_SPACE: + strClassType = STR_CLASS_SPACE; + goto compileStrClass; case STR_IS_UPPER: + strClassType = STR_CLASS_UPPER; + goto compileStrClass; case STR_IS_WORD: + strClassType = STR_CLASS_WORD; + goto compileStrClass; case STR_IS_XDIGIT: - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + strClassType = STR_CLASS_XDIGIT; + compileStrClass: + if (allowEmpty) { + OP1( STR_CLASS, strClassType); + } else { + int over, over2; + + OP( DUP); + OP1( STR_CLASS, strClassType); + JUMP1( JUMP_TRUE, over); + OP( POP); + PUSH( "0"); + JUMP1( JUMP, over2); + FIXJUMP1(over); + PUSH( ""); + OP( STR_NEQ); + FIXJUMP1(over2); + } + return TCL_OK; case STR_IS_BOOL: case STR_IS_FALSE: case STR_IS_TRUE: - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); OP( TRY_CVT_TO_BOOLEAN); switch (t) { int over, over2; @@ -569,7 +617,6 @@ TclCompileStringIsCmd( case STR_IS_DOUBLE: { int satisfied, isEmpty; - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); if (allowEmpty) { OP( DUP); PUSH( ""); @@ -598,7 +645,6 @@ TclCompileStringIsCmd( case STR_IS_INT: case STR_IS_WIDE: case STR_IS_ENTIER: - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); if (allowEmpty) { int testNumType; @@ -638,7 +684,6 @@ TclCompileStringIsCmd( return TCL_OK; case STR_IS_LIST: - CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); @@ -653,7 +698,8 @@ TclCompileStringIsCmd( OP( LNOT); return TCL_OK; } - return TCL_ERROR; + + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int @@ -1171,6 +1217,41 @@ TclCompileStringToTitleCmd( } /* + * Support definitions for the [string is] compilation. + */ + +static int +UniCharIsAscii( + int character) +{ + return (character >= 0) && (character < 0x80); +} + +static int +UniCharIsHexDigit( + int character) +{ + return (character >= 0) && (character < 0x80) && isxdigit(character); +} + +StringClassDesc const tclStringClassTable[] = { + {"alnum", Tcl_UniCharIsAlnum}, + {"alpha", Tcl_UniCharIsAlpha}, + {"ascii", UniCharIsAscii}, + {"control", Tcl_UniCharIsControl}, + {"digit", Tcl_UniCharIsDigit}, + {"graph", Tcl_UniCharIsGraph}, + {"lower", Tcl_UniCharIsLower}, + {"print", Tcl_UniCharIsPrint}, + {"punct", Tcl_UniCharIsPunct}, + {"space", Tcl_UniCharIsSpace}, + {"upper", Tcl_UniCharIsUpper}, + {"word", Tcl_UniCharIsWordChar}, + {"xdigit", UniCharIsHexDigit}, + {NULL, NULL} +}; + +/* *---------------------------------------------------------------------- * * TclCompileSubstCmd -- diff --git a/generic/tclCompile.c b/generic/tclCompile.c index fdc3e26..08a7a4c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -644,6 +644,11 @@ InstructionDesc const tclInstructionTable[] = { {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, /* Try converting stktop to boolean if possible. No errors. * Stack: ... value => ... value isStrictBool */ + {"strclass", 2, 0, 1, {OPERAND_UINT1}}, + /* See if all the characters of the given string are a member of the + * specified (by opnd) character class. Note that an empty string will + * satisfy the class check (standard definition of "all"). + * Stack: ... stringValue => ... boolean */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index d6d515d..502a2e6 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -797,9 +797,10 @@ typedef struct ByteCode { #define INST_NUM_TYPE 182 #define INST_TRY_CVT_TO_BOOLEAN 183 +#define INST_STR_CLASS 184 /* The last opcode */ -#define LAST_INST_OPCODE 183 +#define LAST_INST_OPCODE 184 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -844,6 +845,40 @@ typedef struct InstructionDesc { MODULE_SCOPE InstructionDesc const tclInstructionTable[]; /* + * Constants used by INST_STRING_CLASS to indicate character classes. These + * correspond closely by name with what [string is] can support, but there is + * no requirement to keep the values the same. + */ + +typedef enum InstStringClassType { + STR_CLASS_ALNUM, /* Unicode alphabet or digit characters. */ + STR_CLASS_ALPHA, /* Unicode alphabet characters. */ + STR_CLASS_ASCII, /* Characters in range U+000000..U+00007F. */ + STR_CLASS_CONTROL, /* Unicode control characters. */ + STR_CLASS_DIGIT, /* Unicode digit characters. */ + STR_CLASS_GRAPH, /* Unicode printing characters, excluding + * space. */ + STR_CLASS_LOWER, /* Unicode lower-case alphabet characters. */ + STR_CLASS_PRINT, /* Unicode printing characters, including + * spaces. */ + STR_CLASS_PUNCT, /* Unicode punctuation characters. */ + STR_CLASS_SPACE, /* Unicode space characters. */ + STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */ + STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector + * punctuation) characters. */ + STR_CLASS_XDIGIT /* Characters that can be used as digits in + * hexadecimal numbers ([0-9A-Fa-f]). */ +} InstStringClassType; + +typedef struct StringClassDesc { + const char *name; /* Name of the class. */ + int (*comparator)(int); /* Function to test if a single unicode + * character is a member of the class. */ +} StringClassDesc; + +MODULE_SCOPE StringClassDesc const tclStringClassTable[]; + +/* * Compilation of some Tcl constructs such as if commands and the logical or * (||) and logical and (&&) operators in expressions requires the generation * of forward jumps. Since the PC target of these jumps isn't known when the diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 916de17..58d85e1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5810,6 +5810,25 @@ TEBCresume( TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); + + case INST_STR_CLASS: + opnd = TclGetInt1AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, + O2S(valuePtr))); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + match = 1; + if (length > 0) { + end = ustring1 + length; + for (p=ustring1 ; p Date: Wed, 29 Jan 2014 23:18:58 +0000 Subject: Squashed C99 syntax breaking the native AIX cc. --- generic/tclAssembly.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7b775a9..55a0c3f 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -50,7 +50,7 @@ typedef enum BasicBlockCatchState { BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ BBCS_NONE, /* Block is outside of any catch */ BBCS_INCATCH, /* Block is within a catch context */ - BBCS_CAUGHT, /* Block is within a catch context and + BBCS_CAUGHT /* Block is within a catch context and * may be executed after an exception fires */ } BasicBlockCatchState; @@ -121,7 +121,7 @@ enum BasicBlockFlags { * marking it as the start of a 'catch' * sequence. The 'jumpTarget' is the exception * exit from the catch block. */ - BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction, + BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction, * unwinding the catch from the exception * stack. */ }; @@ -184,7 +184,7 @@ typedef enum TalInstType { * produces N */ ASSEM_SINT1, /* One 1-byte signed-integer operand * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by + ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by * LVT entry. Fixed arity */ } TalInstType; -- cgit v0.12 From d7757d423e285ae0c112407d1dcc60191aa0b4bd Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 30 Jan 2014 11:02:51 +0000 Subject: win/tclWinChan.c Tcl_InitNotifier: Bug [2413550] Avoid reopening of serial channels which causes issues with Bluetooth virtual com. Patch by Rolf Schroedter. --- ChangeLog | 6 +++ win/tclWinChan.c | 151 ++++++++++++++++++++++++++++++++++++++++++++++++++++- win/tclWinInt.h | 2 +- win/tclWinSerial.c | 25 +++++---- 4 files changed, 171 insertions(+), 13 deletions(-) diff --git a/ChangeLog b/ChangeLog index fd8c7c7..aec77d9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -7,6 +7,12 @@ this log file. You may still find useful things in it, but the Timeline is a better first place to look now. ============================================================================ +2014-01-30 Harald Oehlmann + + * win/tclWinChan.c Tcl_InitNotifier: Bug [2413550] + Avoid reopening of serial channels which causes issues with + Bluetooth virtual com. Patch by Rolf Schroedter. + 2013-08-30 Don Porter * generic/tcl.h: Bump to 8.5.15 for release. diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 89d898f..19e3655 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -95,7 +95,7 @@ static void FileThreadActionProc(ClientData instanceData, static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static DWORD FileGetType(HANDLE handle); - +static int NativeIsComPort(CONST TCHAR *nativeName); /* * This structure describes the channel type structure for file based IO. */ @@ -904,6 +904,33 @@ TclpOpenFileChannel( } /* + * [2413550] Avoid double-open of serial ports on Windows + * Special handling for Windows serial ports by a "name-hint" + * to directly open it with the OVERLAPPED flag set. + */ + + if( NativeIsComPort(nativeName) ) { + + handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode); + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open serial \"", + TclGetString(pathPtr), "\": ", + Tcl_PosixError(interp), NULL); + } + return NULL; + } + + /* + * For natively named Windows serial ports we are done. + */ + channel = TclWinOpenSerialChannel(handle, channelName, + channelPermissions); + + return channel; + } + /* * Set up the file sharing mode. We want to allow simultaneous access. */ @@ -935,11 +962,15 @@ TclpOpenFileChannel( switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* + * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * already done with the code above. + * Here we handle all other serial port names. + * * Reopen channel for OVERLAPPED operation. Normally this shouldn't * fail, because the channel exists. */ - handle = TclWinSerialReopen(handle, nativeName, accessMode); + handle = TclWinSerialOpen(handle, nativeName, accessMode); if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { @@ -1476,6 +1507,122 @@ FileGetType( return type; } + /* + *---------------------------------------------------------------------- + * + * NativeIsComPort -- + * + * Determines if a path refers to a Windows serial port. + * A simple and efficient solution is to use a "name hint" to detect + * COM ports by their filename instead of resorting to a syscall + * to detect serialness after the fact. + * The following patterns cover common serial port names: + * COM[1-9]:? + * //./COM[0-9]+ + * \\.\COM[0-9]+ + * + * Results: + * 1 = serial port, 0 = not. + * + *---------------------------------------------------------------------- + */ + +static int +NativeIsComPort( + const TCHAR *nativePath) /* Path of file to access, native encoding. */ +{ + /* + * Use wide-char or plain character case-insensitive comparison + */ + if (tclWinProcs->useWide) { + const WCHAR *p = (const WCHAR *) nativePath; + int i, len = wcslen(p); + + /* + * 1. Look for com[1-9]:? + */ + + if ( (len >= 4) && (len <= 5) + && (_wcsnicmp(p, L"com", 3) == 0) ) { + /* + * The 4th character must be a digit 1..9 optionally followed by a ":" + */ + + if ( (p[3] < L'1') || (p[3] > L'9') ) { + return 0; + } + if ( (len == 5) && (p[4] != L':') ) { + return 0; + } + return 1; + } + + /* + * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + */ + + if ( (len >= 8) && ( + (_wcsnicmp(p, L"//./com", 7) == 0) + || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) ) + { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for ( i=7; i '9') ) { + return 0; + } + } + return 1; + } + + } else { + const char *p = (const char *) nativePath; + int i, len = strlen(p); + + /* + * 1. Look for com[1-9]:? + */ + + if ( (len >= 4) && (len <= 5) + && (strnicmp(p, "com", 3) == 0) ) { + /* + * The 4th character must be a digit 1..9 optionally followed by a ":" + */ + + if ( (p[3] < '1') || (p[3] > '9') ) { + return 0; + } + if ( (len == 5) && (p[4] != ':') ) { + return 0; + } + return 1; + } + + /* + * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + */ + + if ( (len >= 8) && ( + (strnicmp(p, "//./com", 7) == 0) + || (strnicmp(p, "\\\\.\\com", 7) == 0) ) ) + { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for ( i=7; i '9') ) { + return 0; + } + } + return 1; + } + } + return 0; +} + /* * Local Variables: * mode: c diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 3d5e275..ccf48bb 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -187,7 +187,7 @@ MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); MODULE_SCOPE void TclWinResetInterfaceEncodings(); -MODULE_SCOPE HANDLE TclWinSerialReopen(HANDLE handle, CONST TCHAR *name, +MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, CONST TCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal, CONST TCHAR* LinkCopy); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index d5244ac..312a2f8 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1410,23 +1410,22 @@ SerialWriterThread( /* *---------------------------------------------------------------------- * - * TclWinSerialReopen -- + * TclWinSerialOpen -- * - * Reopens the serial port with the OVERLAPPED FLAG set + * Opens or Reopens the serial port with the OVERLAPPED FLAG set * * Results: - * Returns the new handle, or INVALID_HANDLE_VALUE. Normally there - * shouldn't be any error, because the same channel has previously been - * succeesfully opened. + * Returns the new handle, or INVALID_HANDLE_VALUE. + * I an existing channel is specified it is closed and reopened. * * Side effects: - * May close the original handle + * May close/reopen the original handle * *---------------------------------------------------------------------- */ HANDLE -TclWinSerialReopen( +TclWinSerialOpen( HANDLE handle, CONST TCHAR *name, DWORD access) @@ -1434,16 +1433,22 @@ TclWinSerialReopen( SerialInit(); /* + * If an open channel is specified, close it + */ + + if ( handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) { + return INVALID_HANDLE_VALUE; + } + + /* * Multithreaded I/O needs the overlapped flag set otherwise * ClearCommError blocks under Windows NT/2000 until serial output is * finished */ - if (CloseHandle(handle) == FALSE) { - return INVALID_HANDLE_VALUE; - } handle = (*tclWinProcs->createFileProc)(name, access, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); + return handle; } -- cgit v0.12 From 9ac255b85b57fd192a8255ed8d8ca73bf5306748 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Jan 2014 14:44:56 +0000 Subject: Fix [22c10c8e79]: core-8-5: msvc6 build: "Side by Side" error --- win/makefile.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 4466439..152cc66 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -902,7 +902,7 @@ $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) -@TCL_WIN_VERSION@ $(TCL_DOTVERSION).0.0 +@TCL_WIN_VERSION@ $(DOTVERSION).0.0 << #--------------------------------------------------------------------- -- cgit v0.12 From 4e8c59b5b86150cbf86bfcd5c501190b4e29c138 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 18:31:39 +0000 Subject: Refactor WriteChars() and WriteBytes() into simple wrappers of a common routine Write(). --- generic/tclEncoding.c | 2 ++ generic/tclIO.c | 48 +++++++++++++++++++++++++++++++++++------------- generic/tclInt.h | 2 ++ 3 files changed, 39 insertions(+), 13 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c2f1b4b..c303dd1 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -182,6 +182,7 @@ TCL_DECLARE_MUTEX(encodingMutex) static Tcl_Encoding defaultEncoding; static Tcl_Encoding systemEncoding; +Tcl_Encoding tclIdentityEncoding; /* * The following variable is used in the sparse matrix code for a @@ -566,6 +567,7 @@ TclInitEncodingSubsystem(void) type.clientData = NULL; defaultEncoding = Tcl_CreateEncoding(&type); + tclIdentityEncoding = Tcl_GetEncoding(NULL, type.encodingName); systemEncoding = Tcl_GetEncoding(NULL, type.encodingName); type.encodingName = "utf-8"; diff --git a/generic/tclIO.c b/generic/tclIO.c index 4ae9ec0..78ad629 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -200,6 +200,7 @@ static int FilterInputBytes(Channel *chanPtr, static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); +static Tcl_Encoding GetBinaryEncoding(); static void FreeBinaryEncoding(ClientData clientData); static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); @@ -222,6 +223,8 @@ static int TranslateInputEOL(ChannelState *statePtr, char *dst, static int TranslateOutputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); +static int Write(Channel *chanPtr, const char *src, + int srcLen, Tcl_Encoding encoding); static int WriteBytes(Channel *chanPtr, const char *src, int srcLen); static int WriteChars(Channel *chanPtr, const char *src, @@ -3640,6 +3643,9 @@ WriteBytes( const char *src, /* Bytes to write. */ int srcLen) /* Number of bytes to write. */ { +#if 1 + return Write(chanPtr, src, srcLen, tclIdentityEncoding); +#else ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; @@ -3712,6 +3718,7 @@ WriteBytes( sawLF = 0; } return total; +#endif } /* @@ -3736,16 +3743,16 @@ WriteBytes( */ static int -WriteChars( +Write( Channel *chanPtr, /* The channel to buffer output for. */ const char *src, /* UTF-8 string to write. */ - int srcLen) /* Length of UTF-8 string in bytes. */ + int srcLen, /* Length of UTF-8 string in bytes. */ + Tcl_Encoding encoding) { ChannelState *statePtr = chanPtr->state; /* State info for channel */ char *nextNewLine = NULL; int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0; - Tcl_Encoding encoding = statePtr->encoding; if (srcLen) { WillWrite(chanPtr); @@ -3894,6 +3901,15 @@ WriteChars( return total; } + +static int +WriteChars( + Channel *chanPtr, /* The channel to buffer output for. */ + const char *src, /* UTF-8 string to write. */ + int srcLen) /* Length of UTF-8 string in bytes. */ +{ + return Write(chanPtr, src, srcLen, chanPtr->state->encoding); +} /* *--------------------------------------------------------------------------- @@ -4197,16 +4213,7 @@ Tcl_GetsObj( */ if (encoding == NULL) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (tsdPtr->binaryEncoding == NULL) { - tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); - Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); - } - encoding = tsdPtr->binaryEncoding; - if (encoding == NULL) { - Tcl_Panic("attempted gets on binary channel where no iso8859-1 encoding available"); - } + encoding = GetBinaryEncoding(); } /* @@ -4747,6 +4754,21 @@ FreeBinaryEncoding( tsdPtr->binaryEncoding = NULL; } } + +static Tcl_Encoding +GetBinaryEncoding() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->binaryEncoding == NULL) { + tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); + Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); + } + if (tsdPtr->binaryEncoding == NULL) { + Tcl_Panic("binary encoding is not available"); + } + return tsdPtr->binaryEncoding; +} /* *--------------------------------------------------------------------------- diff --git a/generic/tclInt.h b/generic/tclInt.h index dc28b97..b45f8e3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2382,6 +2382,8 @@ MODULE_SCOPE char *tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier; +MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; + /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. -- cgit v0.12 From 7c73eea7d83b3f153f57782f4add442c09d03be0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 18:45:11 +0000 Subject: Simplification and cleanup enabled by last commit. --- generic/tclIO.c | 308 ++------------------------------------------------------ 1 file changed, 7 insertions(+), 301 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 78ad629..dd9f1dc 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -165,8 +165,6 @@ static ChannelBuffer * AllocChannelBuffer(int length); static void ChannelTimerProc(ClientData clientData); static int CheckChannelErrors(ChannelState *statePtr, int direction); -static int CheckFlush(Channel *chanPtr, ChannelBuffer *bufPtr, - int newlineFlag); static int CheckForDeadChannel(Tcl_Interp *interp, ChannelState *statePtr); static void CheckForStdChannelsBeingClosed(Tcl_Channel chan); @@ -220,20 +218,19 @@ static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr, static void StopCopy(CopyState *csPtr); static int TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); -static int TranslateOutputEOL(ChannelState *statePtr, char *dst, - const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static int Write(Channel *chanPtr, const char *src, int srcLen, Tcl_Encoding encoding); -static int WriteBytes(Channel *chanPtr, const char *src, - int srcLen); -static int WriteChars(Channel *chanPtr, const char *src, - int srcLen); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); static int WillRead(Channel *chanPtr); +#define WriteChars(chanPtr, src, srcLen) \ + Write(chanPtr, src, srcLen, chanPtr->state->encoding) +#define WriteBytes(chanPtr, src, srcLen) \ + Write(chanPtr, src, srcLen, tclIdentityEncoding) + /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a @@ -3619,114 +3616,9 @@ static int WillRead(Channel *chanPtr) /* *---------------------------------------------------------------------- * - * WriteBytes -- - * - * Write a sequence of bytes into an output buffer, may queue the buffer - * for output if it gets full, and also remembers whether the current - * buffer is ready e.g. if it contains a newline and we are in line - * buffering mode. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. + * Write -- * - *---------------------------------------------------------------------- - */ - -static int -WriteBytes( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* Bytes to write. */ - int srcLen) /* Number of bytes to write. */ -{ -#if 1 - return Write(chanPtr, src, srcLen, tclIdentityEncoding); -#else - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - ChannelBuffer *bufPtr; - char *dst; - int dstMax, sawLF, savedLF, total, dstLen, toWrite, translate; - - if (srcLen) { - WillWrite(chanPtr); - } - - total = 0; - sawLF = 0; - savedLF = 0; - translate = (statePtr->flags & CHANNEL_LINEBUFFERED) - || (statePtr->outputTranslation != TCL_TRANSLATE_LF); - - /* - * Loop over all bytes in src, storing them in output buffer with proper - * EOL translation. - */ - - while (srcLen + savedLF > 0) { - bufPtr = statePtr->curOutPtr; - if (bufPtr == NULL) { - bufPtr = AllocChannelBuffer(statePtr->bufSize); - statePtr->curOutPtr = bufPtr; - } - dst = InsertPoint(bufPtr); - dstMax = SpaceLeft(bufPtr); - dstLen = dstMax; - - toWrite = dstLen; - if (toWrite > srcLen) { - toWrite = srcLen; - } - - if (translate) { - if (savedLF) { - /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in this buffer. If the channel is - * line-based, we will need to flush it. - */ - - *dst++ = '\n'; - dstLen--; - sawLF++; - } - if (TranslateOutputEOL(statePtr, dst, src, &dstLen, &toWrite)) { - sawLF++; - } - dstLen += savedLF; - savedLF = 0; - if (dstLen > dstMax) { - savedLF = 1; - dstLen = dstMax; - } - } else { - memcpy(dst, src, toWrite); - dstLen = toWrite; - } - - bufPtr->nextAdded += dstLen; - if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { - return -1; - } - total += dstLen; - src += toWrite; - srcLen -= toWrite; - sawLF = 0; - } - return total; -#endif -} - -/* - *---------------------------------------------------------------------- - * - * WriteChars -- - * - * Convert UTF-8 bytes to the channel's external encoding and write the + * Convert srcLen bytes starting at src according to encoding and write * produced bytes into an output buffer, may queue the buffer for output * if it gets full, and also remembers whether the current buffer is * ready e.g. if it contains a newline and we are in line buffering mode. @@ -3901,192 +3793,6 @@ Write( return total; } - -static int -WriteChars( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* UTF-8 string to write. */ - int srcLen) /* Length of UTF-8 string in bytes. */ -{ - return Write(chanPtr, src, srcLen, chanPtr->state->encoding); -} - -/* - *--------------------------------------------------------------------------- - * - * TranslateOutputEOL -- - * - * Helper function for WriteBytes() and WriteChars(). Converts the '\n' - * characters in the source buffer into the appropriate EOL form - * specified by the output translation mode. - * - * EOL translation stops either when the source buffer is empty or the - * output buffer is full. - * - * When converting to CRLF mode and there is only 1 byte left in the - * output buffer, this routine stores the '\r' in the last byte and then - * stores the '\n' in the byte just past the end of the buffer. The - * caller is responsible for passing in a buffer that is large enough to - * hold the extra byte. - * - * Results: - * The return value is 1 if a '\n' was translated from the source buffer, - * or 0 otherwise -- this can be used by the caller to decide to flush a - * line-based channel even though the channel buffer is not full. - * - * *dstLenPtr is filled with how many bytes of the output buffer were - * used. As mentioned above, this can be one more that the output - * buffer's specified length if a CRLF was stored. - * - * *srcLenPtr is filled with how many bytes of the source buffer were - * consumed. - * - * Side effects: - * It may be obvious, but bears mentioning that when converting in CRLF - * mode (which requires two bytes of storage in the output buffer), the - * number of bytes consumed from the source buffer will be less than the - * number of bytes stored in the output buffer. - * - *--------------------------------------------------------------------------- - */ - -static int -TranslateOutputEOL( - ChannelState *statePtr, /* Channel being read, for translation and - * buffering modes. */ - char *dst, /* Output buffer filled with UTF-8 chars by - * applying appropriate EOL translation to - * source characters. */ - const char *src, /* Source UTF-8 characters. */ - int *dstLenPtr, /* On entry, the maximum length of output - * buffer in bytes. On exit, the number of - * bytes actually used in output buffer. */ - int *srcLenPtr) /* On entry, the length of source buffer. On - * exit, the number of bytes read from the - * source buffer. */ -{ - char *dstEnd; - int srcLen, newlineFound; - - newlineFound = 0; - srcLen = *srcLenPtr; - - switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - for (dstEnd = dst + srcLen; dst < dstEnd; ) { - if (*src == '\n') { - newlineFound = 1; - } - *dst++ = *src++; - } - *dstLenPtr = srcLen; - break; - case TCL_TRANSLATE_CR: - for (dstEnd = dst + srcLen; dst < dstEnd;) { - if (*src == '\n') { - *dst++ = '\r'; - newlineFound = 1; - src++; - } else { - *dst++ = *src++; - } - } - *dstLenPtr = srcLen; - break; - case TCL_TRANSLATE_CRLF: { - /* - * Since this causes the number of bytes to grow, we start off trying - * to put 'srcLen' bytes into the output buffer, but allow it to store - * more bytes, as long as there's still source bytes and room in the - * output buffer. - */ - - char *dstStart, *dstMax; - const char *srcStart; - - dstStart = dst; - dstMax = dst + *dstLenPtr; - - srcStart = src; - - if (srcLen < *dstLenPtr) { - dstEnd = dst + srcLen; - } else { - dstEnd = dst + *dstLenPtr; - } - while (dst < dstEnd) { - if (*src == '\n') { - if (dstEnd < dstMax) { - dstEnd++; - } - *dst++ = '\r'; - newlineFound = 1; - } - *dst++ = *src++; - } - *srcLenPtr = src - srcStart; - *dstLenPtr = dst - dstStart; - break; - } - default: - break; - } - return newlineFound; -} - -/* - *--------------------------------------------------------------------------- - * - * CheckFlush -- - * - * Helper function for WriteBytes() and WriteChars(). If the channel - * buffer is ready to be flushed, flush it. - * - * Results: - * The return value is -1 if there was a problem flushing the channel - * buffer, or 0 otherwise. - * - * Side effects: - * The buffer will be recycled if it is flushed. - * - *--------------------------------------------------------------------------- - */ - -static int -CheckFlush( - Channel *chanPtr, /* Channel being read, for buffering mode. */ - ChannelBuffer *bufPtr, /* Channel buffer to possibly flush. */ - int newlineFlag) /* Non-zero if a the channel buffer contains a - * newline. */ -{ - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - - /* - * The current buffer is ready for output: - * 1. if it is full. - * 2. if it contains a newline and this channel is line-buffered. - * 3. if it contains any output and this channel is unbuffered. - */ - - if ((statePtr->flags & BUFFER_READY) == 0) { - if (IsBufferFull(bufPtr)) { - SetFlag(statePtr, BUFFER_READY); - } else if (statePtr->flags & CHANNEL_LINEBUFFERED) { - if (newlineFlag != 0) { - SetFlag(statePtr, BUFFER_READY); - } - } else if (statePtr->flags & CHANNEL_UNBUFFERED) { - SetFlag(statePtr, BUFFER_READY); - } - } - if (statePtr->flags & BUFFER_READY) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } - } - return 0; -} /* *--------------------------------------------------------------------------- -- cgit v0.12 From e264168978eae3270ed1c67ef1152c65347db8f0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 19:13:28 +0000 Subject: Trial: Implement DoWrite() as WriteBytes(). --- generic/tclIO.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index dd9f1dc..1434d88 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9213,6 +9213,9 @@ DoWrite( const char *src, /* Data to write. */ int srcLen) /* Number of bytes to write. */ { +#if 1 + return WriteBytes(chanPtr, src, srcLen); +#else ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *outBufPtr; /* Current output buffer. */ @@ -9340,6 +9343,7 @@ DoWrite( } /* Closes "while" */ return totalDestCopied; +#endif } /* -- cgit v0.12 From 8079c3edb6ad6cac45822466639a9e2b9e9146e0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 19:30:34 +0000 Subject: Eliminate DoWrite(). It duplicates WriteBytes(). --- generic/tclIO.c | 165 +------------------------------------------------------- 1 file changed, 2 insertions(+), 163 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 1434d88..33bb98c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -189,7 +189,6 @@ static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); static int DoRead(Channel *chanPtr, char *srcPtr, int slen); -static int DoWrite(Channel *chanPtr, const char *src, int srcLen); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); static int DoWriteChars(Channel *chan, const char *src, int len); @@ -3362,7 +3361,7 @@ Tcl_Write( if (srcLen < 0) { srcLen = strlen(src); } - return DoWrite(chanPtr, src, srcLen); + return WriteBytes(chanPtr, src, srcLen); } /* @@ -8639,7 +8638,7 @@ CopyData( } if (outBinary || sameEncoding) { - sizeb = DoWrite(outStatePtr->topChanPtr, buffer, sizeb); + sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb); } else { sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb); } @@ -9189,166 +9188,6 @@ CopyBuffer( /* *---------------------------------------------------------------------- * - * DoWrite -- - * - * Puts a sequence of characters into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. - * - *---------------------------------------------------------------------- - */ - -static int -DoWrite( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* Data to write. */ - int srcLen) /* Number of bytes to write. */ -{ -#if 1 - return WriteBytes(chanPtr, src, srcLen); -#else - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - ChannelBuffer *outBufPtr; /* Current output buffer. */ - int foundNewline; /* Did we find a newline in output? */ - char *dPtr; - const char *sPtr; /* Search variables for newline. */ - int crsent; /* In CRLF eol translation mode, remember the - * fact that a CR was output to the channel - * without its following NL. */ - int i; /* Loop index for newline search. */ - int destCopied; /* How many bytes were used in this - * destination buffer to hold the output? */ - int totalDestCopied; /* How many bytes total were copied to the - * channel buffer? */ - int srcCopied; /* How many bytes were copied from the source - * string? */ - char *destPtr; /* Where in line to copy to? */ - - /* - * If we are in network (or windows) translation mode, record the fact - * that we have not yet sent a CR to the channel. - */ - - crsent = 0; - - /* - * Loop filling buffers and flushing them until all output has been - * consumed. - */ - - srcCopied = 0; - totalDestCopied = 0; - - while (srcLen > 0) { - /* - * Make sure there is a current output buffer to accept output. - */ - - if (statePtr->curOutPtr == NULL) { - statePtr->curOutPtr = AllocChannelBuffer(statePtr->bufSize); - } - - outBufPtr = statePtr->curOutPtr; - - destCopied = SpaceLeft(outBufPtr); - if (destCopied > srcLen) { - destCopied = srcLen; - } - - destPtr = InsertPoint(outBufPtr); - switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy(destPtr, src, (size_t) destCopied); - break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy(destPtr, src, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } - } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = src; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } - } else { - *dPtr = *sPtr; - } - } - break; - case TCL_TRANSLATE_AUTO: - Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); - default: - Tcl_Panic("Tcl_Write: unknown output translation mode"); - } - - /* - * The current buffer is ready for output if it is full, or if it - * contains a newline and this channel is line-buffered, or if it - * contains any output and this channel is unbuffered. - */ - - outBufPtr->nextAdded += destCopied; - if (!(statePtr->flags & BUFFER_READY)) { - if (IsBufferFull(outBufPtr)) { - SetFlag(statePtr, BUFFER_READY); - } else if (statePtr->flags & CHANNEL_LINEBUFFERED) { - for (sPtr = src, i = 0, foundNewline = 0; - (i < srcCopied) && (!foundNewline); - i++, sPtr++) { - if (*sPtr == '\n') { - foundNewline = 1; - break; - } - } - if (foundNewline) { - SetFlag(statePtr, BUFFER_READY); - } - } else if (statePtr->flags & CHANNEL_UNBUFFERED) { - SetFlag(statePtr, BUFFER_READY); - } - } - - totalDestCopied += srcCopied; - src += srcCopied; - srcLen -= srcCopied; - - if (statePtr->flags & BUFFER_READY) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } - } - } /* Closes "while" */ - - return totalDestCopied; -#endif -} - -/* - *---------------------------------------------------------------------- - * * CopyEventProc -- * * This routine is invoked as a channel event handler for the background -- cgit v0.12 From 4e9008ff1b243981772ef48e1e92f2a95301b0e3 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Jan 2014 20:10:21 +0000 Subject: Refactor to eliminate the DoWriteChars() layer. --- generic/tclIO.c | 86 +++++++++++++++------------------------------------------ 1 file changed, 22 insertions(+), 64 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 33bb98c..542d97d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -191,7 +191,6 @@ static void DiscardOutputQueued(ChannelState *chanPtr); static int DoRead(Channel *chanPtr, char *srcPtr, int slen); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); -static int DoWriteChars(Channel *chan, const char *src, int len); static int FilterInputBytes(Channel *chanPtr, GetsState *statePtr); static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, @@ -3454,81 +3453,40 @@ Tcl_WriteChars( int len) /* Length of string in bytes, or < 0 for * strlen(). */ { - ChannelState *statePtr; /* State info for channel */ - - statePtr = ((Channel *) chan)->state; + Channel *chanPtr = (Channel *) chan; + ChannelState *statePtr = chanPtr->state; /* State info for channel */ + int result; + Tcl_Obj *objPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { return -1; } - return DoWriteChars((Channel *) chan, src, len); -} - -/* - *--------------------------------------------------------------------------- - * - * DoWriteChars -- - * - * Takes a sequence of UTF-8 characters and converts them for output - * using the channel's current encoding, may queue the buffer for output - * if it gets full, and also remembers whether the current buffer is - * ready e.g. if it contains a newline and we are in line buffering mode. - * Compensates stacking, i.e. will redirect the data from the specified - * channel to the topmost channel in a stack. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. - * - *---------------------------------------------------------------------- - */ - -static int -DoWriteChars( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* UTF-8 characters to queue in output - * buffer. */ - int len) /* Length of string in bytes, or < 0 for - * strlen(). */ -{ - /* - * Always use the topmost channel of the stack - */ - - ChannelState *statePtr; /* State info for channel */ - - statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; if (len < 0) { len = strlen(src); } - if (statePtr->encoding == NULL) { - /* - * Inefficient way to convert UTF-8 to byte-array, but the code - * parallels the way it is done for objects. - * Special case for 1-byte (used by eg [puts] for the \n) could - * be extended to more efficient translation of the src string. - */ + if (statePtr->encoding) { + return WriteChars(chanPtr, src, len); + } - int result; + /* + * Inefficient way to convert UTF-8 to byte-array, but the code + * parallels the way it is done for objects. Special case for 1-byte + * (used by eg [puts] for the \n) could be extended to more efficient + * translation of the src string. + */ - if ((len == 1) && (UCHAR(*src) < 0xC0)) { - result = WriteBytes(chanPtr, src, len); - } else { - Tcl_Obj *objPtr = Tcl_NewStringObj(src, len); - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); - result = WriteBytes(chanPtr, src, len); - TclDecrRefCount(objPtr); - } - return result; + if ((len == 1) && (UCHAR(*src) < 0xC0)) { + return WriteBytes(chanPtr, src, len); } - return WriteChars(chanPtr, src, len); + + objPtr = Tcl_NewStringObj(src, len); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); + result = WriteBytes(chanPtr, src, len); + TclDecrRefCount(objPtr); + return result; } /* @@ -8640,7 +8598,7 @@ CopyData( if (outBinary || sameEncoding) { sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb); } else { - sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb); + sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb); } /* -- cgit v0.12 From 81e405a16c6eff768e23d1c43c292e4875b86a16 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 31 Jan 2014 09:13:13 +0000 Subject: Fix [4b3b7a3082]: tcl8.5.15/generic/tclExecute.c:7713: array index before sanity check ? --- generic/tclExecute.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e657828..2e396e8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -73,7 +73,7 @@ int tclTraceExec = 0; * disjoint for backward-compatability reasons. */ -static const char *operatorStrings[] = { +static const char *const operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", @@ -86,7 +86,7 @@ static const char *operatorStrings[] = { */ #ifdef TCL_COMPILE_DEBUG -static const char *resultStrings[] = { +static const char *const resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" }; #endif @@ -7710,10 +7710,12 @@ IllegalExprOperandType( ClientData ptr; int type; unsigned char opcode = *pc; - const char *description, *operator = operatorStrings[opcode - INST_LOR]; + const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { operator = "**"; + } else if (opcode <= INST_STR_NEQ) { + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { -- cgit v0.12 From 4c98b1f4cda633b5554ac990dfde7401bd0d67b1 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 31 Jan 2014 20:02:58 +0000 Subject: Do not call updateStringProc directly. We have TclGetString() for that. --- generic/tclIO.c | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 542d97d..71f8f53 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10429,17 +10429,8 @@ SetChannelFromAny( } } if (objPtr->typePtr != &tclChannelType) { - Tcl_Channel chan; + Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); - /* - * We need a valid string with which to check for a valid channel, but - * make sure not to free internal rep until validated. [Bug 1847044] - */ - if ((objPtr->typePtr != NULL) && (objPtr->bytes == NULL)) { - objPtr->typePtr->updateStringProc(objPtr); - } - - chan = Tcl_GetChannel(interp, objPtr->bytes, NULL); if (chan == NULL) { return TCL_ERROR; } -- cgit v0.12 From 6f611b9b973068d5630b4a227aef5fc316686036 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 31 Jan 2014 20:42:21 +0000 Subject: The "channel" Tcl_ObjType is caching only. It never needs an UpdateString routine. It's also static to the tclIO.c file. --- generic/tclIO.c | 52 ++++++---------------------------------------------- 1 file changed, 6 insertions(+), 46 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 71f8f53..7705d7b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -316,14 +316,13 @@ static int WillRead(Channel *chanPtr); static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static int SetChannelFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfChannel(Tcl_Obj *objPtr); static void FreeChannelIntRep(Tcl_Obj *objPtr); -static Tcl_ObjType tclChannelType = { +static Tcl_ObjType chanObjType = { "channel", /* name for this type */ FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ - NULL, /* updateStringProc UpdateStringOfChannel */ + NULL, /* updateStringProc */ NULL /* setFromAnyProc SetChannelFromAny */ }; @@ -10379,7 +10378,7 @@ DupChannelIntRep( SET_CHANNELSTATE(copyPtr, statePtr); SET_CHANNELINTERP(copyPtr, interpPtr); Tcl_Preserve((ClientData) statePtr); - copyPtr->typePtr = &tclChannelType; + copyPtr->typePtr = srcPtr->typePtr; } /* @@ -10410,7 +10409,7 @@ SetChannelFromAny( if (interp == NULL) { return TCL_ERROR; } - if (objPtr->typePtr == &tclChannelType) { + if (objPtr->typePtr == &chanObjType) { /* * The channel is valid until any call to DetachChannel occurs. * Ensure consistency checks are done. @@ -10420,15 +10419,13 @@ SetChannelFromAny( if (statePtr->flags & (CHANNEL_TAINTED|CHANNEL_CLOSED)) { ResetFlag(statePtr, CHANNEL_TAINTED); Tcl_Release((ClientData) statePtr); - UpdateStringOfChannel(objPtr); objPtr->typePtr = NULL; } else if (interpPtr != (Interp*) interp) { Tcl_Release((ClientData) statePtr); - UpdateStringOfChannel(objPtr); objPtr->typePtr = NULL; } } - if (objPtr->typePtr != &tclChannelType) { + if (objPtr->typePtr != &chanObjType) { Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); if (chan == NULL) { @@ -10440,7 +10437,7 @@ SetChannelFromAny( Tcl_Preserve((ClientData) statePtr); SET_CHANNELSTATE(objPtr, statePtr); SET_CHANNELINTERP(objPtr, interp); - objPtr->typePtr = &tclChannelType; + objPtr->typePtr = &chanObjType; } return TCL_OK; } @@ -10448,43 +10445,6 @@ SetChannelFromAny( /* *---------------------------------------------------------------------- * - * UpdateStringOfChannel -- - * - * Update the string representation for an object whose internal - * representation is "Channel". - * - * Results: - * None. - * - * Side effects: - * The object's string may be set by converting its Unicode represention - * to UTF format. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfChannel( - Tcl_Obj *objPtr) /* Object with string rep to update. */ -{ - if (objPtr->bytes == NULL) { - ChannelState *statePtr = GET_CHANNELSTATE(objPtr); - const char *name = statePtr->channelName; - if (name) { - size_t len = strlen(name); - objPtr->bytes = (char *) ckalloc(len + 1); - objPtr->length = len; - memcpy(objPtr->bytes, name, len); - } else { - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - } - } -} - -/* - *---------------------------------------------------------------------- - * * FreeChannelIntRep -- * * Release statePtr storage. -- cgit v0.12 From a85ebc21de9b4010d0733a56197fecbb6f3d3a3b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 31 Jan 2014 22:07:10 +0000 Subject: Simplify macro typecasting. --- generic/tclIO.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7705d7b..3636861 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -331,7 +331,7 @@ static Tcl_ObjType chanObjType = { #define SET_CHANNELSTATE(objPtr, storePtr) \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) #define GET_CHANNELINTERP(objPtr) \ - ((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) + ((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) #define SET_CHANNELINTERP(objPtr, storePtr) \ ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr)) @@ -10373,10 +10373,9 @@ DupChannelIntRep( * currently have an internal rep.*/ { ChannelState *statePtr = GET_CHANNELSTATE(srcPtr); - Interp *interpPtr = GET_CHANNELINTERP(srcPtr); SET_CHANNELSTATE(copyPtr, statePtr); - SET_CHANNELINTERP(copyPtr, interpPtr); + SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr)); Tcl_Preserve((ClientData) statePtr); copyPtr->typePtr = srcPtr->typePtr; } @@ -10404,7 +10403,6 @@ SetChannelFromAny( register Tcl_Obj *objPtr) /* The object to convert. */ { ChannelState *statePtr; - Interp *interpPtr; if (interp == NULL) { return TCL_ERROR; @@ -10415,12 +10413,11 @@ SetChannelFromAny( * Ensure consistency checks are done. */ statePtr = GET_CHANNELSTATE(objPtr); - interpPtr = GET_CHANNELINTERP(objPtr); if (statePtr->flags & (CHANNEL_TAINTED|CHANNEL_CLOSED)) { ResetFlag(statePtr, CHANNEL_TAINTED); Tcl_Release((ClientData) statePtr); objPtr->typePtr = NULL; - } else if (interpPtr != (Interp*) interp) { + } else if (interp != GET_CHANNELINTERP(objPtr)) { Tcl_Release((ClientData) statePtr); objPtr->typePtr = NULL; } -- cgit v0.12 From 347264f196f57e2f4433f33dbaa6c8e2e4a2c83d Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Feb 2014 14:42:12 +0000 Subject: improve the disassembly --- generic/tclCompile.c | 7 ++++++- generic/tclCompile.h | 3 ++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 08a7a4c..c5d0107 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -644,7 +644,7 @@ InstructionDesc const tclInstructionTable[] = { {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, /* Try converting stktop to boolean if possible. No errors. * Stack: ... value => ... value isStrictBool */ - {"strclass", 2, 0, 1, {OPERAND_UINT1}}, + {"strclass", 2, 0, 1, {OPERAND_SCLS1}}, /* See if all the characters of the given string are a member of the * specified (by opnd) character class. Note that an empty string will * satisfy the class check (standard definition of "all"). @@ -5097,6 +5097,11 @@ FormatInstruction( } Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); break; + case OPERAND_SCLS1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%s ", + tclStringClassTable[opnd].name); + break; case OPERAND_NONE: default: break; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 502a2e6..5665ca9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -825,8 +825,9 @@ typedef enum InstOperandType { * variable table. */ OPERAND_LVT4, /* Four byte unsigned index into the local * variable table. */ - OPERAND_AUX4 /* Four byte unsigned index into the aux data + OPERAND_AUX4, /* Four byte unsigned index into the aux data * table. */ + OPERAND_SCLS1 /* Index into tclStringClassTable. */ } InstOperandType; typedef struct InstructionDesc { -- cgit v0.12 From 009a17d3a03061610a2c281f18937e78e995855f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Feb 2014 14:43:52 +0000 Subject: Fix [651e828a52]: Wrong Windows version reported for Windows 8.1 --- unix/tclUnixInit.c | 29 ++++++++++++++++++++++------- win/tclWinInit.c | 18 ++++++++++++++---- 2 files changed, 36 insertions(+), 11 deletions(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 0b98cf9..423e97e 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -33,7 +33,10 @@ #endif #ifdef __CYGWIN__ -DLLIMPORT extern __stdcall unsigned char GetVersionExA(void *); +DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *); +DLLIMPORT extern __stdcall void *LoadLibraryW(const void *); +DLLIMPORT extern __stdcall void FreeLibrary(void *); +DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); #define NUMPLATFORMS 4 @@ -66,14 +69,14 @@ typedef struct _SYSTEM_INFO { int wProcessorRevision; } SYSTEM_INFO; -typedef struct _OSVERSIONINFOA { +typedef struct _OSVERSIONINFOW { DWORD dwOSVersionInfoSize; DWORD dwMajorVersion; DWORD dwMinorVersion; DWORD dwBuildNumber; DWORD dwPlatformId; - char szCSDVersion[128]; -} OSVERSIONINFOA; + wchar_t szCSDVersion[128]; +} OSVERSIONINFOW; #endif #ifdef HAVE_COREFOUNDATION @@ -811,7 +814,8 @@ TclpSetVariables( { #ifdef __CYGWIN__ SYSTEM_INFO sysInfo; - OSVERSIONINFOA osInfo; + static OSVERSIONINFOW osInfo; + static int osInfoInitialized = 0; char buffer[TCL_INTEGER_SPACE * 2]; #elif !defined(NO_UNAME) struct utsname name; @@ -924,8 +928,19 @@ TclpSetVariables( unameOK = 0; #ifdef __CYGWIN__ unameOK = 1; - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - GetVersionExA(&osInfo); + if (!osInfoInitialized) { + HANDLE handle = LoadLibraryW(L"NTDLL"); + int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; + } + GetSystemInfo(&sysInfo); if (osInfo.dwPlatformId < NUMPLATFORMS) { diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 81d762f..08ef1ed 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -563,7 +563,8 @@ TclpSetVariables( SYSTEM_INFO info; OemId oemId; } sys; - OSVERSIONINFOW osInfo; + static OSVERSIONINFOW osInfo; + static int osInfoInitialized = 0; Tcl_DString ds; WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; @@ -571,9 +572,18 @@ TclpSetVariables( Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - GetVersionExW(&osInfo); - + if (!osInfoInitialized) { + HANDLE handle = LoadLibraryW(L"NTDLL"); + int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; + } GetSystemInfo(&sys.info); /* -- cgit v0.12 From dc81fd618b33c6e9c6b8fa4b9595229ce3809f01 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 4 Feb 2014 08:15:52 +0000 Subject: [971cb4f1db]: Make debugging traces less inclined to serious visual corruption --- generic/tclExecute.c | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ac78370..89305e6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5905,14 +5905,34 @@ TEBCresume( trim2 = 0; } createTrimmedString: + /* + * Careful here; trim set often contains non-ASCII characters so we + * take care when printing. [Bug 971cb4f1db] + */ + +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TRACE(("\"%.30s\" ", O2S(valuePtr))); + TclPrintObject(stdout, value2Ptr, 30); + printf(" => "); + } +#endif if (trim1 == 0 && trim2 == 0) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", - O2S(valuePtr), O2S(value2Ptr)), valuePtr); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, valuePtr, 30); + printf("\n"); + } +#endif NEXT_INST_F(1, 1, 0); } else { objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, objResultPtr, 30); + printf("\n"); + } +#endif NEXT_INST_F(1, 2, 1); } } -- cgit v0.12 From a72ae0f931f9ac8a78ef7b78f854ae68e66f9dd1 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 4 Feb 2014 09:02:23 +0000 Subject: make the printing of source much less inclined to be fazed by non-ASCII chars --- generic/tclCompile.c | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c5d0107..347e3f0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -5318,7 +5318,7 @@ PrintSourceToObj( int maxChars) /* Maximum number of chars to print. */ { register const char *p; - register int i = 0; + register int i = 0, len; if (stringPtr == NULL) { Tcl_AppendToObj(appendObj, "\"\"", -1); @@ -5327,32 +5327,50 @@ PrintSourceToObj( Tcl_AppendToObj(appendObj, "\"", -1); p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { + for (; (*p != '\0') && (i < maxChars); p+=len) { + Tcl_UniChar ch; + + len = TclUtfToUniChar(p, &ch); + switch (ch) { case '"': Tcl_AppendToObj(appendObj, "\\\"", -1); + i += 2; continue; case '\f': Tcl_AppendToObj(appendObj, "\\f", -1); + i += 2; continue; case '\n': Tcl_AppendToObj(appendObj, "\\n", -1); + i += 2; continue; case '\r': Tcl_AppendToObj(appendObj, "\\r", -1); + i += 2; continue; case '\t': Tcl_AppendToObj(appendObj, "\\t", -1); + i += 2; continue; case '\v': Tcl_AppendToObj(appendObj, "\\v", -1); + i += 2; continue; default: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); + if (ch < 0x20 || ch >= 0x7f) { + Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch); + i += 6; + } else { + Tcl_AppendPrintfToObj(appendObj, "%c", ch); + i++; + } continue; } } Tcl_AppendToObj(appendObj, "\"", -1); + if (*p != '\0') { + Tcl_AppendToObj(appendObj, "...", -1); + } } #ifdef TCL_COMPILE_STATS -- cgit v0.12 From ee8ba589547e1b44b7851f0524f854e9b58f8dfe Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 4 Feb 2014 14:30:55 +0000 Subject: Be sure to finalize the identity encoding. --- generic/tclEncoding.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c303dd1..1842fb6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -658,6 +658,7 @@ TclFinalizeEncodingSubsystem(void) Tcl_MutexLock(&encodingMutex); encodingsInitialized = 0; FreeEncoding(systemEncoding); + FreeEncoding(tclIdentityEncoding); hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { -- cgit v0.12 From 9901c4812ae35bda160641378fab124f87238b96 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2014 21:21:53 +0000 Subject: Add missing __stdcall (which crashes on win32), and clean-up indenting --- unix/tclUnixInit.c | 22 ++++++++++++---------- win/tclWinInit.c | 21 +++++++++++---------- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 423e97e..11a65707 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -38,6 +38,7 @@ DLLIMPORT extern __stdcall void *LoadLibraryW(const void *); DLLIMPORT extern __stdcall void FreeLibrary(void *); DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); +DLLIMPORT extern __stdcall void GetSystemInfo(void *); #define NUMPLATFORMS 4 static const char *const platforms[NUMPLATFORMS] = { @@ -929,16 +930,17 @@ TclpSetVariables( #ifdef __CYGWIN__ unameOK = 1; if (!osInfoInitialized) { - HANDLE handle = LoadLibraryW(L"NTDLL"); - int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - if (!getversion || getversion(&osInfo)) { - GetVersionExW(&osInfo); - } - if (handle) { - FreeLibrary(handle); - } - osInfoInitialized = 1; + HANDLE handle = LoadLibraryW(L"NTDLL"); + __stdcall int(*getversion)(void *) = + (__stdcall int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; } GetSystemInfo(&sysInfo); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 08ef1ed..f49edf0 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -573,16 +573,17 @@ TclpSetVariables( TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); if (!osInfoInitialized) { - HANDLE handle = LoadLibraryW(L"NTDLL"); - int(*getversion)(void *) = (int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - if (!getversion || getversion(&osInfo)) { - GetVersionExW(&osInfo); - } - if (handle) { - FreeLibrary(handle); - } - osInfoInitialized = 1; + HANDLE handle = LoadLibraryW(L"NTDLL"); + __stdcall int(*getversion)(void *) = + (__stdcall int(*)(void *)) GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; } GetSystemInfo(&sys.info); -- cgit v0.12 From e11501e82c5daaf3f89f915d6df764823e9edb86 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2014 21:29:44 +0000 Subject: remove duplicate declaration --- unix/tclUnixInit.c | 1 - 1 file changed, 1 deletion(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 11a65707..7e0b19a 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -38,7 +38,6 @@ DLLIMPORT extern __stdcall void *LoadLibraryW(const void *); DLLIMPORT extern __stdcall void FreeLibrary(void *); DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *); DLLIMPORT extern __stdcall void GetSystemInfo(void *); -DLLIMPORT extern __stdcall void GetSystemInfo(void *); #define NUMPLATFORMS 4 static const char *const platforms[NUMPLATFORMS] = { -- cgit v0.12 From 7986522df51e69499b127ab05a24f697b5ac0849 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Feb 2014 21:51:32 +0000 Subject: Satisfy required position of __stdcall from VC++ --- unix/tclUnixInit.c | 4 ++-- win/tclWinInit.c | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 7e0b19a..a8cd00d 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -930,8 +930,8 @@ TclpSetVariables( unameOK = 1; if (!osInfoInitialized) { HANDLE handle = LoadLibraryW(L"NTDLL"); - __stdcall int(*getversion)(void *) = - (__stdcall int(*)(void *))GetProcAddress(handle, "RtlGetVersion"); + int(__stdcall *getversion)(void *) = + (int(__stdcall *)(void *))GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); if (!getversion || getversion(&osInfo)) { GetVersionExW(&osInfo); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index f49edf0..2f3c7e8 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -574,8 +574,8 @@ TclpSetVariables( if (!osInfoInitialized) { HANDLE handle = LoadLibraryW(L"NTDLL"); - __stdcall int(*getversion)(void *) = - (__stdcall int(*)(void *)) GetProcAddress(handle, "RtlGetVersion"); + int(__stdcall *getversion)(void *) = + (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion"); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); if (!getversion || getversion(&osInfo)) { GetVersionExW(&osInfo); -- cgit v0.12 From 11b2556b272a74d9456a2b0b9cef5ccc76fd8316 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Feb 2014 19:04:36 +0000 Subject: Revised ReadChars to restore an attempt to make sure we do not short read because of a false notion of limited storage space. The test suite does not appear to demonstrate any case where this matters. Could be an incomplete test suite, or an example of pointless code. --- generic/tclIO.c | 8 +++++++- generic/tclInt.h | 2 ++ generic/tclStringObj.c | 32 ++++++++++++++++++++++++++++++++ 3 files changed, 41 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index f8baba3..cedf3f6 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5310,7 +5310,13 @@ ReadChars( dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; (void) TclGetStringFromObj(objPtr, &numBytes); Tcl_AppendToObj(objPtr, NULL, dstNeeded); - dst = TclGetString(objPtr) + numBytes; + if (toRead == srcLen) { + unsigned int size; + dst = TclGetStringStorage(objPtr, &size) + numBytes; + dstNeeded = size - numBytes; + } else { + dst = TclGetString(objPtr) + numBytes; + } /* * [Bug 1462248]: The cause of the crash reported in this bug is this: diff --git a/generic/tclInt.h b/generic/tclInt.h index a998460..0c09ec0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2571,6 +2571,8 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr); +MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, + unsigned int *sizePtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d96d814..8c6a376 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2711,6 +2711,38 @@ Tcl_ObjPrintf( /* *--------------------------------------------------------------------------- * + * TclGetStringStorage -- + * + * Returns the string storage space of a Tcl_Obj. + * + * Results: + * The pointer value objPtr->bytes is returned and the number of bytes + * allocated there is written to *sizePtr (if known). + * + * Side effects: + * May set objPtr->bytes. + * + *--------------------------------------------------------------------------- + */ + +char * +TclGetStringStorage( + Tcl_Obj *objPtr, + unsigned int *sizePtr) +{ + String *stringPtr; + + if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) { + return TclGetStringFromObj(objPtr, (int *)sizePtr); + } + + stringPtr = GET_STRING(objPtr); + *sizePtr = stringPtr->allocated; + return objPtr->bytes; +} +/* + *--------------------------------------------------------------------------- + * * TclStringObjReverse -- * * Implements the [string reverse] operation. -- cgit v0.12 From 4ae04fa40387165f811a88d87a1140a07bf10215 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Feb 2014 21:44:43 +0000 Subject: Check for existance of __BORLANDC__ before using its value --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index 31960ec..5300bba 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -168,7 +168,7 @@ extern "C" { * MSVCRT. */ -#if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#if (defined(__WIN32__) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define HAVE_DECLSPEC 1 # ifdef STATIC_BUILD # define DLLIMPORT -- cgit v0.12 From 6e78f7a617b001eb5e35fe11cad2f469c0f48320 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Feb 2014 22:38:17 +0000 Subject: [a4494e28ed] Use flag bit instead of NULL pointer to suppress teardown list of imported commands when the original command gets re-created. This prevents the panic otherwise possible when the invalid state represented by the NULL pointer is encountered during a command delete trace. --- generic/tclBasic.c | 39 +++++++++++++++++++++++++++++---------- generic/tclInt.h | 1 + tests/namespace.test | 9 +++++++++ 3 files changed, 39 insertions(+), 10 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c3ab871..89d6b8f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1887,10 +1887,19 @@ Tcl_CreateCommand( */ cmdPtr = Tcl_GetHashValue(hPtr); - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2061,10 +2070,19 @@ Tcl_CreateObjCommand( * intact. */ - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2869,12 +2887,13 @@ Tcl_DeleteCommandFromToken( * commands were created that refer back to this command. Delete these * imported commands now. */ - - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { - nextRefPtr = refPtr->nextPtr; - importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); + if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index b45f8e3..f869ff0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1528,6 +1528,7 @@ typedef struct Command { #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 #define CMD_HAS_EXEC_TRACES 0x4 +#define CMD_REDEF_IN_PROGRESS 0x8 /* *---------------------------------------------------------------- diff --git a/tests/namespace.test b/tests/namespace.test index 4eecac1..b59e09e 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -556,6 +556,15 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { lappend l [info commands ::test_ns_import::*] } } {::test_ns_import::cmd1 {}} +test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { + # Will panic if still buggy + namespace eval src {namespace export foo; proc foo {} {}} + namespace eval dst {namespace import [namespace parent]::src::foo} + trace add command src::foo delete \ + "[list namespace delete [namespace current]::dst] ;#" + proc src::foo {} {} + namespace delete src +} {} test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { catch {namespace delete {*}[namespace children :: test_ns_*]} -- cgit v0.12 From 32a6fce0618ed21d85cf47b4b842ea9ee2c0c2e6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Feb 2014 22:41:14 +0000 Subject: Change the flag value to avoid merge conflict with trunk. --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index f869ff0..1348340 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1528,7 +1528,7 @@ typedef struct Command { #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 #define CMD_HAS_EXEC_TRACES 0x4 -#define CMD_REDEF_IN_PROGRESS 0x8 +#define CMD_REDEF_IN_PROGRESS 0x10 /* *---------------------------------------------------------------- -- cgit v0.12 From c688c0e2b32e29091cb41f2ef425fe3cafa39c19 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Feb 2014 07:54:04 +0000 Subject: improve the testing of the disassembly commands --- tests/compile.test | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 81 insertions(+), 1 deletion(-) diff --git a/tests/compile.test b/tests/compile.test index 2852bf2..22ebc7d 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -658,12 +658,15 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # does not check the format of disassembled bytecode though; that's liable to # change without warning. +set disassemblables [linsert [join { + lambda method objmethod proc script +} ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble } -match glob -result {wrong # args: should be "*"} test compile-18.2 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble ? -} -match glob -result {bad type "?": must be *} +} -result "bad type \"?\": must be $disassemblables" test compile-18.3 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble lambda } -match glob -result {wrong # args: should be "* lambda lambdaTerm"} @@ -737,6 +740,83 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * +# There never was a compile-18.20. +# The keys of the dictionary produced by [getbytecode] are defined. +set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth} +test compile-18.21 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode +} -match glob -result {wrong # args: should be "*"} +test compile-18.22 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode ? +} -result "bad type \"?\": must be $disassemblables" +test compile-18.23 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda +} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} +test compile-18.24 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda \{ +} -result "can't interpret \"\{\" as a lambda expression" +test compile-18.25 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode lambda {{} {}}] +} -result $bytecodekeys +test compile-18.26 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc +} -match glob -result {wrong # args: should be "* proc procName"} +test compile-18.27 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc nosuchproc +} -result {"nosuchproc" isn't a procedure} +test compile-18.28 {disassembler - basics} -setup { + proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result $bytecodekeys +test compile-18.29 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode script +} -match glob -result {wrong # args: should be "* script script"} +test compile-18.30 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode script {}] +} -result $bytecodekeys +test compile-18.31 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method +} -match glob -result {wrong # args: should be "* method className methodName"} +test compile-18.32 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method nosuchclass foo +} -result {nosuchclass does not refer to an object} +test compile-18.33 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::getbytecode method justanobject foo +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.34 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.35 {disassembler - basics} -setup { + oo::class create foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode method foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys +test compile-18.36 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod +} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} +test compile-18.37 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod nosuchobject foo +} -result {nosuchobject does not refer to an object} +test compile-18.38 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.39 {disassembler - basics} -setup { + oo::object create foo + oo::objdefine foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode objmethod foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { # This will panic in a --enable-symbols=compile build, unless bug is fixed. -- cgit v0.12 From d8e6ba4a3b30e39fc7cde4cb5550d2157c95e194 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Feb 2014 11:59:22 +0000 Subject: Eliminate all usage of WIN32 and __WIN32__ macros: Some compilers (e.g. Clang/LLVM) don't define it, and _WIN32 is much more portable anyway. See: [http://nadeausoftware.com/articles/2012/01/c_c_tip_how_use_compiler_predefined_macros_detect_operating_system#WindowsCygwinnonPOSIXandMinGW] --- generic/tcl.h | 35 ++++++++++++++++------------------- generic/tclClock.c | 2 +- generic/tclCmdAH.c | 2 +- generic/tclDecls.h | 24 ++++++++++++------------ generic/tclEnv.c | 4 ++-- generic/tclFCmd.c | 2 +- generic/tclIOUtil.c | 8 ++++---- generic/tclIntDecls.h | 0 generic/tclIntPlatDecls.h | 16 ++++++++-------- generic/tclLoad.c | 4 ++-- generic/tclMain.c | 2 +- generic/tclPathObj.c | 6 +++--- generic/tclPlatDecls.h | 6 +++--- generic/tclStubInit.c | 20 ++++++++++---------- generic/tclTest.c | 6 +++--- generic/tclThreadJoin.c | 4 ++-- tools/genStubs.tcl | 6 +++--- win/configure | 4 ++-- win/tcl.m4 | 4 ++-- win/tclWin32Dll.c | 4 ++-- win/tclWinTest.c | 2 +- 21 files changed, 79 insertions(+), 82 deletions(-) mode change 100644 => 100755 generic/tclDecls.h mode change 100644 => 100755 generic/tclIntDecls.h mode change 100644 => 100755 generic/tclIntPlatDecls.h mode change 100644 => 100755 generic/tclPlatDecls.h mode change 100644 => 100755 generic/tclStubInit.c diff --git a/generic/tcl.h b/generic/tcl.h index b7237bf..b93b3ac 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -67,15 +67,12 @@ extern "C" { * We use this method because there is no autoconf equivalent. */ -#ifndef __WIN32__ -# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) +#ifdef _WIN32 +# ifndef __WIN32__ # define __WIN32__ -# ifndef WIN32 -# define WIN32 -# endif -# ifndef _WIN32 -# define _WIN32 -# endif +# endif +# ifndef WIN32 +# define WIN32 # endif #endif @@ -83,11 +80,11 @@ extern "C" { * STRICT: See MSDN Article Q83456 */ -#ifdef __WIN32__ +#ifdef _WIN32 # ifndef STRICT # define STRICT # endif -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double @@ -191,7 +188,7 @@ extern "C" { * MSVCRT. */ -#if (defined(__WIN32__) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define HAVE_DECLSPEC 1 # ifdef STATIC_BUILD # define DLLIMPORT @@ -315,14 +312,14 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ -#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID) +#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; #endif -#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */ +#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ /* * Macro to use instead of "void" for arguments that must have type "void *" @@ -390,7 +387,7 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__WIN32__) +# if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ # define TCL_LL_MODIFIER "L" @@ -400,7 +397,7 @@ typedef long LONG; # elif defined(__GNUC__) # define TCL_WIDE_INT_TYPE long long # define TCL_LL_MODIFIER "ll" -# else /* ! __WIN32__ && ! __GNUC__ */ +# else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... @@ -415,7 +412,7 @@ typedef long LONG; # define TCL_WIDE_INT_TYPE long long # endif # endif /* NO_LIMITS_H */ -# endif /* __WIN32__ */ +# endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ #ifdef TCL_WIDE_INT_IS_LONG # undef TCL_WIDE_INT_TYPE @@ -447,7 +444,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; # define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #endif /* TCL_WIDE_INT_IS_LONG */ -#if defined(__WIN32__) +#if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # elif defined(_WIN64) @@ -562,7 +559,7 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream; * will be called as the main fuction of the new thread created by that call. */ -#if defined __WIN32__ +#if defined _WIN32 typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData); #else typedef void (Tcl_ThreadCreateProc) (ClientData clientData); @@ -574,7 +571,7 @@ typedef void (Tcl_ThreadCreateProc) (ClientData clientData); * in generic/tclThreadTest.c for it's usage. */ -#if defined __WIN32__ +#if defined _WIN32 # define Tcl_ThreadCreateType unsigned __stdcall # define TCL_THREAD_CREATE_RETURN return 0 #else diff --git a/generic/tclClock.c b/generic/tclClock.c index 6d2976d..50d480c 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -19,7 +19,7 @@ * Windows has mktime. The configurators do not check. */ -#ifdef __WIN32__ +#ifdef _WIN32 #define HAVE_MKTIME 1 #endif diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f90819a..d90a747 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1590,7 +1590,7 @@ FileAttrIsOwnedCmd( * test for equivalence to the current user. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) value = 1; #else value = (geteuid() == buf.st_uid); diff --git a/generic/tclDecls.h b/generic/tclDecls.h old mode 100644 new mode 100755 index 830c998..91c0add --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -63,7 +63,7 @@ EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, const char *file, int line); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); @@ -73,7 +73,7 @@ EXTERN void Tcl_CreateFileHandler(int fd, int mask, EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); #endif /* UNIX */ @@ -511,7 +511,7 @@ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, @@ -1835,19 +1835,19 @@ typedef struct TclStubs { char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */ void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved9)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved10)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2009,10 +2009,10 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2513,7 +2513,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbCkfree) /* 7 */ #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* UNIX */ @@ -2521,7 +2521,7 @@ extern const TclStubs *tclStubsPtr; #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_DeleteFileHandler \ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ #endif /* UNIX */ @@ -2841,7 +2841,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* UNIX */ diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 8f51c1b..cd1a954 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -444,7 +444,7 @@ TclUnsetEnv( * that no = should be included, and Windows requires it. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) string = ckalloc(length + 2); memcpy(string, name, (size_t) length); string[length] = '='; @@ -453,7 +453,7 @@ TclUnsetEnv( string = ckalloc(length + 1); memcpy(string, name, (size_t) length); string[length] = '\0'; -#endif /* WIN32 */ +#endif /* _WIN32 */ Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, Tcl_DStringLength(&envString) + 1); diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 13377d3..6452fff 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -517,7 +517,7 @@ CopyRenameOneFile( * 16 bits and we get collisions. See bug #2015723. */ -#if !defined(WIN32) && !defined(__CYGWIN__) +#if !defined(_WIN32) && !defined(__CYGWIN__) if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6259216..f624cb7 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -19,7 +19,7 @@ */ #include "tclInt.h" -#ifdef __WIN32__ +#ifdef _WIN32 # include "tclWinInt.h" #endif #include "tclFileSystem.h" @@ -792,7 +792,7 @@ TclFinalizeFilesystem(void) * filesystem is likely to fail. */ -#ifdef __WIN32__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -819,7 +819,7 @@ TclResetFilesystem(void) filesystemList = &nativeFilesystemRecord; theFilesystemEpoch++; -#ifdef __WIN32__ +#ifdef _WIN32 /* * Cleans up the win32 API filesystem proc lookup table. This must happen * very late in finalization so that deleting of copied dlls can occur. @@ -3255,7 +3255,7 @@ Tcl_LoadFile( return TCL_ERROR; } -#ifndef __WIN32__ +#ifndef _WIN32 /* * Do we need to set appropriate permissions on the file? This may be * required on some systems. On Unix we could loop over the file diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h old mode 100644 new mode 100755 diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h old mode 100644 new mode 100755 index 72719fe..2c74b5a --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,7 +13,7 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS -#ifdef __WIN32__ +#ifdef _WIN32 # define Tcl_DirEntry void # define DIR void #endif @@ -45,7 +45,7 @@ extern "C" { * Exported function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -104,7 +104,7 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ @@ -258,7 +258,7 @@ typedef struct TclIntPlatStubs { int magic; void *hooks; -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ @@ -291,7 +291,7 @@ typedef struct TclIntPlatStubs { int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (DWORD errCode); /* 0 */ void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ @@ -371,7 +371,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; * Inline function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ @@ -420,7 +420,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ @@ -550,7 +550,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) # undef TclWinNToHS # define TclWinNToHS ntohs #else diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 5cacab1..7c70e03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -830,7 +830,7 @@ Tcl_UnloadObjCmd( * Unload the shared library from the application memory... */ -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get @@ -1151,7 +1151,7 @@ TclFinalizeLoad(void) pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get diff --git a/generic/tclMain.c b/generic/tclMain.c index faea75a..360f5e9 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -47,7 +47,7 @@ * we have to translate that to strcmp here. */ -#ifndef __WIN32__ +#ifndef _WIN32 # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index b7f3dcf..fe6063f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -512,7 +512,7 @@ TclFSGetPathType( if (PATHFLAGS(pathPtr) == 0) { /* The path is not absolute... */ -#ifdef __WIN32__ +#ifdef _WIN32 /* ... on Windows we must make another call to determine whether * it's relative or volumerelative [Bug 2571597]. */ return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, @@ -1956,7 +1956,7 @@ Tcl_FSGetNormalizedPath( /* * We have a refCount on the cwd. */ -#ifdef __WIN32__ +#ifdef _WIN32 } else if (type == TCL_PATH_VOLUME_RELATIVE) { /* * Only Windows has volume-relative paths. @@ -1969,7 +1969,7 @@ Tcl_FSGetNormalizedPath( return NULL; } pureNormalized = 0; -#endif /* __WIN32__ */ +#endif /* _WIN32 */ } } diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h old mode 100644 new mode 100755 index 681854d..abc8ee8 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -50,7 +50,7 @@ extern "C" { * Exported function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr); @@ -75,7 +75,7 @@ typedef struct TclPlatStubs { int magic; void *hooks; -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ #endif /* WIN */ @@ -97,7 +97,7 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c old mode 100644 new mode 100755 index e1918ef..097269f --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -90,7 +90,7 @@ static unsigned short TclWinNToHS(unsigned short ns) { } #endif -#ifdef __WIN32__ +#ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 @@ -557,7 +557,7 @@ static const TclIntStubs tclIntStubs = { static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ @@ -590,7 +590,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ TclWinConvertWSAError, /* 1 */ TclWinGetServByName, /* 2 */ @@ -661,7 +661,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ #endif /* WIN */ @@ -758,19 +758,19 @@ const TclStubs tclStubs = { Tcl_DbCkalloc, /* 6 */ Tcl_DbCkfree, /* 7 */ Tcl_DbCkrealloc, /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_CreateFileHandler, /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 9 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_CreateFileHandler, /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_DeleteFileHandler, /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 10 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -932,10 +932,10 @@ const TclStubs tclStubs = { Tcl_GetMaster, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 167 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ diff --git a/generic/tclTest.c b/generic/tclTest.c index f121d0d..a27c95a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -414,7 +414,7 @@ static int TestNRELevels(ClientData clientData, static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) static int TestcpuidCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); @@ -681,7 +681,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif @@ -6648,7 +6648,7 @@ TestNumUtfCharsCmd( return TCL_OK; } -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 4b09e1c..5c70a62 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -14,7 +14,7 @@ #include "tclInt.h" -#ifdef WIN32 +#ifdef _WIN32 /* * The information about each joinable thread is remembered in a structure as @@ -305,7 +305,7 @@ TclSignalExitThread( Tcl_MutexUnlock(&threadPtr->threadMutex); } -#endif /* WIN32 */ +#endif /* _WIN32 */ /* * Local Variables: diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index b45e560..7a75dc6 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -283,7 +283,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { set text "" switch $plat { win { - append text "#if defined(__WIN32__)" + append text "#if defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } @@ -294,7 +294,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { append text "#endif /* WIN */\n" } unix { - append text "#if !defined(__WIN32__)" + append text "#if !defined(_WIN32)" if {$withCygwin} { append text " && !defined(__CYGWIN__)" } @@ -320,7 +320,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { append text "#endif /* AQUA */\n" } x11 { - append text "#if !(defined(__WIN32__)" + append text "#if !(defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } diff --git a/win/configure b/win/configure index 569172e..2affd38 100755 --- a/win/configure +++ b/win/configure @@ -3340,7 +3340,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif @@ -3463,7 +3463,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif diff --git a/win/tcl.m4 b/win/tcl.m4 index 625c329..d12ae10 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -572,7 +572,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, AC_TRY_COMPILE([ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif ], [], @@ -639,7 +639,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif ], [], diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 634e1d2..688fa8d 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -69,7 +69,7 @@ TCL_DECLARE_MUTEX(mountPointMap) * We will need this below. */ -#ifdef __WIN32__ +#ifdef _WIN32 #ifndef STATIC_BUILD /* @@ -137,7 +137,7 @@ DllMain( return TRUE; } #endif /* !STATIC_BUILD */ -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* *---------------------------------------------------------------------- diff --git a/win/tclWinTest.c b/win/tclWinTest.c index b83c0ba..6027e32 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -17,7 +17,7 @@ /* * For TestplatformChmod on Windows */ -#ifdef __WIN32__ +#ifdef _WIN32 #include #endif -- cgit v0.12 From 38e56569f541a17fd0445bc3619d66e985e823db Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 11 Feb 2014 08:53:33 +0000 Subject: Changed position of flag evaluation as proposed by Phil Hoffman --- win/tclWinChan.c | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 19e3655..6d480a8 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -886,24 +886,6 @@ TclpOpenFileChannel( } /* - * If the file is being created, get the file attributes from the - * permissions argument, else use the existing file attributes. - */ - - if (mode & O_CREAT) { - if (permissions & S_IWRITE) { - flags = FILE_ATTRIBUTE_NORMAL; - } else { - flags = FILE_ATTRIBUTE_READONLY; - } - } else { - flags = (*tclWinProcs->getFileAttributesProc)(nativeName); - if (flags == 0xFFFFFFFF) { - flags = 0; - } - } - - /* * [2413550] Avoid double-open of serial ports on Windows * Special handling for Windows serial ports by a "name-hint" * to directly open it with the OVERLAPPED flag set. @@ -931,6 +913,24 @@ TclpOpenFileChannel( return channel; } /* + * If the file is being created, get the file attributes from the + * permissions argument, else use the existing file attributes. + */ + + if (mode & O_CREAT) { + if (permissions & S_IWRITE) { + flags = FILE_ATTRIBUTE_NORMAL; + } else { + flags = FILE_ATTRIBUTE_READONLY; + } + } else { + flags = (*tclWinProcs->getFileAttributesProc)(nativeName); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* * Set up the file sharing mode. We want to allow simultaneous access. */ -- cgit v0.12 From 67d68fe341c4c825148b48d7fd74d2136ac8fa6a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Feb 2014 10:58:30 +0000 Subject: Fix execute permission bit (should not be set) for *Decls.h files --- generic/tclDecls.h | 0 generic/tclIntDecls.h | 0 generic/tclIntPlatDecls.h | 0 generic/tclPlatDecls.h | 0 generic/tclStubInit.c | 0 5 files changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 generic/tclDecls.h mode change 100755 => 100644 generic/tclIntDecls.h mode change 100755 => 100644 generic/tclIntPlatDecls.h mode change 100755 => 100644 generic/tclPlatDecls.h mode change 100755 => 100644 generic/tclStubInit.c diff --git a/generic/tclDecls.h b/generic/tclDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h old mode 100755 new mode 100644 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c old mode 100755 new mode 100644 -- cgit v0.12 From 08700ad2348944e47107ddbcbf18bbd7d861668d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 11 Feb 2014 19:53:41 +0000 Subject: Refactor so that CopyAndTranslateBuffer() calls on TranslateInputEOL() instead of duplicating so much of its function. Note the testing gaps. --- generic/tclIO.c | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index cedf3f6..09b8191 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8805,8 +8805,6 @@ CopyAndTranslateBuffer( * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ - int i; /* Iterates over the copied input looking for - * the input eofChar. */ /* * If there is no input at all, return zero. The invariant is that either @@ -8821,6 +8819,15 @@ CopyAndTranslateBuffer( bufPtr = statePtr->inQueueHead; bytesInBuffer = BytesLeft(bufPtr); +#if 1 + copied = space; + if (bytesInBuffer <= copied) { + copied = bytesInBuffer; + } + TranslateInputEOL(statePtr, result, RemovePoint(bufPtr), + &copied, &bytesInBuffer); + bufPtr->nextRemoved += copied; +#else copied = 0; switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: @@ -8842,6 +8849,7 @@ CopyAndTranslateBuffer( case TCL_TRANSLATE_CR: { char *end; + Tcl_Panic("Untested"); if (bytesInBuffer == 0) { return 0; } @@ -8873,6 +8881,7 @@ CopyAndTranslateBuffer( * If there is a held-back "\r" at EOF, produce it now. */ + Tcl_Panic("Untested"); if (bytesInBuffer == 0) { if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == (INPUT_SAW_CR | CHANNEL_EOF)) { @@ -8940,6 +8949,7 @@ CopyAndTranslateBuffer( for (src = result; src < end; src++) { curByte = *src; if (curByte == '\r') { + Tcl_Panic("Untested"); SetFlag(statePtr, INPUT_SAW_CR); *dst = '\n'; dst++; @@ -8965,6 +8975,9 @@ CopyAndTranslateBuffer( */ if (statePtr->inEofChar != 0) { + int i; + + Tcl_Panic("Untested"); for (i = 0; i < copied; i++) { if (result[i] == (char) statePtr->inEofChar) { /* @@ -8979,6 +8992,7 @@ CopyAndTranslateBuffer( } } } +#endif /* * If the current buffer is empty recycle it. -- cgit v0.12 From c3c6e18ae396cac45fbc5d94ce9e2e7b7cc2ffc3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Feb 2014 12:13:32 +0000 Subject: typo --- unix/tclConfig.sh.in | 2 +- win/tclConfig.sh.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/tclConfig.sh.in b/unix/tclConfig.sh.in index d47e686..b58e9fd 100644 --- a/unix/tclConfig.sh.in +++ b/unix/tclConfig.sh.in @@ -165,5 +165,5 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' -# Flag, 1: we built Tcl with threads enables, 0 we didn't +# Flag, 1: we built Tcl with threads enabled, 0 we didn't TCL_THREADS=@TCL_THREADS@ diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in index 65bc5c5..00a8790 100644 --- a/win/tclConfig.sh.in +++ b/win/tclConfig.sh.in @@ -175,6 +175,6 @@ TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' # Path to the Tcl stub library in the install directory. TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' -# Flag, 1: we built Tcl with threads enables, 0 we didn't +# Flag, 1: we built Tcl with threads enabled, 0 we didn't TCL_THREADS=@TCL_THREADS@ -- cgit v0.12 From bd474d3d6b7f770543d6e93ca2b6c9212c551bdf Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 16 Feb 2014 08:18:29 +0000 Subject: [9bf7e67b37]: minor documentation blooper --- doc/tclvars.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/tclvars.n b/doc/tclvars.n index 2fec222..9d7a4ce 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -10,7 +10,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceEval, tcl_wordchars, tcl_version \- Variables used by Tcl +argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP -- cgit v0.12 From abe90f6c1b82d92b9e000f861edde447cf1d7863 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 18 Feb 2014 17:54:06 +0000 Subject: Coverage test for -translation auto handling of INPUT_SAW_CR flag. Demonstrates refactor failure. --- generic/tclIO.c | 1 - tests/io.test | 15 +++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 09b8191..20101c2 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8949,7 +8949,6 @@ CopyAndTranslateBuffer( for (src = result; src < end; src++) { curByte = *src; if (curByte == '\r') { - Tcl_Panic("Untested"); SetFlag(statePtr, INPUT_SAW_CR); *dst = '\n'; dst++; diff --git a/tests/io.test b/tests/io.test index 68051d7..e08c57a 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6730,6 +6730,21 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { file size $path(kyrillic.txt) } 3 +test io-52.12 {coverage of -translation auto} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] -- cgit v0.12 From e3b160fb968cfca1ba3255292e5583bd0bf3e37d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 18 Feb 2014 18:26:22 +0000 Subject: Refactor correction exposed by coverage test. --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 20101c2..01af6dc 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8826,7 +8826,7 @@ CopyAndTranslateBuffer( } TranslateInputEOL(statePtr, result, RemovePoint(bufPtr), &copied, &bytesInBuffer); - bufPtr->nextRemoved += copied; + bufPtr->nextRemoved += bytesInBuffer; #else copied = 0; switch (statePtr->inputTranslation) { -- cgit v0.12 From 997ad71bccf25cf78178d99b5bd94103ef365e4d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 18 Feb 2014 18:35:19 +0000 Subject: coverage test for -translation cr --- generic/tclIO.c | 1 - tests/io.test | 14 ++++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 01af6dc..4197dc0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8849,7 +8849,6 @@ CopyAndTranslateBuffer( case TCL_TRANSLATE_CR: { char *end; - Tcl_Panic("Untested"); if (bytesInBuffer == 0) { return 0; } diff --git a/tests/io.test b/tests/io.test index e08c57a..0c2944b 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6744,6 +6744,20 @@ test io-52.12 {coverage of -translation auto} { close $out file size $path(test2) } 29 +test io-52.13 {coverage of -translation cr} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation cr + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 30 test io-53.1 {CopyData} {fcopy} { file delete $path(test1) -- cgit v0.12 From 9afa8a13e86fbd71a030ead7909cbe7d7db76296 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 18 Feb 2014 21:27:35 +0000 Subject: Another coverage test that reveals refactoring error. --- generic/tclIO.c | 2 +- tests/io.test | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4197dc0..c862923 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8880,10 +8880,10 @@ CopyAndTranslateBuffer( * If there is a held-back "\r" at EOF, produce it now. */ - Tcl_Panic("Untested"); if (bytesInBuffer == 0) { if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == (INPUT_SAW_CR | CHANNEL_EOF)) { + Tcl_Panic("Untested"); result[0] = '\r'; ResetFlag(statePtr, INPUT_SAW_CR); return 1; diff --git a/tests/io.test b/tests/io.test index 0c2944b..4df44a3 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6758,6 +6758,20 @@ test io-52.13 {coverage of -translation cr} { close $out file size $path(test2) } 30 +test io-52.14 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 test io-53.1 {CopyData} {fcopy} { file delete $path(test1) -- cgit v0.12 From 1a35a544342c26a5fa207edcd05448d6f525d9a1 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 18 Feb 2014 23:20:06 +0000 Subject: Callers of TranslateInputEOL are expected to manage the INPUT_NEED_NL flag. --- generic/tclIO.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index c862923..68d370a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8824,6 +8824,20 @@ CopyAndTranslateBuffer( if (bytesInBuffer <= copied) { copied = bytesInBuffer; } + if (copied == 0) { + return 0; + } + if (statePtr->flags & INPUT_NEED_NL) { + ResetFlag(statePtr, INPUT_NEED_NL); + + if (RemovePoint(bufPtr)[0] == '\n') { + bufPtr->nextRemoved++; + *result = '\n'; + } else { + *result = '\r'; + } + return 1; + } TranslateInputEOL(statePtr, result, RemovePoint(bufPtr), &copied, &bytesInBuffer); bufPtr->nextRemoved += bytesInBuffer; -- cgit v0.12 From 03c5b98228950023fde73077aa1b3e401e373d1c Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 19 Feb 2014 03:36:15 +0000 Subject: Shortcut ReadBytes() when it's a no-op. --- generic/tclIO.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 68d370a..7820242 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5201,6 +5201,9 @@ ReadBytes( if ((unsigned) toRead > (unsigned) srcLen) { toRead = srcLen; } + if (toRead == 0) { + return 0; + } (void) Tcl_GetByteArrayFromObj(objPtr, &length); TclAppendBytesToByteArray(objPtr, NULL, toRead); @@ -5209,7 +5212,7 @@ ReadBytes( if (statePtr->flags & INPUT_NEED_NL) { ResetFlag(statePtr, INPUT_NEED_NL); - if ((srcLen == 0) || (*src != '\n')) { + if (*src != '\n') { *dst = '\r'; length += 1; Tcl_SetByteArrayLength(objPtr, length); -- cgit v0.12 From e9a5cb0bbfec8877ccb5b56d39e6100ba9c5e42d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 19 Feb 2014 03:45:17 +0000 Subject: Next coverage test to expose another refactoring error. --- generic/tclIO.c | 1 - tests/io.test | 14 ++++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7820242..3b2b53e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8900,7 +8900,6 @@ CopyAndTranslateBuffer( if (bytesInBuffer == 0) { if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == (INPUT_SAW_CR | CHANNEL_EOF)) { - Tcl_Panic("Untested"); result[0] = '\r'; ResetFlag(statePtr, INPUT_SAW_CR); return 1; diff --git a/tests/io.test b/tests/io.test index 4df44a3..8c066ca 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6772,6 +6772,20 @@ test io-52.14 {coverage of -translation crlf} { close $out file size $path(test2) } 29 +test io-52.15 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\r + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 test io-53.1 {CopyData} {fcopy} { file delete $path(test1) -- cgit v0.12 From 58b67990b95b7d36b3099c43cfcf6448b9c1b23d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 19 Feb 2014 14:10:55 +0000 Subject: [1230597] Update test comment. --- tests/namespace.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/namespace.test b/tests/namespace.test index b59e09e..71b6860 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -301,7 +301,7 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { +test namespace-9.5 {Tcl_Import, RFE 1230597} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg } {0 {}} test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { -- cgit v0.12 From d0f15c03d3f5385a24eea5b7b2cdc6f8d95a8933 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 20 Feb 2014 03:51:16 +0000 Subject: Refactoring repair to fix failing test. --- generic/tclIO.c | 52 +++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 37 insertions(+), 15 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 3b2b53e..3cddc29 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8808,6 +8808,7 @@ CopyAndTranslateBuffer( * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ + int toCopy; /* * If there is no input at all, return zero. The invariant is that either @@ -8822,30 +8823,51 @@ CopyAndTranslateBuffer( bufPtr = statePtr->inQueueHead; bytesInBuffer = BytesLeft(bufPtr); + copied = 0; #if 1 - copied = space; - if (bytesInBuffer <= copied) { - copied = bytesInBuffer; - } - if (copied == 0) { - return 0; - } if (statePtr->flags & INPUT_NEED_NL) { - ResetFlag(statePtr, INPUT_NEED_NL); - if (RemovePoint(bufPtr)[0] == '\n') { - bufPtr->nextRemoved++; - *result = '\n'; - } else { + /* + * An earlier call to TranslateInputEOL ended in the read of a \r . + * Only the next read from the same channel can complete the + * translation sequence to tell us what character we should read. + */ + + if (bytesInBuffer) { + /* There's a next byte. It will settle things. */ + ResetFlag(statePtr, INPUT_NEED_NL); + + if (RemovePoint(bufPtr)[0] == '\n') { + bufPtr->nextRemoved++; + bytesInBuffer--; + *result++ = '\n'; + } else { + *result++ = '\r'; + } + copied++; + space--; + } else if (statePtr->flags & CHANNEL_EOF) { + /* There is no next byte, and there never will be (EOF). */ + ResetFlag(statePtr, INPUT_NEED_NL); *result = '\r'; + return 1; + } else { + /* There is no next byte. Ask the caller to read more. */ + return 0; } - return 1; + } + toCopy = space; + if (bytesInBuffer <= toCopy) { + toCopy = bytesInBuffer; + } + if (toCopy == 0) { + return copied; } TranslateInputEOL(statePtr, result, RemovePoint(bufPtr), - &copied, &bytesInBuffer); + &toCopy, &bytesInBuffer); bufPtr->nextRemoved += bytesInBuffer; + copied += toCopy; #else - copied = 0; switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: if (bytesInBuffer == 0) { -- cgit v0.12 From ddaf1d27cb4ec6db78294cb42e1fd46ae6d2dbc2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 20 Feb 2014 20:31:55 +0000 Subject: Can we send some binary reads down the char-reading path? --- generic/tclIO.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 3636861..4d7133a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5096,7 +5096,8 @@ DoReadChars( for (copied = 0; (unsigned) toRead > 0; ) { copiedNow = -1; if (statePtr->inQueueHead != NULL) { - if (encoding == NULL) { + if (encoding == NULL + && statePtr->inputTranslation == TCL_TRANSLATE_LF) { copiedNow = ReadBytes(statePtr, objPtr, toRead, &offset); } else { copiedNow = ReadChars(statePtr, objPtr, toRead, &offset, @@ -5320,6 +5321,8 @@ ReadChars( char *src, *dst; Tcl_EncodingState oldState; int encEndFlagSuppressed = 0; + Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding + : GetBinaryEncoding(); factor = *factorPtr; offset = *offsetPtr; @@ -5424,7 +5427,7 @@ ReadChars( */ ResetFlag(statePtr, INPUT_NEED_NL); - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars); if ((dstWrote > 0) && (*dst == '\n')) { @@ -5449,7 +5452,7 @@ ReadChars( return 1; } - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstNeeded + 1, &srcRead, &dstWrote, &numChars); @@ -5522,7 +5525,7 @@ ReadChars( return -1; } statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); @@ -5545,7 +5548,7 @@ ReadChars( eof = Tcl_UtfAtIndex(dst, toRead); statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); dstRead = dstWrote; -- cgit v0.12 From 9f6aaa68fc35449d224e5a1ea5d53e09ac38e509 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 20 Feb 2014 21:23:33 +0000 Subject: Switch consistently on the narrower def of binary mode. --- generic/tclIO.c | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4d7133a..eae063b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5060,6 +5060,7 @@ DoReadChars( ChannelBuffer *bufPtr; int offset, factor, copied, copiedNow, result; Tcl_Encoding encoding; + int binaryMode; #define UTF_EXPANSION_FACTOR 1024 /* @@ -5070,8 +5071,12 @@ DoReadChars( encoding = statePtr->encoding; factor = UTF_EXPANSION_FACTOR; + binaryMode = (encoding == NULL) + && (statePtr->inputTranslation == TCL_TRANSLATE_LF) + && (statePtr->inEofChar == NULL); + if (appendFlag == 0) { - if (encoding == NULL) { + if (binaryMode) { Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); @@ -5086,7 +5091,7 @@ DoReadChars( } offset = 0; } else { - if (encoding == NULL) { + if (binaryMode) { Tcl_GetByteArrayFromObj(objPtr, &offset); } else { TclGetStringFromObj(objPtr, &offset); @@ -5096,8 +5101,7 @@ DoReadChars( for (copied = 0; (unsigned) toRead > 0; ) { copiedNow = -1; if (statePtr->inQueueHead != NULL) { - if (encoding == NULL - && statePtr->inputTranslation == TCL_TRANSLATE_LF) { + if (binaryMode) { copiedNow = ReadBytes(statePtr, objPtr, toRead, &offset); } else { copiedNow = ReadChars(statePtr, objPtr, toRead, &offset, @@ -5146,7 +5150,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED); - if (encoding == NULL) { + if (binaryMode) { Tcl_SetByteArrayLength(objPtr, offset); } else { Tcl_SetObjLength(objPtr, offset); -- cgit v0.12 From 82eaf13ae6136c9679b5aeba5c75cd777f2829dd Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 21 Feb 2014 15:02:35 +0000 Subject: fix type error --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index eae063b..ac28ec0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5073,7 +5073,7 @@ DoReadChars( binaryMode = (encoding == NULL) && (statePtr->inputTranslation == TCL_TRANSLATE_LF) - && (statePtr->inEofChar == NULL); + && (statePtr->inEofChar == '\0'); if (appendFlag == 0) { if (binaryMode) { -- cgit v0.12 From 527d583d939f70450bc8b3db5077dd7d806c7c3e Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 21 Feb 2014 15:12:16 +0000 Subject: Simplify ReadBytes based on new constraints. --- generic/tclIO.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index ac28ec0..23e1fbf 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5242,6 +5242,10 @@ ReadBytes( } dst += offset; +#if 1 + memcpy(dst, src, (size_t) toRead); + srcRead = dstWrote = toRead; +#else if (statePtr->flags & INPUT_NEED_NL) { ResetFlag(statePtr, INPUT_NEED_NL); if ((srcLen == 0) || (*src != '\n')) { @@ -5262,6 +5266,7 @@ ReadBytes( return -1; } } +#endif bufPtr->nextRemoved += srcRead; *offsetPtr += dstWrote; return dstWrote; -- cgit v0.12 From eb24399a17b85fad292fe5137bb9ea641f8b7896 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 23 Feb 2014 13:07:36 +0000 Subject: [3597178]: Improve documentation of what's going on with encodings --- doc/encoding.n | 34 +++++++++++++++++++++++++++------- doc/string.n | 28 ++++++++++++++++++++++++---- 2 files changed, 51 insertions(+), 11 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index be1dc3f..5782199 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -14,10 +14,21 @@ encoding \- Manipulate encodings .BE .SH INTRODUCTION .PP -Strings in Tcl are encoded using 16-bit Unicode characters. Different -operating system interfaces or applications may generate strings in -other encodings such as Shift-JIS. The \fBencoding\fR command helps -to bridge the gap between Unicode and these other formats. +Strings in Tcl are logically a sequence of 16-bit Unicode characters. +These strings are represented in memory as a sequence of bytes that +may be in one of several encodings: modified UTF\-8 (which uses 1 to 3 +bytes per character), 16-bit +.QW Unicode +(which uses 2 bytes per character, with an endianness that is +dependent on the host architecture), and binary (which uses a single +byte per character but only handles a restricted range of characters). +Tcl does not guarantee to always use the same encoding for the same +string. +.PP +Different operating system interfaces or applications may generate +strings in other encodings such as Shift\-JIS. The \fBencoding\fR +command helps to bridge the gap between Unicode and these other +formats. .SH DESCRIPTION .PP Performs one of several encoding related operations, depending on @@ -37,8 +48,9 @@ system encoding is used. Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted string. Each byte is stored in the lower 8-bits of a Unicode -character. If \fIencoding\fR is not specified, the current -system encoding is used. +character (indeed, the resulting string is a binary string as far as +Tcl is concerned, at least initially). If \fIencoding\fR is not +specified, the current system encoding is used. .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -56,6 +68,11 @@ searchable directory, that element is ignored. . Returns a list containing the names of all of the encodings that are currently available. +The encodings +.QW utf-8 +and +.QW iso8859-1 +are guaranteed to be present in the list. .TP \fBencoding system\fR ?\fIencoding\fR? . @@ -73,7 +90,7 @@ However, because the \fBsource\fR command always reads files using the current system encoding, Tcl will only source such files correctly when the encoding used to write the file is the same. This tends not to be true in an internationalized setting. For example, if such a -file was sourced in North America (where the ISO8859-1 is normally +file was sourced in North America (where the ISO8859\-1 is normally used), each byte in the file would be treated as a separate character that maps to the 00 page in Unicode. The resulting Tcl strings will not contain the expected Japanese characters. Instead, they will @@ -93,3 +110,6 @@ which is the Hiragana letter HA. Tcl_GetEncoding(3) .SH KEYWORDS encoding, unicode +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/doc/string.n b/doc/string.n index 76005fc..163abdd 100644 --- a/doc/string.n +++ b/doc/string.n @@ -343,10 +343,13 @@ misleading. \fBstring bytelength \fIstring\fR . Returns a decimal string giving the number of bytes used to represent -\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to -represent Unicode characters, the byte length will not be the same as -the character length in general. The cases where a script cares about -the byte length are rare. +\fIstring\fR in memory when encoded as Tcl's internal modified UTF\-8; +Tcl may use other encodings for \fIstring\fR as well, and does not +guarantee to only use a single encoding for a particular \fIstring\fR. +Because UTF\-8 uses a variable number of bytes to represent Unicode +characters, the byte length will not be the same as the character +length in general. The cases where a script cares about the byte +length are rare. .RS .PP In almost all cases, you should use the @@ -354,10 +357,27 @@ In almost all cases, you should use the Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual entry for more details on the UTF\-8 representation. .PP +Formally, the \fBstring bytelength\fR operation returns the content of +the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling +\fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated. +This is highly unlikely to be useful to Tcl scripts, as Tcl's internal +encoding is not strict UTF\-8, but rather a modified CESU\-8 with a +denormalized NUL (identical to that used in a number of places by +Java's serialization mechanism) to enable basic processing with +non-Unicode-aware C functions. As this representation should only +ever be used by Tcl's implementation, the number of bytes used to +store the representation is of very low value (except to C extension +code, which has direct access for the purpose of memory management, +etc.) +.PP \fICompatibility note:\fR it is likely that this subcommand will be withdrawn in a future version of Tcl. It is better to use the \fBencoding convertto\fR command to convert a string to a known encoding and then apply \fBstring length\fR to that. +.PP +.CS +\fBstring length\fR [encoding convertto utf-8 $theString] +.CE .RE .TP \fBstring wordend \fIstring charIndex\fR -- cgit v0.12 From 73bf5da01200e7f7127273188ea24d751eb75ddf Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 24 Feb 2014 21:01:07 +0000 Subject: simplification trims --- generic/tclIO.c | 34 ++++------------------------------ 1 file changed, 4 insertions(+), 30 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5625ff2..1c5fed4 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5194,7 +5194,7 @@ ReadBytes( * the bytes from the first buffer are * returned. */ { - int toRead, srcLen, length, srcRead, dstWrote; + int toRead, srcLen, length; ChannelBuffer *bufPtr; char *src, *dst; @@ -5215,37 +5215,11 @@ ReadBytes( dst = (char *) Tcl_GetByteArrayFromObj(objPtr, NULL); dst += length; -#if 1 memcpy(dst, src, (size_t) toRead); - srcRead = dstWrote = toRead; -#else - if (statePtr->flags & INPUT_NEED_NL) { - ResetFlag(statePtr, INPUT_NEED_NL); - if (*src != '\n') { - *dst = '\r'; - length += 1; - Tcl_SetByteArrayLength(objPtr, length); - return 1; - } - *dst++ = '\n'; - src++; - srcLen--; - toRead--; - } - - srcRead = srcLen; - dstWrote = toRead; - if (TranslateInputEOL(statePtr, dst, src, &dstWrote, &srcRead) != 0) { - if (dstWrote == 0) { - Tcl_SetByteArrayLength(objPtr, length); - return -1; - } - } -#endif - bufPtr->nextRemoved += srcRead; - length += dstWrote; + bufPtr->nextRemoved += toRead; + length += toRead; Tcl_SetByteArrayLength(objPtr, length); - return dstWrote; + return toRead; } /* -- cgit v0.12 From c7f19f76c5362c2918fe01d49808b3246fd84100 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 24 Feb 2014 21:25:08 +0000 Subject: Reduce ReadBytes to simplest expression. --- generic/tclIO.c | 28 +++++----------------------- 1 file changed, 5 insertions(+), 23 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 1c5fed4..a73f041 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5194,31 +5194,13 @@ ReadBytes( * the bytes from the first buffer are * returned. */ { - int toRead, srcLen, length; - ChannelBuffer *bufPtr; - char *src, *dst; - - bufPtr = statePtr->inQueueHead; - src = RemovePoint(bufPtr); - srcLen = BytesLeft(bufPtr); - - toRead = bytesToRead; - if ((unsigned) toRead > (unsigned) srcLen) { - toRead = srcLen; - } - if (toRead == 0) { - return 0; - } - - (void) Tcl_GetByteArrayFromObj(objPtr, &length); - TclAppendBytesToByteArray(objPtr, NULL, toRead); - dst = (char *) Tcl_GetByteArrayFromObj(objPtr, NULL); - dst += length; + ChannelBuffer *bufPtr = statePtr->inQueueHead; + int srcLen = BytesLeft(bufPtr); + int toRead = bytesToRead>srcLen || bytesToRead<0 ? srcLen : bytesToRead; - memcpy(dst, src, (size_t) toRead); + TclAppendBytesToByteArray(objPtr, (unsigned char *) RemovePoint(bufPtr), + toRead); bufPtr->nextRemoved += toRead; - length += toRead; - Tcl_SetByteArrayLength(objPtr, length); return toRead; } -- cgit v0.12 From 259729fa361e6d184ef91be067a93309e14cd998 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Feb 2014 15:49:52 +0000 Subject: [8d5f5b8034] Flush internal representations in [string tolower] of unshared obj --- generic/tclExecute.c | 3 +++ tests/string.test | 9 +++++++++ 2 files changed, 12 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 89305e6..41730d3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5392,6 +5392,7 @@ TEBCresume( } else { length = Tcl_UtfToUpper(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5408,6 +5409,7 @@ TEBCresume( } else { length = Tcl_UtfToLower(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5424,6 +5426,7 @@ TEBCresume( } else { length = Tcl_UtfToTitle(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } diff --git a/tests/string.test b/tests/string.test index 740cdc6..cf658a2 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1398,6 +1398,9 @@ test string-15.9 {string tolower} { test string-15.10 {string tolower, unicode} { string tolower ABCabc\xc7\xe7 } "abcabc\xe7\xe7" +test string-15.11 {string tolower, compiled} { + lindex [string tolower [list A B [list C]]] 1 +} b test string-16.1 {string toupper} { list [catch {string toupper} msg] $msg @@ -1429,6 +1432,9 @@ test string-16.9 {string toupper} { test string-16.10 {string toupper, unicode} { string toupper ABCabc\xc7\xe7 } "ABCABC\xc7\xc7" +test string-16.11 {string toupper, compiled} { + lindex [string toupper [list a b [list c]]] 1 +} B test string-17.1 {string totitle} { list [catch {string totitle} msg] $msg @@ -1451,6 +1457,9 @@ test string-17.6 {string totitle, unicode} { test string-17.7 {string totitle, unicode} { string totitle \u01f3BCabc\xc7\xe7 } "\u01f2bcabc\xe7\xe7" +test string-17.8 {string totitle, compiled} { + lindex [string totitle [list aa bb [list cc]]] 0 +} Aa test string-18.1 {string trim} { list [catch {string trim} msg] $msg -- cgit v0.12 From e3adf1d9a076bcb2704e4364c50097b49e6348c5 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Feb 2014 11:26:00 +0000 Subject: More coverage tests and bug fixes. --- generic/tclIO.c | 3 +-- tests/io.test | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index a73f041..c2a8cab 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5644,7 +5644,7 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL); +// ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL); return 1; } @@ -8981,7 +8981,6 @@ CopyAndTranslateBuffer( if (statePtr->inEofChar != 0) { int i; - Tcl_Panic("Untested"); for (i = 0; i < copied; i++) { if (result[i] == (char) statePtr->inEofChar) { /* diff --git a/tests/io.test b/tests/io.test index 8c066ca..6f4877f 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6786,6 +6786,62 @@ test io-52.15 {coverage of -translation crlf} { close $out file size $path(test2) } 8 +test io-52.16 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar a + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 0 +test io-52.17 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar d + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 3 +test io-52.18 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 +test io-52.19 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 10 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 test io-53.1 {CopyData} {fcopy} { file delete $path(test1) -- cgit v0.12 From 33648948cab45a58ba614f448459fdcb133023dc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Feb 2014 13:16:18 +0000 Subject: Simplify macro handling in tclOO*Decls.h, just as already done in "novem" [0c37ab8944], itcl*Decls.h and tdbc*Decls.h. This doesn't change the way symbols are exported. This simplifications were already present in the Tcl 8.6.2 headers, but those were buggy when tclOO was linked in statically without using stubs. --- generic/tclOO.decls | 1 + generic/tclOODecls.h | 78 ++++++++++++++++++++++++------------------------- generic/tclOOIntDecls.h | 45 ++++++++++------------------ 3 files changed, 55 insertions(+), 69 deletions(-) diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 5d6f2c2..265ba88 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -18,6 +18,7 @@ library tclOO interface tclOO hooks tclOOInt +scspec TCLAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index d3b9e59..9fd62ec 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,19 +5,19 @@ #ifndef _TCLOODECLS #define _TCLOODECLS -#undef TCL_STORAGE_CLASS -#ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# ifdef USE_TCL_STUBS -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS -# define TCL_STORAGE_CLASS +#ifndef TCLAPI +# ifdef BUILD_tcl +# define TCLAPI extern DLLEXPORT # else -# define TCL_STORAGE_CLASS DLLIMPORT +# define TCLAPI extern DLLIMPORT # endif #endif +#ifdef USE_TCL_STUBS +# undef USE_TCLOO_STUBS +# define USE_TCLOO_STUBS +#endif + /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -29,92 +29,92 @@ extern "C" { */ /* 0 */ -EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +TCLAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +TCLAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +TCLAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +TCLAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +TCLAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +TCLAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -EXTERN int Tcl_MethodIsPublic(Tcl_Method method); +TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -EXTERN int Tcl_MethodIsType(Tcl_Method method, +TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method); +TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -EXTERN int Tcl_ObjectDeleted(Tcl_Object object); +TCLAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -EXTERN int Tcl_ObjectContextIsFiltering( +TCLAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +TCLAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -EXTERN int Tcl_ObjectContextSkippedArgs( +TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz, +TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object, +TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +TCLAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp, +TCLAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp, +TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); typedef struct { @@ -231,6 +231,4 @@ extern const TclOOStubs *tclOOStubsPtr; /* !END!: Do not edit above this line. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOODECLS */ diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index 4f70e5b..74a8d81 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -5,17 +5,6 @@ #ifndef _TCLOOINTDECLS #define _TCLOOINTDECLS -#undef TCL_STORAGE_CLASS -#ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# ifdef USE_TCL_STUBS -# define TCL_STORAGE_CLASS -# else -# define TCL_STORAGE_CLASS DLLIMPORT -# endif -#endif - /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -27,46 +16,46 @@ extern "C" { */ /* 0 */ -EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +TCLAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr); +TCLAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -75,7 +64,7 @@ EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -84,22 +73,22 @@ EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -EXTERN int TclOOInvokeObject(Tcl_Interp *interp, +TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters, +TCLAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -EXTERN void TclOOClassSetFilters(Tcl_Interp *interp, +TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -EXTERN void TclOOClassSetMixins(Tcl_Interp *interp, +TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); @@ -174,6 +163,4 @@ extern const TclOOIntStubs *tclOOIntStubsPtr; /* !END!: Do not edit above this line. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLOOINTDECLS */ -- cgit v0.12 From 5a1cac2f139731c8a4cacfc7dce7b8c456e860f4 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Feb 2014 17:47:46 +0000 Subject: New tests covering INPUT_NEED_NL flag handling. One exposes a bug. --- tests/io.test | 71 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) diff --git a/tests/io.test b/tests/io.test index 68051d7..64c878d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -4701,6 +4701,77 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f list $c $l $e } {21 8 1} +test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} {8 8 1 13} +test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} {9 8 1 13} +test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} {2 1 1 13} +test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} {1 1 1 13} +test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} {17 8 1 13} # Test Tcl_InputBlocked -- cgit v0.12 From aad7393c9adb8f82f2594929954960b91d027032 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Feb 2014 20:11:47 +0000 Subject: remove comment --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c2a8cab..8d75bf2 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5644,7 +5644,7 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; -// ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL); + ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL); return 1; } -- cgit v0.12 From 3df8548690a047e4fa9a445a253636a3e3a652df Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Feb 2014 20:21:10 +0000 Subject: Work in progress attempting a ReadChars rewrite. --- generic/tclIO.c | 120 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 119 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 3636861..20428b5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5372,6 +5372,120 @@ ReadChars( } dst = objPtr->bytes + offset; +#if 1 + + /* + * This routine is burdened with satisfying several constraints. + * It cannot append more than 'charsToRead` chars onto objPtr. + * This is measured after encoding and translation transformations + * are completed. There is no precise number of src bytes that can + * be associated with the limit. Yet, when we are done, we must know + * precisely the number of src bytes that were consumed to produce + * the appended chars, so that all subsequent bytes are left in + * the buffers for future read operations. + * + * The consequence is that we have no choice but to implement a + * "trial and error" approach, where in general we may need to + * perform transformations and copies multiple times to achieve + * a consistent set of results. This takes the shape of a loop. + */ + + int dstLimit = dstNeeded + 1; + int savedFlags = statePtr->flags; + int savedIEFlags = statePtr->inputEncodingFlags; + Tcl_EncodingState savedState = statePtr->inputEncodingState; + + while (1) { + int dstDecoded; + + /* + * Perform the encoding transformation. Read no more than + * srcLen bytes, write no more than dstLimit bytes. + */ + +//fprintf(stdout, "Start %d %d\n", dstLimit, srcLen); fflush(stdout); + int code = Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + statePtr->inputEncodingFlags & (bufPtr->nextPtr + ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, + dst, dstLimit, &srcRead, &dstDecoded, &numChars); + + /* + * Perform the translation transformation in place. Read no more + * than the dstDecoded bytes the encoding transformation actually + * produced. Capture the number of bytes written in dstWrote. + * Capture the number of bytes actually consumed in dstRead. + */ + +//fprintf(stdout, "Key NS=%d MB=%d S=%d\n", TCL_CONVERT_NOSPACE, +//TCL_CONVERT_MULTIBYTE, TCL_CONVERT_SYNTAX); fflush(stdout); +//fprintf(stdout, "Decoded %d %d\n", dstDecoded,code); fflush(stdout); + dstWrote = dstRead = dstDecoded; + TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); + + if (dstRead < dstDecoded) { + + /* + * The encoding transformation produced bytes that the + * translation transformation did not consume. Start over + * and impose new limits so that doesn't happen again. + */ +//fprintf(stdout, "X! %d %d\n", dstRead, dstDecoded); fflush(stdout); + + dstLimit = dstRead + TCL_UTF_MAX; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } + +//fprintf(stdout, "check %d %d %d\n", dstWrote, dstRead, dstDecoded); +//fflush(stdout); + + /* + * The translation transformation can only reduce the number + * of chars when it converts \r\n into \n. The reduction in + * the number of chars is the difference in bytes read and written. + */ + + numChars -= (dstRead - dstWrote); + + if (charsToRead > 0 && numChars > charsToRead) { + + /* + * We read more chars than allowed. Reset limits to + * prevent that and try again. + */ +//fprintf(stdout, "Y!\n"); fflush(stdout); + + dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - dst; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } + + if (dstWrote == 0) { + +//fprintf(stdout, "Z!\n"); fflush(stdout); + /* + * Could not read anything. Ask caller to get more data. + */ + + return -1; + } + + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; + + bufPtr->nextRemoved += srcRead; + if (dstWrote > srcRead + 1) { + *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + } + *offsetPtr += dstWrote; +//fprintf(stdout, "OK: %d\n", numChars); fflush(stdout); + return numChars; + } + +#else /* * [Bug 1462248]: The cause of the crash reported in this bug is this: * @@ -5560,6 +5674,7 @@ ReadChars( } *offsetPtr += dstWrote; return numChars; +#endif } /* @@ -5661,7 +5776,9 @@ TranslateInputEOL( if (*src == '\r') { src++; if (src >= srcMax) { - SetFlag(statePtr, INPUT_NEED_NL); +// SetFlag(statePtr, INPUT_NEED_NL); +//fprintf(stdout, "BREAK!\n"); fflush(stdout); +src--; break; } else if (*src == '\n') { *dst++ = *src++; } else { @@ -5673,6 +5790,7 @@ TranslateInputEOL( } srcLen = src - srcStart; dstLen = dst - dstStart; +//fprintf(stdout, "eh? %d %d\n", srcLen, dstLen); fflush(stdout); break; } case TCL_TRANSLATE_AUTO: { -- cgit v0.12 From 67ca0cb05fe3153db733521fbff66e5ba180358c Mon Sep 17 00:00:00 2001 From: max Date: Fri, 28 Feb 2014 10:47:53 +0000 Subject: Broken intermediate state. Calling back to CreateClientSocket() from the event loop works, but the final failed or succeeded state of an asyncronous socket does not get notified to the channel correctly. --- unix/tclUnixSock.c | 15 +++ win/tclWinSock.c | 365 ++++++++++++++++++++++++++++++++--------------------- 2 files changed, 234 insertions(+), 146 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 49a6460..c866903 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -163,6 +163,18 @@ static TclInitProcessGlobalValueProc InitializeHostName; static ProcessGlobalValue hostName = {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; +void printaddrinfo(struct addrinfo *addrlist, char *prefix) +{ + char host[NI_MAXHOST], port[NI_MAXSERV]; + struct addrinfo *ai; + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { + getnameinfo(ai->ai_addr, ai->ai_addrlen, + host, sizeof(host), + port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); + fprintf(stderr,"%s: %s:%s\n", prefix, host, port); + } +} /* *---------------------------------------------------------------------- * @@ -1160,6 +1172,9 @@ Tcl_OpenTcpClient( return NULL; } + printaddrinfo(myaddrlist, "local"); + printaddrinfo(addrlist, "remote"); + /* * Allocate a new TcpState for this socket. */ diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 958e4ac..6afa094 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,6 +47,12 @@ #include "tclWinInt.h" +#if 1 +#define DEBUG(x) fprintf(stderr, ">>> %s(%d): %s<<<\n", __FUNCTION__, __LINE__, x) +#else +#define DEBUG(x) +#endif + /* * Which version of the winsock API do we want? */ @@ -76,7 +82,7 @@ /* "sock" + a pointer in hex + \0 */ #define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) -#define SOCK_TEMPLATE "sock%lx" +#define SOCK_TEMPLATE "sock%p" /* * The following variable is used to tell whether this module has been @@ -156,6 +162,12 @@ struct SocketInfo { Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ + struct addrinfo *addrlist; /* Addresses to connect to. */ + struct addrinfo *addr; /* Iterator over addrlist. */ + struct addrinfo *myaddrlist;/* Local address. */ + struct addrinfo *myaddr; /* Iterator over myaddrlist. */ + int status; /* Cache status of async socket. */ + int cachedBlocking; /* Cache blocking mode of async socket. */ int lastError; /* Error code from last message. */ struct SocketInfo *nextPtr; /* The next socket on the per-thread socket * list. */ @@ -214,9 +226,7 @@ static WNDCLASS windowClass; * Static functions defined in this file. */ -static SocketInfo * CreateClientSocket(Tcl_Interp *interp, int port, - const char *host, const char *myaddr, - int myport, int async); +static int CreateClientSocket(Tcl_Interp *interp, SocketInfo *infoPtr); static void InitSockets(void); static SocketInfo * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); @@ -267,6 +277,22 @@ static const Tcl_ChannelType tcpChannelType = { TcpThreadActionProc, /* thread action proc */ NULL /* truncate */ }; +void printaddrinfo(struct addrinfo *ai, char *prefix) +{ + char host[NI_MAXHOST], port[NI_MAXSERV]; + getnameinfo(ai->ai_addr, ai->ai_addrlen, + host, sizeof(host), + port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); + fprintf(stderr,"%s: [%s]:%s\n", prefix, host, port); +} +void printaddrinfolist(struct addrinfo *addrlist, char *prefix) +{ + struct addrinfo *ai; + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { + printaddrinfo(ai, prefix); + } +} /* *---------------------------------------------------------------------- @@ -699,6 +725,8 @@ SocketEventProc( address addr; int len; + DEBUG("xxx"); + if (!(flags & TCL_FILE_EVENTS)) { return 0; } @@ -841,20 +869,18 @@ SocketEventProc( (WPARAM) SELECT, (LPARAM) infoPtr); } } - if (events & (FD_WRITE | FD_CONNECT)) { + if (events & FD_WRITE) { mask |= TCL_WRITABLE; - if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) { - /* - * Connect errors should also fire the readable handler. - */ - - mask |= TCL_READABLE; - } } - + if (events & FD_CONNECT) { + DEBUG("Calling CreateClientSocket..."); + CreateClientSocket(NULL, infoPtr); + } if (mask) { + DEBUG("Calling Tcl_NotifyChannel..."); Tcl_NotifyChannel(infoPtr->channel, mask); } + DEBUG("returning..."); return 1; } @@ -944,6 +970,13 @@ TcpCloseProc( } } + if (infoPtr->addrlist != NULL) { + freeaddrinfo(infoPtr->addrlist); + } + if (infoPtr->myaddrlist != NULL) { + freeaddrinfo(infoPtr->myaddrlist); + } + /* * TIP #218. Removed the code removing the structure from the global * socket list. This is now done by the thread action callbacks, and only @@ -1072,22 +1105,11 @@ AddSocketInfoFd( */ static SocketInfo * -NewSocketInfo( - SOCKET socket) +NewSocketInfo(SOCKET socket) { SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo)); - /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ - infoPtr->channel = 0; - infoPtr->sockets = NULL; - infoPtr->flags = 0; - infoPtr->watchEvents = 0; - infoPtr->readyEvents = 0; - infoPtr->selectEvents = 0; - infoPtr->acceptEventCount = 0; - infoPtr->acceptProc = NULL; - infoPtr->acceptProcData = NULL; - infoPtr->lastError = 0; + memset(infoPtr, 0, sizeof(SocketInfo)); /* * TIP #218. Removed the code inserting the new structure into the global @@ -1095,8 +1117,6 @@ NewSocketInfo( * there. */ - infoPtr->nextPtr = NULL; - AddSocketInfoFd(infoPtr, socket); return infoPtr; @@ -1107,193 +1127,189 @@ NewSocketInfo( * * CreateClientSocket -- * - * This function opens a new client socket and initializes the - * SocketInfo structure. + * This function opens a new socket in client mode. * * Results: - * Returns a new SocketInfo, or NULL with an error in interp. + * TCL_OK, if the socket was successfully connected or an asynchronous + * connection is in progress. If an error occurs, TCL_ERROR is returned + * and an error message is left in interp. * * Side effects: - * None, except for allocation of memory. + * Opens a socket. + * + * Remarks: + * A single host name may resolve to more than one IP address, e.g. for + * an IPv4/IPv6 dual stack host. For handling asyncronously connecting + * sockets in the background for such hosts, this function can act as a + * coroutine. On the first call, it sets up the control variables for the + * two nested loops over the local and remote addresses. Once the first + * connection attempt is in progress, it sets up itself as a writable + * event handler for that socket, and returns. When the callback occurs, + * control is transferred to the "reenter" label, right after the initial + * return and the loops resume as if they had never been interrupted. + * For syncronously connecting sockets, the loops work the usual way. * *---------------------------------------------------------------------- */ -static SocketInfo * +static int CreateClientSocket( Tcl_Interp *interp, /* For error reporting; can be NULL. */ - int port, /* Port number to open. */ - const char *host, /* Name of host on which to open port. */ - const char *myaddr, /* Optional client-side address */ - int myport, /* Optional client-side port */ - int async) /* If nonzero, connect client socket - * asynchronously. */ + SocketInfo *infoPtr) { u_long flag = 1; /* Indicates nonblocking mode. */ - int asyncConnect = 0; /* Will be 1 if async connect is in - * progress. */ - unsigned short chosenport = 0; - struct addrinfo *addrlist = NULL, *addrPtr; - /* Socket address to connect to. */ - struct addrinfo *myaddrlist = NULL, *myaddrPtr; - /* Socket address for our side. */ - const char *errorMsg = NULL; - SOCKET sock = INVALID_SOCKET; - SocketInfo *infoPtr = NULL; /* The returned value. */ - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + int async_callback = (infoPtr->addr != NULL); + int connected = 0; + int async = infoPtr->flags & SOCKET_ASYNC_CONNECT; - if (!SocketsEnabled()) { - return NULL; + DEBUG(async_callback ? "subsequent" : "first"); + DEBUG(async ? "async" : "sync"); + if (async_callback) { + goto reenter; } + + for (infoPtr->addr = infoPtr->addrlist; infoPtr->addr != NULL; + infoPtr->addr = infoPtr->addr->ai_next) { + + for (infoPtr->myaddr = infoPtr->myaddrlist; infoPtr->myaddr != NULL; + infoPtr->myaddr = infoPtr->myaddr->ai_next) { - /* - * Construct the addresses for each end of the socket. - */ - - if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, - &errorMsg)) { - goto error; - } - if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, - &errorMsg)) { - goto error; - } + DEBUG("inner loop"); - for (addrPtr = addrlist; addrPtr != NULL; - addrPtr = addrPtr->ai_next) { - for (myaddrPtr = myaddrlist; myaddrPtr != NULL; - myaddrPtr = myaddrPtr->ai_next) { /* * No need to try combinations of local and remote addresses * of different families. */ - if (myaddrPtr->ai_family != addrPtr->ai_family) { + if (infoPtr->myaddr->ai_family != infoPtr->addr->ai_family) { + DEBUG("family mismatch"); continue; } - sock = socket(myaddrPtr->ai_family, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { + DEBUG(infoPtr->myaddr->ai_family == AF_INET ? "IPv4" : "IPv6"); + printaddrinfo(infoPtr->myaddr, "~~ from"); + printaddrinfo(infoPtr->addr, "~~ to"); + + /* + * Close the socket if it is still open from the last unsuccessful + * iteration. + */ + + if (infoPtr->sockets->fd != INVALID_SOCKET) { + DEBUG("closesocket"); + closesocket(infoPtr->sockets->fd); + } + + infoPtr->sockets->fd = socket(infoPtr->myaddr->ai_family, SOCK_STREAM, 0); + if (infoPtr->sockets->fd == INVALID_SOCKET) { + DEBUG("socket() failed"); TclWinConvertError((DWORD) WSAGetLastError()); continue; } - + /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. */ - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + SetHandleInformation((HANDLE) infoPtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); /* * Set kernel space buffering */ - TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); + TclSockMinimumBuffers((void *) infoPtr->sockets->fd, TCP_BUFFER_SIZE); /* * Try to bind to a local port. */ - if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen) - == SOCKET_ERROR) { + if (bind(infoPtr->sockets->fd, infoPtr->myaddr->ai_addr, + infoPtr->myaddr->ai_addrlen) == SOCKET_ERROR) { + DEBUG("bind() failed"); TclWinConvertError((DWORD) WSAGetLastError()); - goto looperror; + continue; } /* * Set the socket into nonblocking mode if the connect should * be done in the background. */ - if (async && ioctlsocket(sock, (long) FIONBIO, &flag) + if (async && ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag) == SOCKET_ERROR) { + DEBUG("FIONBIO"); TclWinConvertError((DWORD) WSAGetLastError()); - goto looperror; + continue; } /* * Attempt to connect to the remote socket. */ - if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { + if (connect(infoPtr->sockets->fd, infoPtr->addr->ai_addr, + infoPtr->addr->ai_addrlen) == SOCKET_ERROR) { DWORD error = (DWORD) WSAGetLastError(); - if (error != WSAEWOULDBLOCK) { + + DEBUG("connect()"); + // fprintf(stderr,"error = %lu\n", error); + if (error == WSAEWOULDBLOCK) { + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + DEBUG("WSAEWOULDBLOCK"); + infoPtr->flags |= SOCKET_ASYNC_CONNECT; + infoPtr->selectEvents |= FD_CONNECT; + + ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); + return TCL_OK; + } else { + DEBUG("ELSE"); TclWinConvertError(error); - goto looperror; + continue; } - + reenter: + DEBUG("reenter"); + fprintf(stderr, "lastError: %d\n", infoPtr->lastError); /* * The connection is progressing in the background. */ - - asyncConnect = 1; - } - goto connected; - - looperror: - if (sock != INVALID_SOCKET) { - closesocket(sock); - sock = INVALID_SOCKET; + // infoPtr->selectEvents &= ~(FD_CONNECT); + } else { + connected = 1; + goto connected; } } } goto error; +connected: + DEBUG("connected"); + /* + * Set up the select mask for read/write events. If the connect + * attempt has not completed, include connect events. + */ + + infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - connected: - /* - * Add this socket to the global list of sockets. - */ - - infoPtr = NewSocketInfo(sock); - - /* - * Set up the select mask for read/write events. If the connect - * attempt has not completed, include connect events. - */ - - infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - if (asyncConnect) { - infoPtr->flags |= SOCKET_ASYNC_CONNECT; - infoPtr->selectEvents |= FD_CONNECT; - } - - error: - if (addrlist != NULL) { - freeaddrinfo(addrlist); - } - if (myaddrlist != NULL) { - freeaddrinfo(myaddrlist); - } - +error: /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ - if (infoPtr != NULL) { - ioctlsocket(sock, (long) FIONBIO, &flag); + if (connected) { + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); - - return infoPtr; + return TCL_OK; } if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", - (errorMsg ? errorMsg : Tcl_PosixError(interp)))); + "couldn't open socket: %s", Tcl_PosixError(interp))); } - if (sock != INVALID_SOCKET) { - closesocket(sock); - } - return NULL; + return TCL_ERROR; } /* @@ -1390,18 +1406,57 @@ Tcl_OpenTcpClient( * asynchronously. */ { SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + const char *errorMsg = NULL; + struct addrinfo *addrlist = NULL; + struct addrinfo *myaddrlist = NULL; + char channelName[SOCK_CHAN_LENGTH]; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Create a new client socket and wrap it in a channel. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + return NULL; + } + + /* + * Do the name lookups for the local and remote addresses. */ - infoPtr = CreateClientSocket(interp, port, host, myaddr, myport, async); - if (infoPtr == NULL) { + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) + || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", errorMsg)); + } + return NULL; + } + printaddrinfolist(myaddrlist, "local"); + printaddrinfolist(addrlist, "remote"); + + infoPtr = NewSocketInfo(INVALID_SOCKET); + infoPtr->addrlist = addrlist; + infoPtr->myaddrlist = myaddrlist; + if (async) { + infoPtr->flags |= SOCKET_ASYNC_CONNECT; + } + + /* + * Create a new client socket and wrap it in a channel. + */ + + if (CreateClientSocket(interp, infoPtr) != TCL_OK) { + TcpCloseProc(infoPtr, NULL); return NULL; } @@ -1444,7 +1499,7 @@ Tcl_MakeTcpClientChannel( ClientData sock) /* The socket to wrap up into a channel. */ { SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + char channelName[SOCK_CHAN_LENGTH]; ThreadSpecificData *tsdPtr; if (TclpHasSockets(NULL) != TCL_OK) { @@ -1506,7 +1561,7 @@ Tcl_OpenTcpServer( unsigned short chosenport = 0; struct addrinfo *addrPtr; /* Socket address to listen on. */ SocketInfo *infoPtr = NULL; /* The returned value. */ - void *addrlist = NULL; + struct addrinfo *addrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; u_long flag = 1; /* Indicates nonblocking mode. */ const char *errorMsg = NULL; @@ -1694,7 +1749,7 @@ TcpAccept( SocketInfo *newInfoPtr; SocketInfo *infoPtr = fds->infoPtr; int len = sizeof(addr); - char channelName[16 + TCL_INTEGER_SPACE]; + char channelName[SOCK_CHAN_LENGTH]; char host[NI_MAXHOST], port[NI_MAXSERV]; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); @@ -2512,10 +2567,12 @@ SocketProc( switch (message) { default: + DEBUG("default"); return DefWindowProc(hwnd, message, wParam, lParam); break; case WM_CREATE: + DEBUG("CREATE"); /* * Store the initial tsdPtr, it's from a different thread, so it's not * directly accessible, but needed. @@ -2531,10 +2588,12 @@ SocketProc( break; case WM_DESTROY: + DEBUG("DESTROY"); PostQuitMessage(0); break; case SOCKET_MESSAGE: + DEBUG("SOCKET_MESSAGE"); event = WSAGETSELECTEVENT(lParam); error = WSAGETSELECTERROR(lParam); socket = (SOCKET) wParam; @@ -2549,6 +2608,11 @@ SocketProc( infoPtr = infoPtr->nextPtr) { for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { if (fds->fd == socket) { + if (event & FD_READ) + DEBUG("|->FD_READ"); + if (event & FD_WRITE) + DEBUG("|->FD_WRITE"); + /* * Update the socket state. * @@ -2558,19 +2622,22 @@ SocketProc( */ if (event & FD_CLOSE) { + DEBUG("FD_CLOSE"); infoPtr->acceptEventCount = 0; infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; + DEBUG("FD_ACCEPT"); + infoPtr->acceptEventCount++; } if (event & FD_CONNECT) { + DEBUG("FD_CONNECT"); /* * The socket is now connected, clear the async connect * flag. */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + //infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); /* * Remember any error that occurred so we can report @@ -2582,15 +2649,17 @@ SocketProc( infoPtr->lastError = Tcl_GetErrno(); } } - +#if 0 if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + DEBUG("SOCKET_ASYNC_CONNECT"); + // infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); if (error != ERROR_SUCCESS) { TclWinConvertError((DWORD) error); infoPtr->lastError = Tcl_GetErrno(); } infoPtr->readyEvents |= FD_WRITE; } +#endif infoPtr->readyEvents |= event; /* @@ -2607,10 +2676,12 @@ SocketProc( break; case SOCKET_SELECT: + DEBUG("SOCKET_SELECT"); infoPtr = (SocketInfo *) lParam; for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { infoPtr = (SocketInfo *) lParam; if (wParam == SELECT) { + DEBUG("SELECT"); WSAAsyncSelect(fds->fd, hwnd, SOCKET_MESSAGE, infoPtr->selectEvents); } else { @@ -2618,12 +2689,14 @@ SocketProc( * Clear the selection mask */ + DEBUG("!SELECT"); WSAAsyncSelect(fds->fd, hwnd, 0, 0); } } break; case SOCKET_TERMINATE: + DEBUG("SOCKET_TERMINATE"); DestroyWindow(hwnd); break; } -- cgit v0.12 From 4dd180a450af9fce8d8128ebc37dfe3aa3932c6e Mon Sep 17 00:00:00 2001 From: max Date: Fri, 28 Feb 2014 11:05:35 +0000 Subject: Make printf debugging switchable, because it affects 'make test' --- win/tclWinSock.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 6afa094..905297e 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,7 +47,8 @@ #include "tclWinInt.h" -#if 1 +//#define DEBUGGING +#ifdef DEBUGGING #define DEBUG(x) fprintf(stderr, ">>> %s(%d): %s<<<\n", __FUNCTION__, __LINE__, x) #else #define DEBUG(x) @@ -284,7 +285,9 @@ void printaddrinfo(struct addrinfo *ai, char *prefix) host, sizeof(host), port, sizeof(port), NI_NUMERICHOST|NI_NUMERICSERV); +#ifdef DEBUGGING fprintf(stderr,"%s: [%s]:%s\n", prefix, host, port); +#endif } void printaddrinfolist(struct addrinfo *addrlist, char *prefix) { @@ -1250,7 +1253,9 @@ CreateClientSocket( DWORD error = (DWORD) WSAGetLastError(); DEBUG("connect()"); +#ifdef DEBUGGING // fprintf(stderr,"error = %lu\n", error); +#endif if (error == WSAEWOULDBLOCK) { ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); DEBUG("WSAEWOULDBLOCK"); @@ -1268,7 +1273,9 @@ CreateClientSocket( } reenter: DEBUG("reenter"); +#ifdef DEBUGGING fprintf(stderr, "lastError: %d\n", infoPtr->lastError); +#endif /* * The connection is progressing in the background. */ -- cgit v0.12 From 607601abc11ec2e965fedc5d3cb1e6d83c3a4a10 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Feb 2014 18:25:20 +0000 Subject: More ReadChars rewriting. Test suite now passes. Note that this reform simplifies ReadChars a fair bit (at least in my eyes). Also it does away with the use of an INPUT_NEED_NL flag, using the same strategy for partial \r\n sequences as is used for incomplete multibyte chars. --- generic/tclIO.c | 194 ++++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 173 insertions(+), 21 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 20428b5..ec71991 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5403,7 +5403,6 @@ ReadChars( * srcLen bytes, write no more than dstLimit bytes. */ -//fprintf(stdout, "Start %d %d\n", dstLimit, srcLen); fflush(stdout); int code = Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, statePtr->inputEncodingFlags & (bufPtr->nextPtr ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, @@ -5416,9 +5415,6 @@ ReadChars( * Capture the number of bytes actually consumed in dstRead. */ -//fprintf(stdout, "Key NS=%d MB=%d S=%d\n", TCL_CONVERT_NOSPACE, -//TCL_CONVERT_MULTIBYTE, TCL_CONVERT_SYNTAX); fflush(stdout); -//fprintf(stdout, "Decoded %d %d\n", dstDecoded,code); fflush(stdout); dstWrote = dstRead = dstDecoded; TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); @@ -5426,20 +5422,144 @@ ReadChars( /* * The encoding transformation produced bytes that the - * translation transformation did not consume. Start over - * and impose new limits so that doesn't happen again. + * translation transformation did not consume. Why did + * this happen? */ -//fprintf(stdout, "X! %d %d\n", dstRead, dstDecoded); fflush(stdout); - dstLimit = dstRead + TCL_UTF_MAX; - statePtr->flags = savedFlags; - statePtr->inputEncodingFlags = savedIEFlags; - statePtr->inputEncodingState = savedState; - continue; - } + if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) { + /* + * 1) There's an eof char set on the channel, and + * we saw it and stopped translating at that point. + * + * NOTE the bizarre spec of TranslateInputEOL in this case. + * Clearly the eof char had to be read in order to account + * for the stopping, but the value of dstRead does not + * include it. + * + * Also rather bizarre, our caller can only notice an + * EOF condition if we return the value -1 as the number + * of chars read. This forces us to perform a 2-call + * dance where the first call can read all the chars + * up to the eof char, and the second call is solely + * for consuming the encoded eof char then pointed at + * by src so that we can return that magic -1 value. + * This seems really wasteful, especially since + * the first decoding pass of each call is likely to + * decode many bytes beyond that eof char that's all we + * care about. + */ + + if (dstRead == 0) { + /* + * Curious choice in the eof char handling. We leave + * the eof char in the buffer. So, no need to compute + * a proper srcRead value. At this point, there + * are no chars before the eof char in the buffer. + */ + return -1; + } + + { + /* + * There are chars leading the buffer before the eof + * char. Adjust the dstLimit so we go back and read + * only those and do not encounter the eof char this + * time. + */ + + dstLimit = dstRead + TCL_UTF_MAX; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } + } + + /* + * 2) The other way to read fewer bytes than are decoded + * is when the final byte is \r and we're in a CRLF + * translation mode so we cannot decide whether to + * record \r or \n yet. + */ + + assert(dstRead + 1 == dstDecoded); + assert(dst[dstRead] == '\r'); + assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); + + if (dstWrote > 0) { + /* + * There are chars we can read before we hit the bare cr. + * Go back with a smaller dstLimit so we get them in the + * next pass, compute a matching srcRead, and don't end + * up back here in this call. + */ + + dstLimit = dstRead + TCL_UTF_MAX; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } + + assert(dstWrote == 0); + assert(dstRead == 0); + assert(dstDecoded == 1); + + /* + * We decoded only the bare cr, and we cannot read a + * translated char from that alone. We have to know what's + * next. So why do we only have the one decoded char? + */ + + if (code != TCL_OK) { + char buffer[TCL_UTF_MAX + 2]; + int read, decoded, count; + + /* + * Didn't get everything the buffer could offer + */ + + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + + Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + statePtr->inputEncodingFlags & (bufPtr->nextPtr + ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, + buffer, TCL_UTF_MAX + 2, &read, &decoded, &count); + + if (count == 2) { + if (buffer[1] == '\n') { + /* \r\n translate to \n */ + dst[0] = '\n'; + bufPtr->nextRemoved += read; + } else { + dst[0] = '\r'; + bufPtr->nextRemoved += srcRead; + } + + dst[1] = '\0'; + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; + + *offsetPtr += 1; + return 1; + } -//fprintf(stdout, "check %d %d %d\n", dstWrote, dstRead, dstDecoded); -//fflush(stdout); + } else if (statePtr->flags & CHANNEL_EOF) { + + /* + * The bare \r is the only char and we will never read + * a subsequent char to make the determination. + */ + + dst[0] = '\r'; + bufPtr->nextRemoved = bufPtr->nextAdded; + *offsetPtr += 1; + return 1; + } + + /* FALL THROUGH - get more data (dstWrote == 0) */ + } /* * The translation transformation can only reduce the number @@ -5455,7 +5575,6 @@ ReadChars( * We read more chars than allowed. Reset limits to * prevent that and try again. */ -//fprintf(stdout, "Y!\n"); fflush(stdout); dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - dst; statePtr->flags = savedFlags; @@ -5466,12 +5585,46 @@ ReadChars( if (dstWrote == 0) { -//fprintf(stdout, "Z!\n"); fflush(stdout); - /* - * Could not read anything. Ask caller to get more data. + /* + * We were not able to read any chars. Maybe there were + * not enough src bytes to decode into a char. Maybe + * a lone \r could not be translated (crlf mode). Need + * to combine any unused src bytes we have in the first + * buffer with subsequent bytes to try again. */ - return -1; + ChannelBuffer *nextPtr = bufPtr->nextPtr; + + if (nextPtr == NULL) { + if (srcLen > 0) { + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + } + return -1; + } + + /* + * Space is made at the beginning of the buffer to copy the + * previous unused bytes there. Check first if the buffer we + * are using actually has enough space at its beginning for + * the data we are copying. Because if not we will write over + * the buffer management information, especially the 'nextPtr'. + * + * Note that the BUFFER_PADDING (See AllocChannelBuffer) is + * used to prevent exactly this situation. I.e. it should never + * happen. Therefore it is ok to panic should it happen despite + * the precautions. + */ + + if (nextPtr->nextRemoved - srcLen < 0) { + Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); + } + + nextPtr->nextRemoved -= srcLen; + memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); + RecycleBuffer(statePtr, bufPtr, 0); + statePtr->inQueueHead = nextPtr; + return ReadChars(statePtr, objPtr, charsToRead, + offsetPtr, factorPtr); } statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; @@ -5481,7 +5634,6 @@ ReadChars( *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; } *offsetPtr += dstWrote; -//fprintf(stdout, "OK: %d\n", numChars); fflush(stdout); return numChars; } -- cgit v0.12 From 7b66d219bab6b6710a22b4b18ca563239ffdc050 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Feb 2014 18:28:16 +0000 Subject: tidy up. --- generic/tclIO.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index ec71991..a0a349f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5928,9 +5928,8 @@ TranslateInputEOL( if (*src == '\r') { src++; if (src >= srcMax) { -// SetFlag(statePtr, INPUT_NEED_NL); -//fprintf(stdout, "BREAK!\n"); fflush(stdout); -src--; break; + src--; + break; } else if (*src == '\n') { *dst++ = *src++; } else { @@ -5942,7 +5941,6 @@ src--; break; } srcLen = src - srcStart; dstLen = dst - dstStart; -//fprintf(stdout, "eh? %d %d\n", srcLen, dstLen); fflush(stdout); break; } case TCL_TRANSLATE_AUTO: { -- cgit v0.12 From bb1b4fcb06f80fddfd136a9bd14bf64808f45971 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Feb 2014 18:36:00 +0000 Subject: another coverage test. --- tests/io.test | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/io.test b/tests/io.test index 0941e02..c325809 100644 --- a/tests/io.test +++ b/tests/io.test @@ -4772,6 +4772,21 @@ test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} { close $f list $c $l $e [scan [string index $in end] %c] } {17 8 1 13} +test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format \n%cqrsuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} {9 1 1 13} # Test Tcl_InputBlocked -- cgit v0.12 From 6ac36ed52bd548be97ae7baa3022e822f6a1bdce Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 1 Mar 2014 03:01:41 +0000 Subject: Fixups make the test suite almost pass (except *io-39.17) --- generic/tclIO.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7b798af..139a05e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5289,7 +5289,7 @@ ReadChars( dst = TclGetString(objPtr) + numBytes; } -#if 0 +#if 1 /* * This routine is burdened with satisfying several constraints. @@ -5373,6 +5373,7 @@ ReadChars( * a proper srcRead value. At this point, there * are no chars before the eof char in the buffer. */ + Tcl_SetObjLength(objPtr, numBytes); return -1; } @@ -5459,7 +5460,6 @@ ReadChars( statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; Tcl_SetObjLength(objPtr, numBytes + 1); - // *offsetPtr += 1; return 1; } @@ -5473,7 +5473,6 @@ ReadChars( dst[0] = '\r'; bufPtr->nextRemoved = bufPtr->nextAdded; Tcl_SetObjLength(objPtr, numBytes + 1); - //*offsetPtr += 1; return 1; } @@ -5518,6 +5517,7 @@ ReadChars( if (srcLen > 0) { SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); } + Tcl_SetObjLength(objPtr, numBytes); return -1; } @@ -5542,6 +5542,7 @@ ReadChars( memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; + Tcl_SetObjLength(objPtr, numBytes); return ReadChars(statePtr, objPtr, charsToRead, factorPtr); } @@ -5552,7 +5553,6 @@ ReadChars( *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; } Tcl_SetObjLength(objPtr, numBytes + dstWrote); - //*offsetPtr += dstWrote; return numChars; } @@ -5850,9 +5850,8 @@ TranslateInputEOL( if (*src == '\r') { src++; if (src >= srcMax) { -SetFlag(statePtr, INPUT_NEED_NL); -// src--; -// break; + src--; + break; } else if (*src == '\n') { *dst++ = *src++; } else { -- cgit v0.12 From d2d1d997780ab3a1651986fc9820fd4a75ea8e56 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 3 Mar 2014 15:57:56 +0000 Subject: WIP: async open event now passes to SocketEventProc() and connects but does not finalyze that (I guess). --- win/tclWinSock.c | 38 +++++++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 905297e..ccae931 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -681,7 +681,10 @@ SocketCheckProc( for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if ((infoPtr->readyEvents & infoPtr->watchEvents) - && !(infoPtr->flags & SOCKET_PENDING)) { + && !(infoPtr->flags & SOCKET_PENDING) + || ( infoPtr->flags & SOCKET_ASYNC_CONNECT ) + && ( infoPtr->readyEvents & FD_CONNECT ) + ) { infoPtr->flags |= SOCKET_PENDING; evPtr = ckalloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; @@ -875,7 +878,7 @@ SocketEventProc( if (events & FD_WRITE) { mask |= TCL_WRITABLE; } - if (events & FD_CONNECT) { + if (infoPtr->readyEvents & FD_CONNECT) { DEBUG("Calling CreateClientSocket..."); CreateClientSocket(NULL, infoPtr); } @@ -1236,12 +1239,24 @@ CreateClientSocket( /* * Set the socket into nonblocking mode if the connect should * be done in the background. + * Activate notification for a connect. */ - if (async && ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag) - == SOCKET_ERROR) { - DEBUG("FIONBIO"); - TclWinConvertError((DWORD) WSAGetLastError()); - continue; + if (async) { + if (ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag) + == SOCKET_ERROR) { + DEBUG("FIONBIO"); + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + { + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + infoPtr->flags |= SOCKET_ASYNC_CONNECT; + infoPtr->selectEvents |= FD_CONNECT; + + ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); + } } /* @@ -1256,15 +1271,8 @@ CreateClientSocket( #ifdef DEBUGGING // fprintf(stderr,"error = %lu\n", error); #endif - if (error == WSAEWOULDBLOCK) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + if (async && error == WSAEWOULDBLOCK) { DEBUG("WSAEWOULDBLOCK"); - infoPtr->flags |= SOCKET_ASYNC_CONNECT; - infoPtr->selectEvents |= FD_CONNECT; - - ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); return TCL_OK; } else { DEBUG("ELSE"); -- cgit v0.12 From c5233a1a3eb0706c49c436bda255bbcdac5bf009 Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 4 Mar 2014 07:54:18 +0000 Subject: Reverted move of WSAAsyncSelect before connect -> FD_Connect message does also fire if it exists on call. --- win/tclWinSock.c | 31 +++++++++++++------------------ 1 file changed, 13 insertions(+), 18 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index ccae931..dd893ac 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1239,24 +1239,12 @@ CreateClientSocket( /* * Set the socket into nonblocking mode if the connect should * be done in the background. - * Activate notification for a connect. */ - if (async) { - if (ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag) - == SOCKET_ERROR) { - DEBUG("FIONBIO"); - TclWinConvertError((DWORD) WSAGetLastError()); - continue; - } - { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - infoPtr->flags |= SOCKET_ASYNC_CONNECT; - infoPtr->selectEvents |= FD_CONNECT; - - ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); - } + if (async && ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag) + == SOCKET_ERROR) { + DEBUG("FIONBIO"); + TclWinConvertError((DWORD) WSAGetLastError()); + continue; } /* @@ -1271,8 +1259,15 @@ CreateClientSocket( #ifdef DEBUGGING // fprintf(stderr,"error = %lu\n", error); #endif - if (async && error == WSAEWOULDBLOCK) { + if (error == WSAEWOULDBLOCK) { + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); DEBUG("WSAEWOULDBLOCK"); + infoPtr->flags |= SOCKET_ASYNC_CONNECT; + infoPtr->selectEvents |= FD_CONNECT; + + ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); return TCL_OK; } else { DEBUG("ELSE"); -- cgit v0.12 From 312c80abf4c34b3313aae1c532e5621066e8bd1c Mon Sep 17 00:00:00 2001 From: max Date: Tue, 4 Mar 2014 18:54:48 +0000 Subject: * Use watchEvents only for read/write/close events of [chan event], don't mix with internal use of accept and connect events. * WIP: Refactor the tail of CreateClientSocket() to get notifications for completed async connects right. --- win/tclWinSock.c | 145 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 82 insertions(+), 63 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index dd893ac..6620def 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,7 +47,7 @@ #include "tclWinInt.h" -//#define DEBUGGING +#define DEBUGGING #ifdef DEBUGGING #define DEBUG(x) fprintf(stderr, ">>> %s(%d): %s<<<\n", __FUNCTION__, __LINE__, x) #else @@ -629,11 +629,13 @@ SocketSetupProc( /* * Check to see if there is a ready socket. If so, poll. */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->readyEvents & infoPtr->watchEvents) { + if (infoPtr->readyEvents & + (infoPtr->watchEvents | FD_CONNECT | FD_ACCEPT) + ) { + DEBUG("Tcl_SetMaxBlockTime"); Tcl_SetMaxBlockTime(&blockTime); break; } @@ -667,6 +669,7 @@ SocketCheckProc( SocketEvent *evPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + DEBUG("A"); if (!(flags & TCL_FILE_EVENTS)) { return; } @@ -680,10 +683,9 @@ SocketCheckProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if ((infoPtr->readyEvents & infoPtr->watchEvents) - && !(infoPtr->flags & SOCKET_PENDING) - || ( infoPtr->flags & SOCKET_ASYNC_CONNECT ) - && ( infoPtr->readyEvents & FD_CONNECT ) + if ((infoPtr->readyEvents & + (infoPtr->watchEvents | FD_CONNECT | FD_ACCEPT)) + && !(infoPtr->flags & SOCKET_PENDING) ) { infoPtr->flags |= SOCKET_PENDING; evPtr = ckalloc(sizeof(SocketEvent)); @@ -731,8 +733,7 @@ SocketEventProc( address addr; int len; - DEBUG("xxx"); - + DEBUG(""); if (!(flags & TCL_FILE_EVENTS)) { return 0; } @@ -760,10 +761,17 @@ SocketEventProc( infoPtr->flags &= ~SOCKET_PENDING; + if (infoPtr->readyEvents & FD_CONNECT) { + DEBUG("FD_CONNECT"); + SetEvent(tsdPtr->socketListLock); + CreateClientSocket(NULL, infoPtr); + infoPtr->readyEvents &= ~(FD_CONNECT); + return 1; + } + /* * Handle connection requests directly. */ - if (infoPtr->readyEvents & FD_ACCEPT) { for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { @@ -845,6 +853,7 @@ SocketEventProc( Tcl_Time blockTime = { 0, 0 }; + DEBUG("FD_CLOSE"); Tcl_SetMaxBlockTime(&blockTime); mask |= TCL_READABLE|TCL_WRITABLE; } else if (events & FD_READ) { @@ -858,6 +867,7 @@ SocketEventProc( * readable, notify the channel driver, otherwise reset the async * select handler and keep waiting. */ + DEBUG("FD_READ"); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); @@ -876,12 +886,9 @@ SocketEventProc( } } if (events & FD_WRITE) { + DEBUG("FD_WRITE"); mask |= TCL_WRITABLE; } - if (infoPtr->readyEvents & FD_CONNECT) { - DEBUG("Calling CreateClientSocket..."); - CreateClientSocket(NULL, infoPtr); - } if (mask) { DEBUG("Calling Tcl_NotifyChannel..."); Tcl_NotifyChannel(infoPtr->channel, mask); @@ -1164,14 +1171,17 @@ CreateClientSocket( SocketInfo *infoPtr) { u_long flag = 1; /* Indicates nonblocking mode. */ - int async_callback = (infoPtr->addr != NULL); - int connected = 0; int async = infoPtr->flags & SOCKET_ASYNC_CONNECT; - - DEBUG(async_callback ? "subsequent" : "first"); + int async_callback = infoPtr->sockets->fd != INVALID_SOCKET; + ThreadSpecificData *tsdPtr; + DEBUG(async ? "async" : "sync"); + if (async_callback) { + DEBUG("subsequent call"); goto reenter; + } else { + DEBUG("first call"); } for (infoPtr->addr = infoPtr->addrlist; infoPtr->addr != NULL; @@ -1199,13 +1209,12 @@ CreateClientSocket( /* * Close the socket if it is still open from the last unsuccessful * iteration. - */ - + */ if (infoPtr->sockets->fd != INVALID_SOCKET) { DEBUG("closesocket"); closesocket(infoPtr->sockets->fd); } - + infoPtr->sockets->fd = socket(infoPtr->myaddr->ai_family, SOCK_STREAM, 0); if (infoPtr->sockets->fd == INVALID_SOCKET) { DEBUG("socket() failed"); @@ -1254,7 +1263,7 @@ CreateClientSocket( if (connect(infoPtr->sockets->fd, infoPtr->addr->ai_addr, infoPtr->addr->ai_addrlen) == SOCKET_ERROR) { DWORD error = (DWORD) WSAGetLastError(); - + TclWinConvertError(error); DEBUG("connect()"); #ifdef DEBUGGING // fprintf(stderr,"error = %lu\n", error); @@ -1262,64 +1271,59 @@ CreateClientSocket( if (error == WSAEWOULDBLOCK) { ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); DEBUG("WSAEWOULDBLOCK"); - infoPtr->flags |= SOCKET_ASYNC_CONNECT; infoPtr->selectEvents |= FD_CONNECT; ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); return TCL_OK; - } else { - DEBUG("ELSE"); - TclWinConvertError(error); - continue; + reenter: + Tcl_SetErrno(infoPtr->lastError); + DEBUG("reenter"); + infoPtr->selectEvents &= ~(FD_CONNECT); } - reenter: - DEBUG("reenter"); + } else { + DWORD error = (DWORD) WSAGetLastError(); + TclWinConvertError(error); + } #ifdef DEBUGGING - fprintf(stderr, "lastError: %d\n", infoPtr->lastError); + fprintf(stderr, "lastError: %d\n", Tcl_GetErrno()); #endif - /* - * The connection is progressing in the background. - */ - // infoPtr->selectEvents &= ~(FD_CONNECT); - } else { - connected = 1; - goto connected; + if (Tcl_GetErrno() == 0) { + goto out; } } } - goto error; -connected: - DEBUG("connected"); + +out: + DEBUG("connected or finally failed"); + if (Tcl_GetErrno() != 0 && interp != NULL) { + DEBUG("ERRNO"); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } /* - * Set up the select mask for read/write events. If the connect - * attempt has not completed, include connect events. + * Set up the select mask for read/write events. */ infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - -error: + /* * Register for interest in events in the select mask. Note that this * automatically places the socket into non-blocking mode. */ - - if (connected) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + + tsdPtr = TclThreadDataKeyGet(&dataKey); + ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); - return TCL_OK; - } - - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", Tcl_PosixError(interp))); + if (async_callback) { + Tcl_NotifyChannel(infoPtr->channel, TCL_WRITABLE); } - - return TCL_ERROR; + return TCL_OK; } /* @@ -1348,7 +1352,6 @@ WaitForSocketEvent( int result = 1; int oldMode; ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - /* * Be sure to disable event servicing so we are truly modal. */ @@ -1464,7 +1467,7 @@ Tcl_OpenTcpClient( /* * Create a new client socket and wrap it in a channel. */ - + DEBUG(""); if (CreateClientSocket(interp, infoPtr) != TCL_OK) { TcpCloseProc(infoPtr, NULL); return NULL; @@ -1702,7 +1705,6 @@ error: */ infoPtr->selectEvents = FD_ACCEPT; - infoPtr->watchEvents |= FD_ACCEPT; /* * Register for interest in events in the select mask. Note that this @@ -2289,6 +2291,9 @@ TcpGetOptionProc( } for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { sock = fds->fd; +#ifdef DEBUGGING + fprintf(stderr, "sock == %d\n", sock); +#endif size = sizeof(sockname); if (getsockname(sock, &(sockname.sa), &size) >= 0) { int flags = reverseDNS; @@ -2419,6 +2424,9 @@ TcpWatchProc( { SocketInfo *infoPtr = instanceData; + DEBUG((mask & TCL_READABLE) ? "+r":"-r"); + DEBUG((mask & TCL_WRITABLE) ? "+w":"-w"); + /* * Update the watch events mask. Only if the socket is not a server * socket. [Bug 557878] @@ -2427,10 +2435,10 @@ TcpWatchProc( if (!infoPtr->acceptProc) { infoPtr->watchEvents = 0; if (mask & TCL_READABLE) { - infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); + infoPtr->watchEvents |= (FD_READ|FD_CLOSE); } if (mask & TCL_WRITABLE) { - infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT); + infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE); } /* @@ -2613,10 +2621,16 @@ SocketProc( * eventState flag. */ + DEBUG("FOO"); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + DEBUG("BAR"); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { +#ifdef DEBUGGING + fprintf(stderr,"socket = %d, fd=%d, event = %d, error = %d\n", + socket, fds->fd, event, error); +#endif if (fds->fd == socket) { if (event & FD_READ) DEBUG("|->FD_READ"); @@ -2692,6 +2706,11 @@ SocketProc( infoPtr = (SocketInfo *) lParam; if (wParam == SELECT) { DEBUG("SELECT"); + if (infoPtr->selectEvents & FD_READ) DEBUG(" READ"); + if (infoPtr->selectEvents & FD_WRITE) DEBUG(" WRITE"); + if (infoPtr->selectEvents & FD_CLOSE) DEBUG(" CLOSE"); + if (infoPtr->selectEvents & FD_CONNECT) DEBUG(" CONNECT"); + if (infoPtr->selectEvents & FD_ACCEPT) DEBUG(" ACCEPT"); WSAAsyncSelect(fds->fd, hwnd, SOCKET_MESSAGE, infoPtr->selectEvents); } else { -- cgit v0.12 From 91e8a8f60c91ad11df3a1c00d36184b9bc0c9947 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 5 Mar 2014 10:20:09 +0000 Subject: Next async connect try works. Reset error and move notifier before connect. --- win/tclWinSock.c | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 6620def..2da50f5 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1214,6 +1214,11 @@ CreateClientSocket( DEBUG("closesocket"); closesocket(infoPtr->sockets->fd); } + + /* + * Reset last error from last try + */ + infoPtr->lastError = 0; infoPtr->sockets->fd = socket(infoPtr->myaddr->ai_family, SOCK_STREAM, 0); if (infoPtr->sockets->fd == INVALID_SOCKET) { @@ -1249,11 +1254,13 @@ CreateClientSocket( * Set the socket into nonblocking mode if the connect should * be done in the background. */ - if (async && ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag) - == SOCKET_ERROR) { - DEBUG("FIONBIO"); - TclWinConvertError((DWORD) WSAGetLastError()); - continue; + if (async) { + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + infoPtr->selectEvents |= FD_CONNECT; + + ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); } /* @@ -1269,13 +1276,7 @@ CreateClientSocket( // fprintf(stderr,"error = %lu\n", error); #endif if (error == WSAEWOULDBLOCK) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); DEBUG("WSAEWOULDBLOCK"); - infoPtr->selectEvents |= FD_CONNECT; - - ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); return TCL_OK; reenter: Tcl_SetErrno(infoPtr->lastError); -- cgit v0.12 From 60f72ecdaf9f585eb8210a95d43969c20ede5329 Mon Sep 17 00:00:00 2001 From: max Date: Wed, 5 Mar 2014 13:09:22 +0000 Subject: Print out the value of infoPtr in DEBUG, so that coexisting sockets can be distinguished in the output. --- win/tclWinSock.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 2da50f5..64b2fc9 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -49,7 +49,8 @@ #define DEBUGGING #ifdef DEBUGGING -#define DEBUG(x) fprintf(stderr, ">>> %s(%d): %s<<<\n", __FUNCTION__, __LINE__, x) +#define DEBUG(x) fprintf(stderr, ">>> %p %s(%d): %s<<<\n", \ + infoPtr, __FUNCTION__, __LINE__, x) #else #define DEBUG(x) #endif @@ -669,7 +670,6 @@ SocketCheckProc( SocketEvent *evPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - DEBUG("A"); if (!(flags & TCL_FILE_EVENTS)) { return; } @@ -683,10 +683,12 @@ SocketCheckProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + DEBUG("A"); if ((infoPtr->readyEvents & (infoPtr->watchEvents | FD_CONNECT | FD_ACCEPT)) && !(infoPtr->flags & SOCKET_PENDING) ) { + DEBUG("B"); infoPtr->flags |= SOCKET_PENDING; evPtr = ckalloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; @@ -1356,6 +1358,7 @@ WaitForSocketEvent( /* * Be sure to disable event servicing so we are truly modal. */ + DEBUG("============="); oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); @@ -2586,12 +2589,10 @@ SocketProc( switch (message) { default: - DEBUG("default"); return DefWindowProc(hwnd, message, wParam, lParam); break; case WM_CREATE: - DEBUG("CREATE"); /* * Store the initial tsdPtr, it's from a different thread, so it's not * directly accessible, but needed. @@ -2607,12 +2608,10 @@ SocketProc( break; case WM_DESTROY: - DEBUG("DESTROY"); PostQuitMessage(0); break; case SOCKET_MESSAGE: - DEBUG("SOCKET_MESSAGE"); event = WSAGETSELECTEVENT(lParam); error = WSAGETSELECTERROR(lParam); socket = (SOCKET) wParam; @@ -2668,7 +2667,6 @@ SocketProc( * Remember any error that occurred so we can report * connection failures. */ - if (error != ERROR_SUCCESS) { TclWinConvertError((DWORD) error); infoPtr->lastError = Tcl_GetErrno(); -- cgit v0.12 From bf23be680c6a9233bd70707a05513b31b047d158 Mon Sep 17 00:00:00 2001 From: max Date: Wed, 5 Mar 2014 13:12:13 +0000 Subject: avoid warnings about uninitialized infoPtr in DEBUG --- win/tclWinSock.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 64b2fc9..f06aad1 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -726,7 +726,7 @@ SocketEventProc( int flags) /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { - SocketInfo *infoPtr; + SocketInfo *infoPtr = NULL; /* DEBUG */ SocketEvent *eventPtr = (SocketEvent *) evPtr; int mask = 0, events; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -2578,7 +2578,7 @@ SocketProc( { int event, error; SOCKET socket; - SocketInfo *infoPtr; + SocketInfo *infoPtr = NULL; /* DEBUG */ TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 -- cgit v0.12 From 23801213cacd306b0bfddbdb51efcd15c88ed0f9 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 5 Mar 2014 14:23:38 +0000 Subject: Merge repair to correct failing tests. --- generic/tclIO.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 139a05e..6e3f0cf 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5320,7 +5320,7 @@ ReadChars( * srcLen bytes, write no more than dstLimit bytes. */ - int code = Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + int code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, statePtr->inputEncodingFlags & (bufPtr->nextPtr ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, dst, dstLimit, &srcRead, &dstDecoded, &numChars); @@ -5441,7 +5441,7 @@ ReadChars( statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, statePtr->inputEncodingFlags & (bufPtr->nextPtr ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, buffer, TCL_UTF_MAX + 2, &read, &decoded, &count); -- cgit v0.12 From f320ea76a37f8837d998a6400000d59b72d1e376 Mon Sep 17 00:00:00 2001 From: max Date: Wed, 5 Mar 2014 14:40:27 +0000 Subject: Refactor the error handling logic around connect() --- win/tclWinSock.c | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index f06aad1..d7b1b5b 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1176,6 +1176,7 @@ CreateClientSocket( int async = infoPtr->flags & SOCKET_ASYNC_CONNECT; int async_callback = infoPtr->sockets->fd != INVALID_SOCKET; ThreadSpecificData *tsdPtr; + DWORD error; DEBUG(async ? "async" : "sync"); @@ -1258,7 +1259,7 @@ CreateClientSocket( */ if (async) { ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - infoPtr->selectEvents |= FD_CONNECT; + infoPtr->selectEvents |= FD_CONNECT | FD_READ | FD_WRITE; ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, @@ -1268,26 +1269,22 @@ CreateClientSocket( /* * Attempt to connect to the remote socket. */ - - if (connect(infoPtr->sockets->fd, infoPtr->addr->ai_addr, - infoPtr->addr->ai_addrlen) == SOCKET_ERROR) { - DWORD error = (DWORD) WSAGetLastError(); - TclWinConvertError(error); - DEBUG("connect()"); + + DEBUG("connect()"); + connect(infoPtr->sockets->fd, infoPtr->addr->ai_addr, + infoPtr->addr->ai_addrlen); + error = WSAGetLastError(); + TclWinConvertError(error); #ifdef DEBUGGING - // fprintf(stderr,"error = %lu\n", error); + // fprintf(stderr,"error = %lu\n", error); #endif - if (error == WSAEWOULDBLOCK) { - DEBUG("WSAEWOULDBLOCK"); - return TCL_OK; - reenter: - Tcl_SetErrno(infoPtr->lastError); - DEBUG("reenter"); - infoPtr->selectEvents &= ~(FD_CONNECT); - } - } else { - DWORD error = (DWORD) WSAGetLastError(); - TclWinConvertError(error); + if (error == WSAEWOULDBLOCK) { + DEBUG("WSAEWOULDBLOCK"); + return TCL_OK; + reenter: + Tcl_SetErrno(infoPtr->lastError); + DEBUG("reenter"); + infoPtr->selectEvents &= ~(FD_CONNECT); } #ifdef DEBUGGING fprintf(stderr, "lastError: %d\n", Tcl_GetErrno()); @@ -1311,7 +1308,7 @@ out: /* * Set up the select mask for read/write events. */ - + DEBUG("selectEvents = FD_READ | FD_WRITE | FD_CLOSE"); infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; /* -- cgit v0.12 From 2910497fce32aefc629cfe738e7f2d5e0e941877 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 5 Mar 2014 15:15:43 +0000 Subject: "gets" blocked after async cannect: SOCKET_ASYNC_CONNECT was not cleared --- win/tclWinSock.c | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index d7b1b5b..162cbd4 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1259,7 +1259,7 @@ CreateClientSocket( */ if (async) { ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - infoPtr->selectEvents |= FD_CONNECT | FD_READ | FD_WRITE; + infoPtr->selectEvents |= FD_CONNECT; ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, @@ -2653,18 +2653,18 @@ SocketProc( if (event & FD_CONNECT) { DEBUG("FD_CONNECT"); - /* - * The socket is now connected, clear the async connect - * flag. - */ - //infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - - /* - * Remember any error that occurred so we can report - * connection failures. - */ - if (error != ERROR_SUCCESS) { + if (error == ERROR_SUCCESS) { + /* + * The socket is now connected, clear the async connect + * flag. + */ + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + } else { + /* + * Remember any error that occurred so we can report + * connection failures. + */ TclWinConvertError((DWORD) error); infoPtr->lastError = Tcl_GetErrno(); } -- cgit v0.12 From 9d31d410437d7e7fad1201c869e0a7c479daf693 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 5 Mar 2014 17:16:35 +0000 Subject: Adapt CopyAndTranslateBuffer() to changes in TranslateInputEOL(). Notably no longer using the INPUT_NEED_NL flag. --- generic/tclIO.c | 117 +++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 77 insertions(+), 40 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6e3f0cf..013f8dd 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5914,7 +5914,7 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL); + ResetFlag(statePtr, INPUT_SAW_CR); return 1; } @@ -9046,7 +9046,6 @@ CopyAndTranslateBuffer( * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ - int toCopy; /* * If there is no input at all, return zero. The invariant is that either @@ -9061,51 +9060,90 @@ CopyAndTranslateBuffer( bufPtr = statePtr->inQueueHead; bytesInBuffer = BytesLeft(bufPtr); - copied = 0; -#if 0 - if (statePtr->flags & INPUT_NEED_NL) { +#if 1 + copied = space; + if (bytesInBuffer <= copied) { + copied = bytesInBuffer; + } + if (copied == 0) { + return copied; + } + TranslateInputEOL(statePtr, result, RemovePoint(bufPtr), + &copied, &bytesInBuffer); + bufPtr->nextRemoved += bytesInBuffer; - /* - * An earlier call to TranslateInputEOL ended in the read of a \r . - * Only the next read from the same channel can complete the - * translation sequence to tell us what character we should read. - */ + /* + * If the current buffer is empty recycle it. + */ + + if (IsBufferEmpty(bufPtr)) { + statePtr->inQueueHead = bufPtr->nextPtr; + if (statePtr->inQueueHead == NULL) { + statePtr->inQueueTail = NULL; + } + RecycleBuffer(statePtr, bufPtr, 0); + } else { + + if (copied > 0) { + return copied; + } - if (bytesInBuffer) { - /* There's a next byte. It will settle things. */ - ResetFlag(statePtr, INPUT_NEED_NL); + if (statePtr->inEofChar + && RemovePoint(bufPtr)[0] == statePtr->inEofChar) { + return 0; + } - if (RemovePoint(bufPtr)[0] == '\n') { - bufPtr->nextRemoved++; - bytesInBuffer--; - *result++ = '\n'; - } else { - *result++ = '\r'; + if (BytesLeft(bufPtr) == 1) { + + ChannelBuffer *nextPtr = bufPtr->nextPtr; + + if (nextPtr == NULL) { + + if (statePtr->flags & CHANNEL_EOF) { + *result = '\r'; + bufPtr->nextRemoved += 1; + return 1; + } + + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + return 0; } - copied++; - space--; - } else if (statePtr->flags & CHANNEL_EOF) { - /* There is no next byte, and there never will be (EOF). */ - ResetFlag(statePtr, INPUT_NEED_NL); + + nextPtr->nextRemoved -= 1; + memcpy(RemovePoint(nextPtr), RemovePoint(bufPtr), 1); + RecycleBuffer(statePtr, bufPtr, 0); + statePtr->inQueueHead = nextPtr; + return 0; + } + + if (statePtr->inEofChar + && RemovePoint(bufPtr)[1] == statePtr->inEofChar) { *result = '\r'; + bufPtr->nextRemoved += 1; return 1; - } else { - /* There is no next byte. Ask the caller to read more. */ - return 0; } + /* + * Buffer is not empty. How can that be? + * 0) We stopped early due to the value of "space". + * => copied > 0 and all is fine. + * 1) We saw eof char and stopped the translation copy. + * => if (copied > 0) or ((copied == 0) and @ eof char), + * return is fine. + * 2) The buffer holds a \r while in CRLF translation, followed + * by either the end of the buffer, or the eof char. + */ + } - toCopy = space; - if (bytesInBuffer <= toCopy) { - toCopy = bytesInBuffer; - } - if (toCopy == 0) { - return copied; - } - TranslateInputEOL(statePtr, result, RemovePoint(bufPtr), - &toCopy, &bytesInBuffer); - bufPtr->nextRemoved += bytesInBuffer; - copied += toCopy; + + /* + * Return the number of characters copied into the result buffer. This may + * be different from the number of bytes consumed, because of EOL + * translations. + */ + + return copied; #else + copied = 0; switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: if (bytesInBuffer == 0) { @@ -9265,7 +9303,6 @@ CopyAndTranslateBuffer( } } } -#endif /* * If the current buffer is empty recycle it. @@ -9286,6 +9323,7 @@ CopyAndTranslateBuffer( */ return copied; +#endif } /* @@ -10726,7 +10764,6 @@ DumpFlags( ChanFlag('S', CHANNEL_STICKY_EOF); ChanFlag('B', CHANNEL_BLOCKED); ChanFlag('/', INPUT_SAW_CR); - ChanFlag('*', INPUT_NEED_NL); ChanFlag('D', CHANNEL_DEAD); ChanFlag('R', CHANNEL_RAW_MODE); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING -- cgit v0.12 From 94a4d6ac65eed79a3fe89a71d1c2a429793300bc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 5 Mar 2014 19:41:51 +0000 Subject: Remove old dead code; silence compiler warnings; tidy up. --- generic/tclIO.c | 415 ++------------------------------------------------------ generic/tclIO.h | 3 - 2 files changed, 12 insertions(+), 406 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 013f8dd..821d111 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5252,33 +5252,25 @@ ReadChars( * UTF-8. On output, contains another guess * based on the data seen so far. */ { - int toRead, factor, srcLen, dstNeeded, numBytes; - int srcRead, dstWrote, numChars, dstRead; - ChannelBuffer *bufPtr; - char *src, *dst; - Tcl_EncodingState oldState; - int encEndFlagSuppressed = 0; Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding : GetBinaryEncoding(); - - factor = *factorPtr; - - bufPtr = statePtr->inQueueHead; - src = RemovePoint(bufPtr); - srcLen = BytesLeft(bufPtr); - - toRead = charsToRead; - if ((unsigned)toRead > (unsigned)srcLen) { - toRead = srcLen; - } + Tcl_EncodingState savedState = statePtr->inputEncodingState; + ChannelBuffer *bufPtr = statePtr->inQueueHead; + int savedIEFlags = statePtr->inputEncodingFlags; + int savedFlags = statePtr->flags; + char *dst, *src = RemovePoint(bufPtr); + int dstLimit, numBytes, srcLen = BytesLeft(bufPtr); + int toRead = ((unsigned) charsToRead > srcLen) ? srcLen : charsToRead; /* * 'factor' is how much we guess that the bytes in the source buffer will * expand when converted to UTF-8 chars. This guess comes from analyzing * how many characters were produced by the previous pass. */ + + int factor = *factorPtr; + int dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; (void) TclGetStringFromObj(objPtr, &numBytes); Tcl_AppendToObj(objPtr, NULL, dstNeeded); if (toRead == srcLen) { @@ -5289,8 +5281,6 @@ ReadChars( dst = TclGetString(objPtr) + numBytes; } -#if 1 - /* * This routine is burdened with satisfying several constraints. * It cannot append more than 'charsToRead` chars onto objPtr. @@ -5307,13 +5297,9 @@ ReadChars( * a consistent set of results. This takes the shape of a loop. */ - int dstLimit = dstNeeded + 1; - int savedFlags = statePtr->flags; - int savedIEFlags = statePtr->inputEncodingFlags; - Tcl_EncodingState savedState = statePtr->inputEncodingState; - + dstLimit = dstNeeded + 1; while (1) { - int dstDecoded; + int dstDecoded, dstRead, dstWrote, srcRead, numChars; /* * Perform the encoding transformation. Read no more than @@ -5555,200 +5541,6 @@ ReadChars( Tcl_SetObjLength(objPtr, numBytes + dstWrote); return numChars; } - -#else - /* - * [Bug 1462248]: The cause of the crash reported in this bug is this: - * - * - ReadChars, called with a single buffer, with a incomplete - * multi-byte character at the end (only the first byte of it). - * - Encoding translation fails, asks for more data - * - Data is read, and eof is reached, TCL_ENCODING_END (TEE) is set. - * - ReadChar is called again, converts the first buffer, but due to TEE - * it does not check for incomplete multi-byte data, and the character - * just after the end of the first buffer is a valid completion of the - * multi-byte header in the actual buffer. The conversion reads more - * characters from the buffer then present. This causes nextRemoved to - * overshoot nextAdded and the next reads compute a negative srcLen, - * cause further translations to fail, causing copying of data into the - * next buffer using bad arguments, causing the mecpy for to eventually - * fail. - * - * In the end it is a memory access bug spiraling out of control if the - * conditions are _just so_. And ultimate cause is that TEE is given to a - * conversion where it should not. TEE signals that this is the last - * buffer. Except in our case it is not. - * - * My solution is to suppress TEE if the first buffer is not the last. We - * will eventually need it given that EOF has been reached, but not right - * now. This is what the new flag "endEncSuppressFlag" is for. - * - * The bug in 'Tcl_Utf2UtfProc' where it read from memory behind the - * actual buffer has been fixed as well, and fixes the problem with the - * crash too, but this would still allow the generic layer to - * accidentially break a multi-byte sequence if the conditions are just - * right, because again the ExternalToUtf would be successful where it - * should not. - */ - - if ((statePtr->inputEncodingFlags & TCL_ENCODING_END) && - (bufPtr->nextPtr != NULL)) { - /* - * TEE is set for a buffer which is not the last. Squash it for now, - * and restore it later, before yielding control to our caller. - */ - - statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - encEndFlagSuppressed = 1; - } - - oldState = statePtr->inputEncodingState; - if (statePtr->flags & INPUT_NEED_NL) { - /* - * We want a '\n' because the last character we saw was '\r'. - */ - - ResetFlag(statePtr, INPUT_NEED_NL); - Tcl_ExternalToUtf(NULL, encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars); - if ((dstWrote > 0) && (*dst == '\n')) { - /* - * The next char was a '\n'. Consume it and produce a '\n'. - */ - - bufPtr->nextRemoved += srcRead; - } else { - /* - * The next char was not a '\n'. Produce a '\r'. - */ - - *dst = '\r'; - } - statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - Tcl_SetObjLength(objPtr, numBytes + 1); - - if (encEndFlagSuppressed) { - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } - return 1; - } - - Tcl_ExternalToUtf(NULL, encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, - dstNeeded + 1, &srcRead, &dstWrote, &numChars); - - if (encEndFlagSuppressed) { - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } - - if (srcRead == 0) { - /* - * Not enough bytes in src buffer to make a complete char. Copy the - * bytes to the next buffer to make a new contiguous string, then tell - * the caller to fill the buffer with more bytes. - */ - - ChannelBuffer *nextPtr; - - nextPtr = bufPtr->nextPtr; - if (nextPtr == NULL) { - if (srcLen > 0) { - /* - * There isn't enough data in the buffers to complete the next - * character, so we need to wait for more data before the next - * file event can be delivered. [Bug 478856] - * - * The exception to this is if the input buffer was completely - * empty before we tried to convert its contents. Nothing in, - * nothing out, and no incomplete character data. The - * conversion before the current one was complete. - */ - - SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); - } - Tcl_SetObjLength(objPtr, numBytes); - return -1; - } - - /* - * Space is made at the beginning of the buffer to copy the previous - * unused bytes there. Check first if the buffer we are using actually - * has enough space at its beginning for the data we are copying. - * Because if not we will write over the buffer management - * information, especially the 'nextPtr'. - * - * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used to - * prevent exactly this situation. I.e. it should never happen. - * Therefore it is ok to panic should it happen despite the - * precautions. - */ - - if (nextPtr->nextRemoved - srcLen < 0) { - Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); - } - - nextPtr->nextRemoved -= srcLen; - memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); - RecycleBuffer(statePtr, bufPtr, 0); - statePtr->inQueueHead = nextPtr; - Tcl_SetObjLength(objPtr, numBytes); - return ReadChars(statePtr, objPtr, charsToRead, factorPtr); - } - - dstRead = dstWrote; - if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) { - /* - * Hit EOF char. How many bytes of src correspond to where the EOF was - * located in dst? Run the conversion again with an output buffer just - * big enough to hold the data so we can get the correct value for - * srcRead. - */ - - if (dstWrote == 0) { - Tcl_SetObjLength(objPtr, numBytes); - return -1; - } - statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); - TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - } - - /* - * The number of characters that we got may be less than the number that - * we started with because "\r\n" sequences may have been turned into just - * '\n' in dst. - */ - - numChars -= (dstRead - dstWrote); - - if ((unsigned) numChars > (unsigned) toRead) { - /* - * Got too many chars. - */ - - const char *eof; - - eof = Tcl_UtfAtIndex(dst, toRead); - statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); - dstRead = dstWrote; - TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - numChars -= (dstRead - dstWrote); - } - statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - - bufPtr->nextRemoved += srcRead; - if (dstWrote > srcRead + 1) { - *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; - } - Tcl_SetObjLength(objPtr, numBytes + dstWrote); - return numChars; -#endif } /* @@ -9060,7 +8852,6 @@ CopyAndTranslateBuffer( bufPtr = statePtr->inQueueHead; bytesInBuffer = BytesLeft(bufPtr); -#if 1 copied = space; if (bytesInBuffer <= copied) { copied = bytesInBuffer; @@ -9142,188 +8933,6 @@ CopyAndTranslateBuffer( */ return copied; -#else - copied = 0; - switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer. - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; - case TCL_TRANSLATE_CR: { - char *end; - - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer, then replace all \r - * with \n. - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - for (end = result + copied; result < end; result++) { - if (*result == '\r') { - *result = '\n'; - } - } - break; - } - case TCL_TRANSLATE_CRLF: { - char *src, *end, *dst; - int curByte; - - /* - * If there is a held-back "\r" at EOF, produce it now. - */ - - if (bytesInBuffer == 0) { - if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - ResetFlag(statePtr, INPUT_SAW_CR); - return 1; - } - return 0; - } - - /* - * Copy the current chunk and replace "\r\n" with "\n" (but not - * standalone "\r"!). - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\n') { - ResetFlag(statePtr, INPUT_SAW_CR); - } else if (statePtr->flags & INPUT_SAW_CR) { - ResetFlag(statePtr, INPUT_SAW_CR); - *dst = '\r'; - dst++; - } - if (curByte == '\r') { - SetFlag(statePtr, INPUT_SAW_CR); - } else { - *dst = (char) curByte; - dst++; - } - } - copied = dst - result; - break; - } - case TCL_TRANSLATE_AUTO: { - char *src, *end, *dst; - int curByte; - - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Loop over the current buffer, converting "\r" and "\r\n" to "\n". - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\r') { - SetFlag(statePtr, INPUT_SAW_CR); - *dst = '\n'; - dst++; - } else { - if ((curByte != '\n') || !(statePtr->flags & INPUT_SAW_CR)) { - *dst = (char) curByte; - dst++; - } - ResetFlag(statePtr, INPUT_SAW_CR); - } - } - copied = dst - result; - break; - } - default: - Tcl_Panic("unknown eol translation mode"); - } - - /* - * If an in-stream EOF character is set for this channel, check that the - * input we copied so far does not contain the EOF char. If it does, copy - * only up to and excluding that character. - */ - - if (statePtr->inEofChar != 0) { - int i; - - for (i = 0; i < copied; i++) { - if (result[i] == (char) statePtr->inEofChar) { - /* - * Set sticky EOF so that no further input is presented to the - * caller. - */ - - SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - copied = i; - break; - } - } - } - - /* - * If the current buffer is empty recycle it. - */ - - if (IsBufferEmpty(bufPtr)) { - statePtr->inQueueHead = bufPtr->nextPtr; - if (statePtr->inQueueHead == NULL) { - statePtr->inQueueTail = NULL; - } - RecycleBuffer(statePtr, bufPtr, 0); - } - - /* - * Return the number of characters copied into the result buffer. This may - * be different from the number of bytes consumed, because of EOL - * translations. - */ - - return copied; -#endif } /* diff --git a/generic/tclIO.h b/generic/tclIO.h index ebf2ef7..a57d4c5 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -252,9 +252,6 @@ typedef struct ChannelState { #define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input * translation mode and the last byte * seen was a "\r". */ -#define INPUT_NEED_NL (1<<15) /* Saw a '\r' at end of last buffer, - * and there should be a '\n' at - * beginning of next buffer. */ #define CHANNEL_DEAD (1<<13) /* The channel has been closed by the * exit handler (on exit) but not * deallocated. When any IO operation -- cgit v0.12 From 3d0e0863c3cb661e0e0b03a84f6227bc3b5a0d20 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 6 Mar 2014 10:37:13 +0000 Subject: Terminate async connect synchronously by any blocking operation --- win/tclWinSock.c | 116 +++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 104 insertions(+), 12 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 162cbd4..263ef9a 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,7 +47,7 @@ #include "tclWinInt.h" -#define DEBUGGING +//#define DEBUGGING #ifdef DEBUGGING #define DEBUG(x) fprintf(stderr, ">>> %p %s(%d): %s<<<\n", \ infoPtr, __FUNCTION__, __LINE__, x) @@ -207,6 +207,9 @@ typedef struct { #define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ #define SOCKET_PENDING (1<<3) /* A message has been sent for this * socket */ +#define SOCKET_REENTER_PENDING (1<<4) /* The reentering after a received + * FD_CONNECT to CreateClientSocket + * is pending */ typedef struct { HWND hwnd; /* Handle to window for socket messages. */ @@ -236,6 +239,7 @@ static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); +static int WaitForAsyncConnect(SocketInfo *infoPtr, int *errorCodePtr); static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); static DWORD WINAPI SocketThread(LPVOID arg); @@ -763,11 +767,12 @@ SocketEventProc( infoPtr->flags &= ~SOCKET_PENDING; - if (infoPtr->readyEvents & FD_CONNECT) { + /* Continue async connect if pending and ready */ + if ( (infoPtr->flags & SOCKET_REENTER_PENDING) + && (infoPtr->readyEvents & FD_CONNECT) ) { DEBUG("FD_CONNECT"); SetEvent(tsdPtr->socketListLock); CreateClientSocket(NULL, infoPtr); - infoPtr->readyEvents &= ~(FD_CONNECT); return 1; } @@ -1173,15 +1178,22 @@ CreateClientSocket( SocketInfo *infoPtr) { u_long flag = 1; /* Indicates nonblocking mode. */ - int async = infoPtr->flags & SOCKET_ASYNC_CONNECT; + /* + * We are started with async connect and the connect notification + * was not jet received + */ + int async_connect = infoPtr->flags & SOCKET_ASYNC_CONNECT; + /* We were called by the event procedure and continue our loop */ int async_callback = infoPtr->sockets->fd != INVALID_SOCKET; ThreadSpecificData *tsdPtr; DWORD error; - DEBUG(async ? "async" : "sync"); + DEBUG(async_connect ? "async connect" : "sync connect"); if (async_callback) { DEBUG("subsequent call"); + /* Clear this pending reenter case */ + infoPtr->flags &= ~(SOCKET_REENTER_PENDING); goto reenter; } else { DEBUG("first call"); @@ -1257,7 +1269,7 @@ CreateClientSocket( * Set the socket into nonblocking mode if the connect should * be done in the background. */ - if (async) { + if (async_connect) { ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); infoPtr->selectEvents |= FD_CONNECT; @@ -1280,6 +1292,8 @@ CreateClientSocket( #endif if (error == WSAEWOULDBLOCK) { DEBUG("WSAEWOULDBLOCK"); + /* Jump out and remember that we want to get back in */ + infoPtr->flags |= SOCKET_REENTER_PENDING; return TCL_OK; reenter: Tcl_SetErrno(infoPtr->lastError); @@ -1299,6 +1313,8 @@ out: DEBUG("connected or finally failed"); if (Tcl_GetErrno() != 0 && interp != NULL) { DEBUG("ERRNO"); + /* Clear async flag so if a read is done it does not block */ + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", Tcl_PosixError(interp))); @@ -1329,6 +1345,82 @@ out: /* *---------------------------------------------------------------------- * + * WaitForAsyncConnect -- + * + * Terminate an asyncroneous connect syncroneously. + * This routine should only be called if flag ASYNC_CONNECT is set. + * + * Results: + * Returns 1 on success or 0 on failure, with an error code in + * errorCodePtr. + * + * Side effects: + * Processes socket events off the system queue. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForAsyncConnect( + SocketInfo *infoPtr, /* Information about this socket. */ + int *errorCodePtr) /* Where to store errors? */ +{ + int result = 1; + int oldMode; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + /* + * A non blocking socket waiting for an asyncronous connect + * returns directly an error + */ + if (infoPtr->flags & SOCKET_ASYNC) { + *errorCodePtr = EWOULDBLOCK; + return 0; + } + + /* + * Be sure to disable event servicing so we are truly modal. + */ + + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + + /* + * Disable async connect as we continue now synchoneously + */ + + /* ToDo: need thread protection * */ + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + + /* + * Reset WSAAsyncSelect so we have a fresh set of events pending. + */ + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, + (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); + + while (1) { + /* Check for connect event */ + if (infoPtr->readyEvents & FD_CONNECT) { + /* continue async connect syncroneously */ + result = CreateClientSocket(NULL, infoPtr); + (void) Tcl_SetServiceMode(oldMode); + /* Todo: find adequate error code */ + *errorCodePtr = EFAULT; + return (result == TCL_OK); + } + + /* + * Wait until something happens. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + } +} + +/* + *---------------------------------------------------------------------- + * * WaitForSocketEvent -- * * Waits until one of the specified events occurs on a socket. @@ -1865,11 +1957,11 @@ TcpInputProc( } /* - * Check to see if the socket is connected before trying to read. + * Check if there is an async connect to terminate */ - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { + if ( (infoPtr->flags & SOCKET_REENTER_PENDING) + && !WaitForAsyncConnect(infoPtr, errorCodePtr)) { return -1; } @@ -1993,11 +2085,11 @@ TcpOutputProc( } /* - * Check to see if the socket is connected before trying to write. + * Check if there is an async connect to terminate */ - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { + if ( (infoPtr->flags & SOCKET_REENTER_PENDING) + && !WaitForAsyncConnect(infoPtr, errorCodePtr)) { return -1; } -- cgit v0.12 From a59f5c70234be1134e3752519daa601c3c850365 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Mar 2014 15:51:06 +0000 Subject: Variable "rawStart" serves no purpose. --- generic/tclIO.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 821d111..b0d0e32 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4464,7 +4464,7 @@ FilterInputBytes( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - char *raw, *rawStart, *dst; + char *raw, *dst; int offset, toRead, dstNeeded, spaceLeft, result, rawLen; Tcl_Obj *objPtr; #define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert at @@ -4521,8 +4521,7 @@ FilterInputBytes( * string rep if we need more space. */ - rawStart = RemovePoint(bufPtr); - raw = rawStart; + raw = RemovePoint(bufPtr); rawLen = BytesLeft(bufPtr); dst = *gsPtr->dstPtr; -- cgit v0.12 From e53f96cbd13df27c822ebe8cc9a5e215f70b800f Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 6 Mar 2014 18:21:40 +0000 Subject: More debug to chase different fd in struct than in callback --- tests/socket.test | 6 ++++ win/tclWinSock.c | 93 ++++++++++++++++++++++++------------------------------- 2 files changed, 46 insertions(+), 53 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index 51219e6..74c44ce 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1855,12 +1855,15 @@ test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] bef -constraints [list socket supported_inet supported_inet6] \ -setup { proc accept {s a p} { + global s puts $s bye close $s + set s ok } set server [socket -server accept -myaddr 127.0.0.1 0] set port [lindex [fconfigure $server -sockname] 2] set x "" + set s "" } \ -body { set client [socket -async localhost $port] @@ -1869,6 +1872,9 @@ test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] bef lappend x [fconfigure $client -error] update } + # This test blocked, as gets waits for the accept which did + # not run due to missing vwait + vwait sok lappend x [gets $client] } \ -cleanup { diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 263ef9a..0533ecd 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,7 +47,7 @@ #include "tclWinInt.h" -//#define DEBUGGING +#define DEBUGGING #ifdef DEBUGGING #define DEBUG(x) fprintf(stderr, ">>> %p %s(%d): %s<<<\n", \ infoPtr, __FUNCTION__, __LINE__, x) @@ -768,12 +768,14 @@ SocketEventProc( infoPtr->flags &= ~SOCKET_PENDING; /* Continue async connect if pending and ready */ - if ( (infoPtr->flags & SOCKET_REENTER_PENDING) - && (infoPtr->readyEvents & FD_CONNECT) ) { + if ( infoPtr->readyEvents & FD_CONNECT ) { + infoPtr->readyEvents &= ~(FD_CONNECT); DEBUG("FD_CONNECT"); - SetEvent(tsdPtr->socketListLock); - CreateClientSocket(NULL, infoPtr); - return 1; + if ( infoPtr->flags & SOCKET_REENTER_PENDING ) { + SetEvent(tsdPtr->socketListLock); + CreateClientSocket(NULL, infoPtr); + return 1; + } } /* @@ -1192,8 +1194,6 @@ CreateClientSocket( if (async_callback) { DEBUG("subsequent call"); - /* Clear this pending reenter case */ - infoPtr->flags &= ~(SOCKET_REENTER_PENDING); goto reenter; } else { DEBUG("first call"); @@ -1242,6 +1242,9 @@ CreateClientSocket( continue; } +#ifdef DEBUGGING + fprintf(stderr, "Client socket %d created\n", infoPtr->sockets->fd); +#endif /* * Win-NT has a misfeature that sockets are inherited in child * processes by default. Turn off the inherit bit. @@ -1287,12 +1290,11 @@ CreateClientSocket( infoPtr->addr->ai_addrlen); error = WSAGetLastError(); TclWinConvertError(error); -#ifdef DEBUGGING - // fprintf(stderr,"error = %lu\n", error); -#endif - if (error == WSAEWOULDBLOCK) { + if (async_connect && error == WSAEWOULDBLOCK) { DEBUG("WSAEWOULDBLOCK"); - /* Jump out and remember that we want to get back in */ + /* + * Activate FD_CONNECT notification and reenter jump + */ infoPtr->flags |= SOCKET_REENTER_PENDING; return TCL_OK; reenter: @@ -1300,6 +1302,11 @@ CreateClientSocket( DEBUG("reenter"); infoPtr->selectEvents &= ~(FD_CONNECT); } + /* + * Clear the reenter flag also for the (hypothetic) case + * that connect did succeed emidiately + */ + infoPtr->flags &= ~(SOCKET_REENTER_PENDING); #ifdef DEBUGGING fprintf(stderr, "lastError: %d\n", Tcl_GetErrno()); #endif @@ -1311,10 +1318,10 @@ CreateClientSocket( out: DEBUG("connected or finally failed"); + /* Clear async flag (not really necessary, not used any more) */ + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); if (Tcl_GetErrno() != 0 && interp != NULL) { DEBUG("ERRNO"); - /* Clear async flag so if a read is done it does not block */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", Tcl_PosixError(interp))); @@ -1373,9 +1380,9 @@ WaitForAsyncConnect( * returns directly an error */ if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; - return 0; - } + *errorCodePtr = EWOULDBLOCK; + return 0; + } /* * Be sure to disable event servicing so we are truly modal. @@ -1387,21 +1394,15 @@ WaitForAsyncConnect( * Disable async connect as we continue now synchoneously */ - /* ToDo: need thread protection * */ + /* ToDo: need thread protection? */ infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - /* - * Reset WSAAsyncSelect so we have a fresh set of events pending. - */ - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, - (LPARAM) infoPtr); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); - while (1) { /* Check for connect event */ if (infoPtr->readyEvents & FD_CONNECT) { + /* Consume the connect event */ + /* ToDo: eventual signaling ? */ + infoPtr->readyEvents &= ~(FD_CONNECT); /* continue async connect syncroneously */ result = CreateClientSocket(NULL, infoPtr); (void) Tcl_SetServiceMode(oldMode); @@ -2745,39 +2746,23 @@ SocketProc( if (event & FD_CONNECT) { DEBUG("FD_CONNECT"); - - if (error == ERROR_SUCCESS) { - /* - * The socket is now connected, clear the async connect - * flag. - */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - } else { - /* - * Remember any error that occurred so we can report - * connection failures. - */ - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); - } - } -#if 0 - if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { - DEBUG("SOCKET_ASYNC_CONNECT"); - // infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + /* + * Remember any error that occurred so we can report + * connection failures. + */ if (error != ERROR_SUCCESS) { TclWinConvertError((DWORD) error); infoPtr->lastError = Tcl_GetErrno(); } - infoPtr->readyEvents |= FD_WRITE; } -#endif + /* + * Inform main thread about signaled events + */ infoPtr->readyEvents |= event; /* * Wake up the Main Thread. */ - SetEvent(tsdPtr->readyEvent); Tcl_ThreadAlert(tsdPtr->threadId); break; @@ -2788,10 +2773,12 @@ SocketProc( break; case SOCKET_SELECT: - DEBUG("SOCKET_SELECT"); + DEBUG("SOCKET_SELECT"); infoPtr = (SocketInfo *) lParam; for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - infoPtr = (SocketInfo *) lParam; +#ifdef DEBUGGING + fprintf(stderr,"loop over fd = %d\n",fds->fd); +#endif if (wParam == SELECT) { DEBUG("SELECT"); if (infoPtr->selectEvents & FD_READ) DEBUG(" READ"); -- cgit v0.12 From bc91d5aa1ef2be26a0f1a6d3de3fb05724964afe Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 7 Mar 2014 07:40:30 +0000 Subject: Still incomplete info structure in event proc: try to protect with locks (unsuccesful). Probably locks in accept socket creation missing. --- win/tclWinSock.c | 63 +++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 51 insertions(+), 12 deletions(-) diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 0533ecd..62d4073 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1151,6 +1151,12 @@ NewSocketInfo(SOCKET socket) * * This function opens a new socket in client mode. * + * This might be called in 3 circumstances: + * - By a regular socket command + * - By the event handler to continue an asynchroneous connect + * - By a blocking socket function (gets/puts) to terminate the + * connect synchroneously + * * Results: * TCL_OK, if the socket was successfully connected or an asynchronous * connection is in progress. If an error occurs, TCL_ERROR is returned @@ -1179,6 +1185,7 @@ CreateClientSocket( Tcl_Interp *interp, /* For error reporting; can be NULL. */ SocketInfo *infoPtr) { + DWORD error; u_long flag = 1; /* Indicates nonblocking mode. */ /* * We are started with async connect and the connect notification @@ -1187,8 +1194,7 @@ CreateClientSocket( int async_connect = infoPtr->flags & SOCKET_ASYNC_CONNECT; /* We were called by the event procedure and continue our loop */ int async_callback = infoPtr->sockets->fd != INVALID_SOCKET; - ThreadSpecificData *tsdPtr; - DWORD error; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); DEBUG(async_connect ? "async connect" : "sync connect"); @@ -1230,12 +1236,20 @@ CreateClientSocket( closesocket(infoPtr->sockets->fd); } + /* get infoPtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + /* * Reset last error from last try */ infoPtr->lastError = 0; infoPtr->sockets->fd = socket(infoPtr->myaddr->ai_family, SOCK_STREAM, 0); + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* continue on socket creation error */ if (infoPtr->sockets->fd == INVALID_SOCKET) { DEBUG("socket() failed"); TclWinConvertError((DWORD) WSAGetLastError()); @@ -1273,12 +1287,21 @@ CreateClientSocket( * be done in the background. */ if (async_connect) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + /* get infoPtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* Now get connect events */ infoPtr->selectEvents |= FD_CONNECT; - ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + // ioctlsocket(infoPtr->sockets->fd, (long) FIONBIO, &flag); SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); + } else { + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); } /* @@ -1300,7 +1323,11 @@ CreateClientSocket( reenter: Tcl_SetErrno(infoPtr->lastError); DEBUG("reenter"); + /* get infoPtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); infoPtr->selectEvents &= ~(FD_CONNECT); + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); } /* * Clear the reenter flag also for the (hypothetic) case @@ -1390,27 +1417,39 @@ WaitForAsyncConnect( oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); - /* - * Disable async connect as we continue now synchoneously - */ - - /* ToDo: need thread protection? */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - while (1) { + + /* get infoPtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + /* Check for connect event */ if (infoPtr->readyEvents & FD_CONNECT) { + /* Consume the connect event */ - /* ToDo: eventual signaling ? */ infoPtr->readyEvents &= ~(FD_CONNECT); + + /* + * Disable async connect as we continue now synchoneously + */ + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + /* continue async connect syncroneously */ result = CreateClientSocket(NULL, infoPtr); + + /* Restore event service mode */ (void) Tcl_SetServiceMode(oldMode); + /* Todo: find adequate error code */ *errorCodePtr = EFAULT; return (result == TCL_OK); } + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + /* * Wait until something happens. */ -- cgit v0.12 From a895183137cb5e741f92353116465a9e27c432e4 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Mar 2014 19:43:16 +0000 Subject: Simplify the input eof char scan. Update some comments. --- generic/tclIO.c | 64 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index b0d0e32..03aac32 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5244,7 +5244,11 @@ ReadChars( * is larger than the number of characters * available in the first buffer, only the * characters from the first buffer are - * returned. */ + * returned. The execption is when there is + * not any complete character in the first + * buffer. In that case, a recursive call + * effectively obtains chars from the + * second buffer. */ int *factorPtr) /* On input, contains a guess of how many * bytes need to be allocated to hold the * result of converting N source bytes to @@ -5259,6 +5263,15 @@ ReadChars( int savedFlags = statePtr->flags; char *dst, *src = RemovePoint(bufPtr); int dstLimit, numBytes, srcLen = BytesLeft(bufPtr); + + /* + * One src byte can yield at most one character. So when the + * number of src bytes we plan to read is less than the limit on + * character count to be read, clearly we will remain within that + * limit, and we can use the value of "srcLen" as a tighter limit + * for sizing receiving buffers. + */ + int toRead = ((unsigned) charsToRead > srcLen) ? srcLen : charsToRead; /* @@ -5569,43 +5582,32 @@ TranslateInputEOL( * characters. */ const char *srcStart, /* Source characters. */ int *dstLenPtr, /* On entry, the maximum length of output - * buffer in bytes; must be <= *srcLenPtr. On - * exit, the number of bytes actually used in - * output buffer. */ + * buffer in bytes. On exit, the number of + * bytes actually used in output buffer. */ int *srcLenPtr) /* On entry, the length of source buffer. On * exit, the number of bytes read from the * source buffer. */ { - int dstLen, srcLen, inEofChar; - const char *eof; + const char *eof = NULL; + int dstLen = *dstLenPtr; + int srcLen = *srcLenPtr; + int inEofChar = statePtr->inEofChar; - dstLen = *dstLenPtr; - - eof = NULL; - inEofChar = statePtr->inEofChar; if (inEofChar != '\0') { /* - * Find EOF in translated buffer then compress out the EOL. The source - * buffer may be much longer than the destination buffer - we only - * want to return EOF if the EOF has been copied to the destination - * buffer. + * Make sure we do not read past any logical end of channel input + * created by the presence of the input eof char. */ - const char *src, *srcMax; - - srcMax = srcStart + *srcLenPtr; - for (src = srcStart; src < srcMax; src++) { - if (*src == inEofChar) { - eof = src; - srcLen = src - srcStart; - if (srcLen < dstLen) { - dstLen = srcLen; - } - *srcLenPtr = srcLen; - break; - } + if ((eof = memchr(srcStart, inEofChar, srcLen))) { + srcLen = eof - srcStart; } } + + if (dstLen > srcLen) { + dstLen = srcLen; + } + switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: if (dstStart != srcStart) { @@ -5635,7 +5637,7 @@ TranslateInputEOL( dst = dstStart; src = srcStart; srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; + srcMax = srcStart + srcLen; for ( ; src < srcEnd; ) { if (*src == '\r') { @@ -5663,7 +5665,7 @@ TranslateInputEOL( dst = dstStart; src = srcStart; srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; + srcMax = srcStart + srcLen; if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) { if (*src == '\n') { @@ -5692,9 +5694,10 @@ TranslateInputEOL( break; } default: - return 0; + Tcl_Panic("unknown input translation %d", statePtr->inputTranslation); } *dstLenPtr = dstLen; + *srcLenPtr = srcLen; if ((eof != NULL) && (srcStart + srcLen >= eof)) { /* @@ -5709,7 +5712,6 @@ TranslateInputEOL( return 1; } - *srcLenPtr = srcLen; return 0; } -- cgit v0.12 From 83f5493faa96da87b5327be1f49e432f5a870879 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Mar 2014 20:15:12 +0000 Subject: TranslateInputEOL() callers no longer need assert dstLen <= srcLen. --- generic/tclIO.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 03aac32..d23ca03 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5330,7 +5330,8 @@ ReadChars( * Capture the number of bytes actually consumed in dstRead. */ - dstWrote = dstRead = dstDecoded; + dstWrote = dstLimit; + dstRead = dstDecoded; TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); if (dstRead < dstDecoded) { @@ -8852,14 +8853,11 @@ CopyAndTranslateBuffer( } bufPtr = statePtr->inQueueHead; bytesInBuffer = BytesLeft(bufPtr); + if (bytesInBuffer == 0) { + return 0; + } copied = space; - if (bytesInBuffer <= copied) { - copied = bytesInBuffer; - } - if (copied == 0) { - return copied; - } TranslateInputEOL(statePtr, result, RemovePoint(bufPtr), &copied, &bytesInBuffer); bufPtr->nextRemoved += bytesInBuffer; -- cgit v0.12 From 85ef4165965dd5e25ccfb0e01ac2d1cf4b3df7aa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 9 Mar 2014 21:55:51 +0000 Subject: Mark io-35.18b test as knownBug --- tests/io.test | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/io.test b/tests/io.test index 64c878d..4791280 100644 --- a/tests/io.test +++ b/tests/io.test @@ -4701,7 +4701,7 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f list $c $l $e } {21 8 1} -test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} { +test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation cr @@ -4714,8 +4714,8 @@ test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} { set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} {8 8 1 13} -test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} { +} -result {8 8 1 13} +test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation cr -eofchar \x1a @@ -4728,8 +4728,8 @@ test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} { set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} {9 8 1 13} -test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} { +} -result {9 8 1 13} +test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -constraints knownBug -body { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation cr -eofchar \x1a @@ -4742,8 +4742,8 @@ test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} { set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} {2 1 1 13} -test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} { +} -result {2 1 1 13} +test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation cr @@ -4756,8 +4756,8 @@ test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} { set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} {1 1 1 13} -test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} { +} -result {1 1 1 13} +test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation cr -eofchar {} @@ -4771,7 +4771,7 @@ test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} { set e [eof $f] close $f list $c $l $e [scan [string index $in end] %c] -} {17 8 1 13} +} -result {17 8 1 13} # Test Tcl_InputBlocked -- cgit v0.12 From 62268820f73d797eebfc2a66ed3fa856c27daeb7 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 10 Mar 2014 03:09:03 +0000 Subject: TranslateInputEOL doesn't need to return anything. No caller cares. Other optimizations and simplifications. --- generic/tclIO.c | 79 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 43 insertions(+), 36 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index d23ca03..6dfdd03 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -214,7 +214,7 @@ static int StackSetBlockMode(Channel *chanPtr, int mode); static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr, int mode); static void StopCopy(CopyState *csPtr); -static int TranslateInputEOL(ChannelState *statePtr, char *dst, +static void TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); static int Write(Channel *chanPtr, const char *src, @@ -5574,7 +5574,7 @@ ReadChars( *--------------------------------------------------------------------------- */ -static int +static void TranslateInputEOL( ChannelState *statePtr, /* Channel being read, for EOL translation and * EOF character. */ @@ -5594,6 +5594,29 @@ TranslateInputEOL( int srcLen = *srcLenPtr; int inEofChar = statePtr->inEofChar; + /* + * Depending on the translation mode in use, there's no need + * to scan more srcLen bytes at srcStart than can possibly transform + * to dstLen bytes. This keeps the scan for eof char below from + * being pointlessly long. + */ + + switch (statePtr->inputTranslation) { + case TCL_TRANSLATE_LF: + case TCL_TRANSLATE_CR: + if (srcLen > dstLen) { + /* In these modes, each src byte become a dst byte. */ + srcLen = dstLen; + } + break; + default: + /* In other modes, at most 2 src bytes become a dst byte. */ + if (srcLen > 2 * dstLen) { + srcLen = 2 * dstLen; + } + break; + } + if (inEofChar != '\0') { /* * Make sure we do not read past any logical end of channel input @@ -5605,36 +5628,29 @@ TranslateInputEOL( } } - if (dstLen > srcLen) { - dstLen = srcLen; - } - switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: + case TCL_TRANSLATE_CR: if (dstStart != srcStart) { - memcpy(dstStart, srcStart, (size_t) dstLen); + memcpy(dstStart, srcStart, (size_t) srcLen); } - srcLen = dstLen; - break; - case TCL_TRANSLATE_CR: { - char *dst, *dstEnd; + if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { + char *dst = dstStart; + char *dstEnd = dstStart + srcLen; - if (dstStart != srcStart) { - memcpy(dstStart, srcStart, (size_t) dstLen); - } - dstEnd = dstStart + dstLen; - for (dst = dstStart; dst < dstEnd; dst++) { - if (*dst == '\r') { - *dst = '\n'; + while ((dst = memchr(dst, '\r', dstEnd - dst))) { + *dst++ = '\n'; } } - srcLen = dstLen; + dstLen = srcLen; break; - } case TCL_TRANSLATE_CRLF: { char *dst; const char *src, *srcEnd, *srcMax; + if (dstLen > srcLen) { + dstLen = srcLen; + } dst = dstStart; src = srcStart; srcEnd = srcStart + dstLen; @@ -5660,29 +5676,23 @@ TranslateInputEOL( break; } case TCL_TRANSLATE_AUTO: { - char *dst; - const char *src, *srcEnd, *srcMax; + const char *srcEnd = srcStart + srcLen; + const char *dstEnd = dstStart + dstLen; + const char *src = srcStart; + char *dst = dstStart; - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + srcLen; - - if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) { + if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { if (*src == '\n') { src++; } ResetFlag(statePtr, INPUT_SAW_CR); } - for ( ; src < srcEnd; ) { + for ( ; dst < dstEnd && src < srcEnd; ) { if (*src == '\r') { src++; - if (src >= srcMax) { + if (src == srcEnd) { SetFlag(statePtr, INPUT_SAW_CR); } else if (*src == '\n') { - if (srcEnd < srcMax) { - srcEnd++; - } src++; } *dst++ = '\n'; @@ -5710,10 +5720,7 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; ResetFlag(statePtr, INPUT_SAW_CR); - return 1; } - - return 0; } /* -- cgit v0.12 From 3c84887dc4fac9f47f2c1b5521c6d889ab6f9dc1 Mon Sep 17 00:00:00 2001 From: max Date: Mon, 10 Mar 2014 12:08:44 +0000 Subject: * tclUnixSock.c: Fix WaitForConnect() for client sockets that have to try more than one address. * socket.test: Extend and improve tests for [socket -async] * socket.test: Add latency measuring and calculation for Windows. --- tests/socket.test | 199 +++++++++++++++++++++++++++++++++++++++++++++++------ unix/tclUnixSock.c | 20 +++--- 2 files changed, 190 insertions(+), 29 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index 74c44ce..bfe6990 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -86,8 +86,21 @@ puts $s2 test1; gets $s1 puts $s2 test2; gets $s1 close $s1; close $s2 set t2 [clock milliseconds] -set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin -unset t1 t2 s1 s2 server +set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin + +# Test the latency of failed connection attempts over the loopback +# interface. They can take more than a second under Windowos and requres +# additional [after]s in some tests that are not needed on systems that fail +# immediately. +set t1 [clock milliseconds] +catch {socket 127.0.0.1 [randport]} +set t2 [clock milliseconds] +set lat2 [expr {($t2-$t1)*2}] + +# Use the maximum of the two latency calculations, but at least 100ms +set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}] +set latency [expr {$latency > 100 ? $latency : 100}] +unset t1 t2 s1 s2 lat1 lat2 server # If remoteServerIP or remoteServerPort are not set, check in the environment # variables for externally set values. @@ -1723,7 +1736,7 @@ catch {close $commandSocket} catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF -test socket-14.0 {[socket -async] when server only listens on IPv4} \ +test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ -constraints [list socket supported_any localhost_v4] \ -setup { proc accept {s a p} { @@ -1736,7 +1749,29 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ + -constraints [list socket supported_any localhost_v4] \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1763,7 +1798,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ lappend x [fconfigure $client -error] fileevent $client writable {} } - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1781,7 +1816,7 @@ test socket-14.2 {[socket -async] fileevent connection refused} \ regexp {[^:]*: (.*)} $client -> x } else { fileevent $client writable {set x [fconfigure $client -error]} - set after [after 1000 {set x timeout}] + set after [after $latency {set x timeout}] vwait x after cancel $after if {$x eq "timeout"} { @@ -1806,7 +1841,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1832,7 +1867,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ fileevent $client writable {} } fileevent $client readable {lappend x [gets $client]} - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1851,38 +1886,162 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} -test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ +test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ -constraints [list socket supported_inet supported_inet6] \ -setup { proc accept {s a p} { - global s + global x puts $s bye close $s - set s ok + set x ok } set server [socket -server accept -myaddr 127.0.0.1 0] set port [lindex [fconfigure $server -sockname] 2] set x "" - set s "" } \ -body { set client [socket -async localhost $port] - foreach _ {1 2} { - lappend x [lindex [fconfigure $client -sockname] 0] - lappend x [fconfigure $client -error] + for {set i 0} {$i < 50} {incr i } { update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 } - # This test blocked, as gets waits for the accept which did - # not run due to missing vwait - vwait sok - lappend x [gets $client] + set x } \ -cleanup { close $server close $client unset x } \ - -result [list ::1 "connection refused" 127.0.0.1 "" bye] + -result {ok bye} +test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ + -constraints [list socket supported_inet supported_inet6] \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ + -constraints {socket supported_inet supported_inet6} \ + -setup { + makeFile { + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + gets $sock + } -cleanup { + # make sure the server exits + catch {socket 127.0.0.1 $port} + close $sock + close $fd + } -result {ok} +test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ + -constraints {socket supported_inet supported_inet6} \ + -setup { + makeFile { + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + gets $sock + } -cleanup { + # make sure the server exits + catch {socket ::1 $port} + close $sock + close $fd + } -result {ok} +test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ + -constraints {socket supported_inet supported_inet6} \ + -setup { + makeFile { + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[set x [gets $sock]] ne ""} break + after 200 + } + set x + } -cleanup { + # make sure the server exits + catch {socket 127.0.0.1 $port} + close $sock + close $fd + } -result {ok} +test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ + -constraints {socket supported_inet supported_inet6} \ + -setup { +