Tcl Source Code

View Ticket
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki
Attach Edit New Ticket Plaintext
Ticket UUID: 219166
Title: overaggressive compiling of ""ed bodies
Type: Bug Version: None
Submitter: nobody Created on: 2000-10-26 05:02:46
Subsystem: 10. Objects Assigned To: hobbs
Priority: 7 High Severity:
Status: Closed Last Modified: 2001-09-20 01:19:41
Resolution: Fixed Closed By: hobbs
    Closed on: 2001-09-19 18:19:41
Description: 
OriginalBugID: 1669 Bug
Version: 8.1b2
SubmitDate: '1999-03-30'
LastModified: '1999-12-03'
Severity: SER
Status: Assigned
Submitter: redman
ChangedBy: hobbs
RelatedBugIDs: 727
OS: All
OSVersion: NA
Machine: NA
FixedDate: '2000-10-25'
FixedInVersion: NA
ClosedDate: '2000-10-25'


03/30/1999 16:06 - redman - The following patch is for test cases that fail in 8.1b2 provided by Viktor Dukhovni.


Index: expr.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/expr.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 expr.test

--- expr.test   1999/03/23 00:59:20     1.1.1.1

+++ expr.test   1999/03/23 05:34:58

@@ -668,4 +668,41 @@

 } 3


+# Test for incorrect "double evaluation" semantics

+

+test expr-20.1 {wrong brace matching} {

+    # fails with 8.0.x, but not 8.1b2

+    catch {unset l}

+    catch {unset r}

+    catch {unset q}

+    catch {unset cmd}

+    catch {unset a}

+    set l "\{"; set r "\}"; set q "\""

+    set cmd "expr $l$q|$q == $q$r$q$r"

+    list [catch $cmd a] $a

+} {1 {extra characters after close-brace}}

+test expr-20.2 {double invocation of variable traces} {

+    set exprtracecounter 0

+    proc exprtraceproc {args} {

+       upvar #0 exprtracecounter counter

+       set argc [llength $args]

+       set extraargs [lrange $args 0 [expr {$argc - 4}]]

+       set name [lindex $args [expr {$argc - 3}]]

+       upvar 1 $name var

+       if {[incr counter] % 2 == 1} {

+           set var "$counter oops [concat $extraargs]"

+       } else {

+           set var "$counter + [concat $extraargs]"

+       }

+    }

+    trace variable exprtracevar r [list exprtraceproc 10]

+    list [catch {expr "$exprtracevar + 20"} a] $a \

+        [catch {expr "$exprtracevar + 20"} b] $b \

+        [unset exprtracevar exprtracecounter]

+} {1 {syntax error in expression "1 oops 10 + 20"} 0 32 {}}

+test expr-20.3 {broken substitution of integer digits} {

+    # fails with 8.0.x, but not 8.1b2

+    list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]

+} {4096 1000}

+

 # cleanup

 unset a

Index: fCmd.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/fCmd.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 fCmd.test

--- fCmd.test   1999/03/23 00:59:20     1.1.1.1

+++ fCmd.test   1999/03/23 05:45:50

@@ -13,5 +13,7 @@

 #


-if {[string compare test [info procs test]] == 1} then {source defs}

+if {[lsearch [namespace children] ::test] == -1} {

+    source [file join [pwd] [file dirname [info script]] defs.tcl]

+}


 if {[string compare testgetplatform [info commands testgetplatform]] != 0} {

Index: fileName.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/fileName.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 fileName.test

--- fileName.test       1999/03/23 00:59:20     1.1.1.1

+++ fileName.test       1999/03/23 05:46:00

@@ -12,5 +12,7 @@

 # RCS: @(#) $Id: fileName.test,v 1.1.2.3 1999/03/11 18:49:37 hershey Exp $


-if {[string compare test [info procs test]] == 1} then {source defs}

+if {[lsearch [namespace children] ::test] == -1} {

+    source [file join [pwd] [file dirname [info script]] defs.tcl]

+}


 if {[info commands testsetplatform] == {}} {

Index: for-old.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/for-old.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 for-old.test

--- for-old.test        1999/03/23 00:59:20     1.1.1.1

+++ for-old.test        1999/03/23 05:46:06

@@ -15,5 +15,7 @@

 # RCS: @(#) $Id: for-old.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $


-if {[string compare test [info procs test]] == 1} then {source defs}

+if {[lsearch [namespace children] ::test] == -1} {

+    source [file join [pwd] [file dirname [info script]] defs.tcl]

+}


 # Check "for" and its use of continue and break.

Index: for.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/for.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 for.test

--- for.test    1999/03/23 00:59:20     1.1.1.1

+++ for.test    1999/03/23 05:44:13

@@ -12,5 +12,7 @@

 # RCS: @(#) $Id: for.test,v 1.1.2.3 1999/03/11 18:49:38 hershey Exp $


-if {[string compare test [info procs test]] == 1} then {source defs}

+if {[lsearch [namespace children] ::test] == -1} {

+    source [file join [pwd] [file dirname [info script]] defs.tcl]

+}


 # Basic "for" operation.

@@ -713,4 +715,24 @@

     set a

 } {}

+

+# Test for incorrect "double evaluation" semantics

+

+test for-6.1 {possible delayed substitution of increment command} {

+    # Increment should be 5, and lappend should always append 5

+    catch {unset a}

+    catch {unset i}

+    set a 5

+    set i {}

+    for {set a 1} {$a < 12} "incr a $a" {lappend i $a}

+    set i

+} {1 6 11}

+

+test for-6.2 {possible delayed substitution of body command} {

+    # Increment should be 5, and lappend should always append 5

+    set a 5

+    set i {}

+    for {set a 1} {$a < 12} {incr a $a} "lappend i $a"

+    set i

+} {5 5 5 5}


 # cleanup

Index: foreach.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/foreach.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 foreach.test

--- foreach.test        1999/03/23 00:59:20     1.1.1.1

+++ foreach.test        1999/03/23 05:44:29

@@ -13,5 +13,7 @@

 # RCS: @(#) $Id: foreach.test,v 1.1.2.3 1999/03/11 18:49:39 hershey Exp $


-if {[string compare test [info procs test]] == 1} then {source defs}

+if {[lsearch [namespace children] ::test] == -1} {

+    source [file join [pwd] [file dirname [info script]] defs.tcl]

+}


 catch {unset a}

@@ -208,4 +210,17 @@

     set msg

 } {wrong # args: should be "break"}

+

+# Test for incorrect "double evaluation" semantics

+

+test foreach-6.1 {delayed substitution of body} {

+    proc foo {} {

+       set a 0

+       foreach a [list 1 2 3] "

+           set x $a

+       "

+       set x

+    }

+    foo

+} {0}


 # cleanup

Index: format.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/format.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 format.test

--- format.test 1999/03/23 00:59:20     1.1.1.1

+++ format.test 1999/03/23 05:46:19

@@ -13,6 +13,6 @@

 # RCS: @(#) $Id: format.test,v 1.1.2.4 1999/03/11 18:49:39 hershey Exp $


-if {[info commands test] != "test"} {

-    source defs

+if {[lsearch [namespace children] ::test] == -1} {

+    source [file join [pwd] [file dirname [info script]] defs.tcl]

 }


Index: if.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/if.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 if.test

--- if.test     1999/03/23 00:59:21     1.1.1.1

+++ if.test     1999/03/23 05:24:22

@@ -504,4 +504,5 @@

     list [catch {$z} msg] $msg

 } {1 {wrong # args: no expression after "if" argument}}

+

 test if-5.2 {if cmd with computed command names: error in if/elseif test} {

     set z if

@@ -1009,4 +1010,68 @@

     ::if {1} {set x 4}

 } 4

+

+# Test for incorrect "double evaluation semantics"

+

+test if-10.1 {delayed substitution of then body} {

+    set j 0

+    if {[incr j] == 1} "

+       set result $j

+    "

+    set result

+} {0}

+test if-10.2 {delayed substitution of elseif expression} {

+    set j 0

+    if {[incr j] == 0} {

+       set result badthen

+    } elseif "$j == 1" {

+       set result badelseif

+    } else {

+       set result ok

+    }

+    set result

+} {ok}

+test if-10.3 {delayed substitution of elseif body} {

+    set j 0

+    if {[incr j] == 0} {

+       set result badthen

+    } elseif {1} "

+       set result $j

+    "

+    set result

+} {0}

+test if-10.4 {delayed substitution of else body} {

+    set j 0

+    if {[incr j] == 0} {

+       set result badthen

+    } else "

+       set result $j

+    "

+    set result

+} {0}

+test if-10.5 {substituted control words} {

+    set then then; proc then {} {return badthen}

+    set else else; proc else {} {return badelse}

+    set elseif elseif; proc elseif {} {return badelseif}

+    list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a

+} {0 ok}

+test if-10.6 {double invocation of variable traces} {

+    set iftracecounter 0

+    proc iftraceproc {args} {

+       upvar #0 iftracecounter counter

+       set argc [llength $args]

+       set extraargs [lrange $args 0 [expr {$argc - 4}]]

+       set name [lindex $args [expr {$argc - 3}]]

+       upvar 1 $name var

+       if {[incr counter] % 2 == 1} {

+           set var "$counter oops [concat $extraargs]"

+       } else {

+           set var "$counter + [concat $extraargs]"

+       }

+    }

+    trace variable iftracevar r [list iftraceproc 10]

+    list [catch {if "$iftracevar + 20" {}} a] $a \

+        [catch {if "$iftracevar + 20" {}} b] $b \

+        [unset iftracevar iftracecounter]

+} {1 {syntax error in expression "1 oops 10 + 20"} 0 {} {}}


 # cleanup

Index: init.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/init.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 init.test

--- init.test   1999/03/23 00:59:21     1.1.1.1

+++ init.test   1999/03/23 05:47:18

@@ -66,5 +66,7 @@

 interp eval $testInterp {


-if {[string compare test [info procs test]] == 1} then {source defs}

+if {[lsearch [namespace children] ::test] == -1} {

+    source [file join [pwd] [file dirname [info script]] defs.tcl]

+}


 auto_reset

Index: while.test

===================================================================

RCS file: /opt/net/cvs/repository/src/tcl8/tcl/tests/while.test,v

retrieving revision 1.1.1.1

diff -u -2 -r1.1.1.1 while.test

--- while.test  1999/03/23 00:59:24     1.1.1.1

+++ while.test  1999/03/23 04:42:15

@@ -28,9 +28,10 @@

 test while-1.2 {TclCompileWhileCmd: error in test expression} {

     set i 0

-    catch {while {$i<}} msg

+    catch {while {$i<} break} msg

     set errorInfo

-} {wrong # args: should be "while test command"

+} {syntax error in expression "$i<"

+    ("while" test expression)

     while compiling

-"while {$i<}"}

+"while {$i<} break"}

 test while-1.3 {TclCompileWhileCmd: error in test expression} {

     set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]

@@ -605,4 +606,14 @@

     set a

 } {1 3}

+

+# Test for incorrect "double evaluation" semantics

+

+test while-7.1 {delayed substitution of body} {

+    set i 0

+    while {[incr i] < 10} "

+       set result $i

+    "

+    set result

+} {0}


 # cleanup



I have integrated the new tests and marked them as known bugs.  The basic problem is that the compiler is inlining bodies that are non-literal.  The simple-minded solution of out-of-line compiling all non-simple bodies would exclude many bodies that contain backslash continuation lines.  This would result in unacceptable performance problems.

So, the correct long term solution is for the parser to indicate when words contain only text and backslash substitutions and flag them as complex literals.  The compile procs can test for this case, perform the substitutions and then recurse.  This should make it possible to compile everything but truly non-literal bodies (i.e. those containing variable or command substitutions).

We should defer the fix for this problem until we start work on TclPro 1.3 so we can deal with the parser changes at the same time we are revisiting the checker and debugger implementations. - stanton
--
Related simple case in id 727 
-- 08/13/1999 hobbs
User Comments: hobbs added on 2001-09-20 01:19:41: 
Logged In: YES 
user_id=72656

applied patch to 8.4a4cvs.
hobbs added on 2001-09-12 04:24:24: 
Logged In: YES 
user_id=72656

Have you checked to ensure that the proper code path is 
getting followed in each case (with printf or 
breakpoints)?  Isn't this going to hinder something like:

for {set i 0} {$i < 1000} {incr i} [subst {
    # Do some static substitution, then run
    set $var \$i
}]

Perhaps we don't need to worry about such odd cases?
msofer added on 2001-09-07 20:31:26: 

File Added - 10487: 219166.bench

Logged In: YES 
user_id=148712

I attach benchmark results: there is no noticeable
difference, the differences are all within tclbench noise
levels. Programs in tclbench seems not to hit the
"unacceptable performance problems" mentioned above.

This is probably due to the fact that tclbench programs are
written with care; the difference would only be apparent
when expressions or bodies are not enclosed in braces.

Jeff: care to take a look?
msofer added on 2001-09-07 20:07:23: 

File Added - 10486: 219166.patch

Logged In: YES 
user_id=148712

Implemented stanton's "simple minded solution", see the
enclosed patch.
msofer added on 2001-08-22 22:16:26: 
Logged In: YES 
user_id=148712

The reference for id 727 is [Bug #217782]

Attachments:

This page was generated in about 0.013s by Fossil 2.25 [2ba99c273b] 2024-05-21 11:18:46