# Test what happens if we try to get something that does not exist

package require turbine 0.0.1
adlb::init 1 1

if [ adlb::amserver ] {
    adlb::server
} else {
    set z  0
    set d0 [ adlb::unique ]
    set d1 [ adlb::unique ]
    adlb::create $d1 integer
    set d2 [ adlb::unique ]
    adlb::create $d2 integer
    adlb::store $d2 integer:25
    set d3 [ adlb::unique ]
    adlb::create $d3 integer
    adlb::store $d3 integer:35
    adlb::close $d3
    set L [ list $z $d0 $d1 $d2 $d3 ]
    foreach d $L {
        if { [ adlb::exists $d ] } {
            puts "exists: $d"
        } else {
            puts "nope: $d"
        }
    }
}

adlb::finalize
puts OK

Switch test to use new adlb::store

# Test what happens if we try to get something that does not exist

package require turbine 0.0.1
adlb::init 1 1

if [ adlb::amserver ] {
    adlb::server
} else {
    set z  0
    set d0 [ adlb::unique ]
    set d1 [ adlb::unique ]
    adlb::create $d1 integer
    set d2 [ adlb::unique ]
    adlb::create $d2 integer
    adlb::store $d2 $adlb::INTEGER 25
    set d3 [ adlb::unique ]
    adlb::create $d3 integer
    adlb::store $d3 $adlb::INTEGER 35
    adlb::close $d3
    set L [ list $z $d0 $d1 $d2 $d3 ]
    foreach d $L {
        if { [ adlb::exists $d ] } {
            puts "exists: $d"
        } else {
            puts "nope: $d"
        }
    }
}

adlb::finalize
puts OK


# Timing constraints for led_sreg_driver

foreach inst [get_cells -hier -filter {(ORIG_REF_NAME == led_sreg_driver || REF_NAME == led_sreg_driver)}] {
    puts "Inserting timing constraints for led_sreg_driver instance $inst"

    set select_ffs [get_cells "$inst/led_sync_reg_1_reg[*] $inst/led_sync_reg_2_reg[*]"]

    if {[llength $select_ffs]} {
        set_property ASYNC_REG TRUE $select_ffs
        set_false_path -from [all_registers] -to [get_cells "$inst/led_sync_reg_1_reg[*]"]
    }
}

Update LED driver timing constraints

# Timing constraints for led_sreg_driver

foreach inst [get_cells -hier -filter {(ORIG_REF_NAME == led_sreg_driver || REF_NAME == led_sreg_driver)}] {
    puts "Inserting timing constraints for led_sreg_driver instance $inst"

    set select_ffs [get_cells "$inst/led_sync_reg_1_reg[*] $inst/led_sync_reg_2_reg[*]"]

    if {[llength $select_ffs]} {
        set_property ASYNC_REG TRUE $select_ffs
        set_false_path -to [get_pins "$inst/led_sync_reg_1_reg[*]/D"]
    }
}


# Copyright 2020 Efabless Corporation
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

if {[catch {read_lef $::env(MERGED_LEF_UNPADDED)} errmsg]} {
    puts stderr $errmsg
    exit 1
}

if {[catch {read_def $::env(CURRENT_DEF)} errmsg]} {
    puts stderr $errmsg
    exit 1
}

set_placement_padding -global -right $::env(CELL_PAD)
detailed_placement

if { [check_placement -verbose] } {
	exit 1
}

write_def $::env(SAVE_DEF)

Exclude tap cells from detailed placement padding

# Copyright 2020 Efabless Corporation
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

if {[catch {read_lef $::env(MERGED_LEF_UNPADDED)} errmsg]} {
    puts stderr $errmsg
    exit 1
}

if {[catch {read_def $::env(CURRENT_DEF)} errmsg]} {
    puts stderr $errmsg
    exit 1
}

set_placement_padding -global -right $::env(CELL_PAD)

set_placement_padding -masters $::env(CELL_PAD_EXCLUDE) -right 0 -left 0

detailed_placement

if { [check_placement -verbose] } {
	exit 1
}

write_def $::env(SAVE_DEF)


# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0

set workroot [file dirname [info script]]

send_msg "Designcheck 1-1" INFO "Checking design"

# Ensure the design meets timing
set slack_ns [get_property SLACK [get_timing_paths -delay_type min_max]]
send_msg "Designcheck 1-2" INFO "Slack is ${slack_ns} ns."

if [expr {$slack_ns < 0}] {
  send_msg "Designcheck 1-3" ERROR "Timing failed. Slack is ${slack_ns} ns."
}

Add timestamp for bitstream identification via USR_ACCESS reg

# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0

set workroot [file dirname [info script]]

send_msg "Designcheck 1-1" INFO "Checking design"

# Ensure the design meets timing
set slack_ns [get_property SLACK [get_timing_paths -delay_type min_max]]
send_msg "Designcheck 1-2" INFO "Slack is ${slack_ns} ns."

if [expr {$slack_ns < 0}] {
  send_msg "Designcheck 1-3" ERROR "Timing failed. Slack is ${slack_ns} ns."
}

# Enable bitstream identification via USR_ACCESS register.
set_property BITSTREAM.CONFIG.USR_ACCESS TIMESTAMP [current_design]


# Minimal Yosys synthesis tcl script for the to support RTL analysis.
# It can be overriden for specific analyses.
set input_rtl $::env(INPUT_RTL)
set top $::env(CONSTANT_TOP)

puts stderr "Yosys synthesis started for module $top in $input_rtl."
yosys -import

# read design

yosys read_verilog -sv -defer $input_rtl

# generic synthesis
yosys synth -top $top

# mapping to liberty
set liberty $::env(LIBERTY)
dfflibmap -liberty $liberty

# -keepff ensures that there will be nets for the source registers
# in the netlist output, supporting further analysis
abc -liberty $liberty -dff -g aig -keepff

# write synthesized design
set output $::env(OUTPUT_NETLIST)
write_verilog $output

puts stderr "Output netlist generated in $output"

Use setundef to remove randomness from Yosys output

# Minimal Yosys synthesis tcl script for the to support RTL analysis.
# It can be overriden for specific analyses.
set input_rtl $::env(INPUT_RTL)
set top $::env(CONSTANT_TOP)

puts stderr "Yosys synthesis started for module $top in $input_rtl."
yosys -import

# read design

yosys read_verilog -sv -defer $input_rtl

# generic synthesis
yosys synth -top $top
setundef -zero

# mapping to liberty
set liberty $::env(LIBERTY)
dfflibmap -liberty $liberty

# -keepff ensures that there will be nets for the source registers
# in the netlist output, supporting further analysis
abc -liberty $liberty -dff -g aig -keepff

# write synthesized design
set output $::env(OUTPUT_NETLIST)
write_verilog $output

puts stderr "Output netlist generated in $output"


set f [open "highwire-journal-list.txt" "r"]
set body [join [split [read $f] "\n"] "|"]
set body [regsub -all {\.} $body {\\.}]
puts "http://($body)/cgi(/|/content/)(abstract|extract|full|refs|reprint|screenpdf|summary)\[A-Za-z0-9.-/\]+"

Sort out posting from PNAS abstract page.

set f [open "highwire-journal-list.txt" "r"]
set body [join [split [read $f] "\n"] "|"]
set body [regsub -all {\.} $body {\\.}]
puts "http://($body)/cgi(/|/content/)(abstract|short|extract|full|refs|reprint|screenpdf|summary)\[A-Za-z0-9.-/\]+"


# append multiple displaced spheres into an RGB image.
catch {load vtktcl}
source vtkImageInclude.tcl

# Image pipeline

vtkImageEllipsoidSource sphere1
sphere1 SetCenter 95 100 0
sphere1 SetRadius 70 70 70

vtkImageEllipsoidSource sphere2
sphere2 SetCenter 161 100 0
sphere2 SetRadius 70 70 70

vtkImageEllipsoidSource sphere3
sphere3 SetCenter 128 160 0
sphere3 SetRadius 70 70 70

vtkImageAppendComponents append
append AddInput [sphere1 GetOutput]
append AddInput [sphere2 GetOutput]
append AddInput [sphere3 GetOutput]

vtkImageViewer viewer
viewer SetInput [append GetOutput]
viewer SetColorWindow 255
viewer SetColorLevel 127.5

# make interface
source WindowLevelInterface.tcl

Order of RGB in test did not match regression valid image

# append multiple displaced spheres into an RGB image.
catch {load vtktcl}
source vtkImageInclude.tcl

# Image pipeline

vtkImageEllipsoidSource sphere1
sphere1 SetCenter 95 100 0
sphere1 SetRadius 70 70 70

vtkImageEllipsoidSource sphere2
sphere2 SetCenter 161 100 0
sphere2 SetRadius 70 70 70

vtkImageEllipsoidSource sphere3
sphere3 SetCenter 128 160 0
sphere3 SetRadius 70 70 70

vtkImageAppendComponents append
append AddInput [sphere3 GetOutput]
append AddInput [sphere1 GetOutput]
append AddInput [sphere2 GetOutput]

vtkImageViewer viewer
viewer SetInput [append GetOutput]
viewer SetColorWindow 255
viewer SetColorLevel 127.5

# make interface
source WindowLevelInterface.tcl


# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0

set workroot [file dirname [info script]]

send_msg "Designcheck 1-1" INFO "Checking design"

# Ensure the design meets timing
set slack_ns [get_property SLACK [get_timing_paths -delay_type min_max]]
send_msg "Designcheck 1-2" INFO "Slack is ${slack_ns} ns."

if [expr {$slack_ns < 0}] {
  send_msg "Designcheck 1-3" ERROR "Timing failed. Slack is ${slack_ns} ns."
}

Create bitstreams with failing timing

# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0

set workroot [file dirname [info script]]

send_msg "Designcheck 1-1" INFO "Checking design"

# Ensure the design meets timing
set slack_ns [get_property SLACK [get_timing_paths -delay_type min_max]]
send_msg "Designcheck 1-2" INFO "Slack is ${slack_ns} ns."

if [expr {$slack_ns < 0}] {
  # TODO: Make this check an ERROR again as soon as we have fixed our timing,
  # see https://github.com/lowRISC/opentitan/issues/2508.
  send_msg "Designcheck 1-3" WARNING "Timing failed. Slack is ${slack_ns} ns."
}


# Copyright 2013 University of Chicago and Argonne National Laboratory
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License

# This file is expected to be regularly edited to control
# debugging output.  It is sourced by debug-auto.tcl
# The variable INPUT is converted to an array by debug-auto.tcl
# Each token maps to ON or OFF to indicate debugging

set INPUT {
    TURBINE ON
    TCL_TURBINE ON
    ADLB OFF
    CACHE OFF
}

Revert accidental debug tokens change

# Copyright 2013 University of Chicago and Argonne National Laboratory
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License

# This file is expected to be regularly edited to control
# debugging output.  It is sourced by debug-auto.tcl
# The variable INPUT is converted to an array by debug-auto.tcl
# Each token maps to ON or OFF to indicate debugging

set INPUT {
    TURBINE OFF
    TCL_TURBINE OFF
    ADLB OFF
    CACHE OFF
}


# global port routines
# the 'main' target is provided by this package
# main is a magic target and should not be replaced
package provide portmain 1.0
package require portutil 1.0

register_target main portmain::main
namespace eval portmain {
	variable options
	variable targets
}

# define globals: portname portversion categories maintainers
globals portmain::options portname portversion portrevision categories maintainers workdir worksrc no_worksubdir

# define options: portname, portversion, categories, maintainers
options portmain::options portname portversion portrevision categories maintainers workdir worksrc no_worksubdir

proc portmain::main {args} {
	global portname
	default portmain::options workdir work
	return 0
}

Add filesdir global and option

# global port routines
# the 'main' target is provided by this package
# main is a magic target and should not be replaced
package provide portmain 1.0
package require portutil 1.0

register_target main portmain::main
namespace eval portmain {
	variable options
	variable targets
}

# define globals: portname portversion categories maintainers
globals portmain::options portname portversion portrevision categories maintainers workdir worksrc no_worksubdir filesdir

# define options: portname, portversion, categories, maintainers
options portmain::options portname portversion portrevision categories maintainers workdir worksrc no_worksubdir filesdir

proc portmain::main {args} {
	global portname
	default portmain::options workdir work
	default portmain::options filesdir files
	return 0
}


# MPE FEATURES

namespace eval turbine {

    # Set by mpe_setup
    variable mpe_ready

    # MPE event IDs
    variable event

    proc mpe_setup { } {

        variable mpe_ready
        variable event
        set event_names [ list metadata ]
        # debug set1 set1rA set1rB sum

        if { ! [ info exists mpe_ready ] } {

            foreach e $event_names {
                set L [ mpe::create $e ]
                set event(start_$e) [ lindex $L 0 ]
                set event(stop_$e)  [ lindex $L 1 ]
            }
            set mpe_ready 1
        }
    }

    # Add an arbitrary string to the MPE log as "metadata"
    # The string length limit is 32
    proc metadata { stack result input } {
        turbine::rule "metadata-$input" $input $turbine::WORK \
            "turbine::metadata_body $input"
    }

    proc metadata_body { message } {

        variable event
        mpe_setup

        set message_value [ turbine::retrieve_string $message ]
        mpe::log $event(start_metadata) "$message_value"
    }
}

Use solo event for turbine::metadata

# MPE FEATURES

namespace eval turbine {

    # Set by mpe_setup
    variable mpe_ready

    # MPE event ID
    variable event

    proc mpe_setup { } {

        variable mpe_ready
        variable event

        if { ! [ info exists mpe_ready ] } {
            set event [ mpe::create_solo "metadata" ]
            set mpe_ready 1
            puts "metadata event ID: $event"
        }
    }

    # Add an arbitrary string to the MPE log as "metadata"
    # The string length limit is 32
    proc metadata { stack result input } {
        turbine::rule "metadata-$input" $input $turbine::WORK \
            "turbine::metadata_body $input"
    }

    proc metadata_body { message } {

        variable event
        mpe_setup

        set message_value [ turbine::retrieve_string $message ]
        mpe::log $event "$message_value"
    }
}


# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0

# get installation path of ascentlint
set RI_INSTALL [file dirname [exec which ascentlint]]

# source the policy file containing the lowrisc lint rules
source "$RI_INSTALL/../Ascent/Lint/lib/policies/lowRISC/LRLR-v1.0.policy"

Increase threshold for max number of bits in an array

# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0

# get installation path of ascentlint
set RI_INSTALL [file dirname [exec which ascentlint]]

# source the policy file containing the lowrisc lint rules
source "$RI_INSTALL/../Ascent/Lint/lib/policies/lowRISC/LRLR-v1.0.policy"

# increase this from 8k (default) to 32k such that large arrays like
# regfiles can be analyzed and linted.
set ri_max_total_range_bits 32768
set ri_max_single_range_bits 32768


package provide funcs_5697 0.5

namespace eval funcs_5697 {
  package require turbine 0.3.0
  namespace import ::turbine::*

  proc copy_url5 { outputs inputs } {
    puts [ list Entering copy_url5 $outputs $inputs ]
    set outurl [ lindex $outputs 0 ]
    set inurl [ lindex $inputs 0 ]

    rule [ list [ get_file_status $inurl ] [ get_file_path $outurl ] ] \
         [ list funcs_5697::copy_url5_body $outurl $inurl ]
  }

  proc copy_url5_body { outurl inurl  } {
    puts [ list Entering copy_url5_body $outurl $inurl ]
    read_refcount_decr [ get_file_status $inurl ]
    set outpath [ retrieve_string [ get_file_path $outurl ] ]
    set inpath [ retrieve_decr_string [ get_file_path $inurl ] ]

    copy_url5_impl $inpath $outpath
    store_void [ get_file_status $outurl ]
  }

  proc copy_url5_impl { inpath outpath } {
    puts [ list Entering copy_url5_impl $outpath $inpath ]
    puts [ list copy_url5 $inpath $outpath ]
  }
}

Fix tcl code for URL test

package provide funcs_5697 0.5

namespace eval funcs_5697 {
  package require turbine 0.3.0
  namespace import ::turbine::*

  proc copy_url5 { outputs inputs } {
    puts [ list Entering copy_url5 $outputs $inputs ]
    set outurl [ lindex $outputs 0 ]
    set inurl [ lindex $inputs 0 ]

    rule [ list [ get_file_status $inurl ] [ get_file_path $outurl ] ] \
         [ list funcs_5697::copy_url5_body $outurl $inurl ]
  }

  proc copy_url5_body { outurl inurl  } {
    puts [ list Entering copy_url5_body $outurl $inurl ]
    set outpath [ retrieve_string [ get_file_path $outurl ] ]
    set inpath [ retrieve_decr_string [ get_file_path $inurl ] ]

    copy_url5_impl $inpath $outpath
    turbine::close_file $outurl
  }

  proc copy_url5_impl { inpath outpath } {
    puts [ list Entering copy_url5_impl $outpath $inpath ]
    puts [ list copy_url5 $inpath $outpath ]
  }
}


package require Tcl 8.5
package require tcltest 2

# Use the tests directory as the working directory for all tests.
::tcltest::workingDirectory [file dirname [info script]]

# Stow any temporary test files in the tmp subdirectory.
# runAllTests should only look here, in the tests directory, for tests.
# It should not bother looking for tests in the tmp subdirectory.
# Files that end in .test.tcl (excepting any lock files) contain tests.
::tcltest::configure -tmpdir tmp -testdir [::tcltest::workingDirectory] -asidefromdir {tmp sample} -file {*.test.tcl} -notfile {l.*.test.tcl}

# Apply any additional configuration arguments.
eval ::tcltest::configure $argv

# Perform the tests.
::tcltest::runAllTests

Configure test output to be more verbose runAllTest blarfs config info anyway, so might as well include more informative test progress messages.

package require Tcl 8.5
package require tcltest 2

# Use the tests directory as the working directory for all tests.
::tcltest::workingDirectory [file dirname [info script]]

# Stow any temporary test files in the tmp subdirectory.
# runAllTests should only look here, in the tests directory, for tests.
# It should not bother looking for tests in the tmp subdirectory.
# Files that end in .test.tcl (excepting any lock files) contain tests.
::tcltest::configure \
		-tmpdir tmp \
		-testdir [::tcltest::workingDirectory] \
		-asidefromdir {tmp sample} \
		-file {*.test.tcl} \
		-notfile {l.*.test.tcl} \
		-verbose {body pass skip error}

# Apply any additional configuration arguments.
eval ::tcltest::configure $argv

# Perform the tests.
::tcltest::runAllTests


# Turbine data abstraction layer

namespace eval turbine {

    namespace export                      \
        string_init string_set string_get \
        file_init   file_set   file_get

    proc string_init { id } {
        adlb::create $id "string:"
        turbine::c::declare $id
    }

    proc string_set { id value } {
        close_dataset $id "string:$value"
    }

    proc string_get { id } {
        puts "get $id"
        set s [ adlb::retrieve $id ]
        set i [ string first : $s ]
        set result [ string range $s $i end ]
        return $result
    }

    proc file_init { id path } {
        adlb::create $id "file:$path"
        turbine::c::declare $id
    }

    proc file_set { id } {
        close_dataset $id "file:close"
    }

    proc file_get { id } {
        puts "get $id"
        set s [ adlb::retrieve $id ]
        set i [ file first : $s ]
        set result [ file range $s $i end ]
        return $result
    }

    proc close_dataset { id value } {
        global WORK_TYPE
        adlb::store $id $value
        set ranks [ adlb::close $id ]
        foreach rank $ranks {
            puts "notify: $rank"
            adlb::put $rank $WORK_TYPE(CONTROL) "close $id"
        }
    }
}

Rename file_get{} to filename{} and fix

# Turbine data abstraction layer

namespace eval turbine {

    namespace export                      \
        string_init string_set string_get \
        file_init   file_set   filename

    proc string_init { id } {
        adlb::create $id "string:"
        turbine::c::declare $id
    }

    proc string_set { id value } {
        close_dataset $id "string:$value"
    }

    proc string_get { id } {
        puts "get $id"
        set s [ adlb::retrieve $id ]
        set i [ string first : $s ]
        set result [ string range $s $i end ]
        return $result
    }

    proc file_init { id path } {
        adlb::create $id "file:$path"
        turbine::c::declare $id
    }

    proc file_set { id } {
        close_dataset $id "file:close"
    }

    proc filename { id } {
        debug "filename($id)"
        set s [ adlb::retrieve $id ]
        set i [ string first : $s ]
        set i [ expr $i + 1 ]
        set result [ string range $s $i end ]
        return $result
    }

    proc close_dataset { id value } {
        global WORK_TYPE
        adlb::store $id $value
        set ranks [ adlb::close $id ]
        foreach rank $ranks {
            puts "notify: $rank"
            adlb::put $rank $WORK_TYPE(CONTROL) "close $id"
        }
    }
}


#----------------------------------------------------------------------------
# $Id$
#
# PLplot TK demos
#
# Maurice LeBrun
# IFS, University of Texas at Austin
# 26-Jan-1995
#
# To plot these, start up plserver.  Type "source tkdemos.tcl", at which
# point a plframe extended widget is created.  Then type "1" for the first
# demo, "2" for the second, and so on.
#
# Note: each demo proc is supplied a widget argument if run from a widget,
# or "loopback" if being run from pltcl.  In the latter case, the
# "loopback cmd" does nothing, but is required two make the two styles of
# Tcl scripts compatible.
#----------------------------------------------------------------------------

plstdwin .
plxframe .plw
pack append . .plw {left expand fill}

for {set i 1} {$i <= 31} {incr i} {
    set demo x[format "%02d" $i]
    source $demo.tcl
    proc $i {} "$demo .plw.plwin"
}

Exclude example 31 from this script since it does not work well under plserver and for that reason x31.tcl is normally not copied to the tk directory.

#----------------------------------------------------------------------------
# $Id$
#
# PLplot TK demos
#
# Maurice LeBrun
# IFS, University of Texas at Austin
# 26-Jan-1995
#
# To plot these, start up plserver.  Type "source tkdemos.tcl", at which
# point a plframe extended widget is created.  Then type "1" for the first
# demo, "2" for the second, and so on.
#
# Note: each demo proc is supplied a widget argument if run from a widget,
# or "loopback" if being run from pltcl.  In the latter case, the
# "loopback cmd" does nothing, but is required two make the two styles of
# Tcl scripts compatible.
#----------------------------------------------------------------------------

plstdwin .
plxframe .plw
pack append . .plw {left expand fill}

# Exclude 31 because it does not work well in this context and because
# the required x31.tcl is normally not copied to the tk directory in any case.
for {set i 1} {$i <= 30} {incr i} {
    set demo x[format "%02d" $i]
    source $demo.tcl
    proc $i {} "$demo .plw.plwin"
}


package provide spec 0.1

package require XOTcl 2.0
package require at_exit
package require try

namespace eval Spec {
    namespace import ::xotcl::*
    namespace import ::tcl::control::*
    namespace import ::at_exit::*
}

source [file join [file dirname [info script]] "dsl.tcl"]
source [file join [file dirname [info script]] "example.tcl"]
source [file join [file dirname [info script]] "example_group.tcl"]
source [file join [file dirname [info script]] "expectation_handler.tcl"]
source [file join [file dirname [info script]] "matchers.tcl"]
source [file join [file dirname [info script]] "reporter.tcl"]
source [file join [file dirname [info script]] "runner.tcl"]
source [file join [file dirname [info script]] "world.tcl"]

nx::Class create Spec {
    :require namespace
    :class property [list world [::Spec::World new]]
}

Remove all references to XOTcl and require the NX package instead.

package provide spec 0.1

package require nx
package require at_exit
package require try

namespace eval Spec {
    namespace import ::tcl::control::*
    namespace import ::at_exit::*
}

source [file join [file dirname [info script]] "dsl.tcl"]
source [file join [file dirname [info script]] "example.tcl"]
source [file join [file dirname [info script]] "example_group.tcl"]
source [file join [file dirname [info script]] "expectation_handler.tcl"]
source [file join [file dirname [info script]] "matchers.tcl"]
source [file join [file dirname [info script]] "reporter.tcl"]
source [file join [file dirname [info script]] "runner.tcl"]
source [file join [file dirname [info script]] "world.tcl"]

nx::Class create Spec {
    :require namespace
    :class property [list world [::Spec::World new]]
}


# Copyright 2013 University of Chicago and Argonne National Laboratory
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License

# Does nothing
# Nice to have for quick experiments

package require turbine 0.0.1

# No rules
proc rules { } {
  set s [ groovy::eval "println \"HOWDY1\"" "\"OKAY\"" ]
  puts $s
}

turbine::defaults
turbine::init $servers "Swift"
turbine::start rules

turbine::finalize

puts OK

proc exit args {}

Use println to get the result back in Tcl

# Copyright 2013 University of Chicago and Argonne National Laboratory
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License

# Does nothing
# Nice to have for quick experiments

package require turbine 0.0.1

# No rules
proc rules { } {
  set s [ groovy::eval "println \"HOWDY1\"" "println \"HOWDY2\"" ]
  puts $s
}

turbine::defaults
turbine::init $servers "Swift"
turbine::start rules

turbine::finalize

puts OK

proc exit args {}


# Loads secondary packages not directly required by BootManager

if {$PLATFORM == "WINDOWS"} {
  source tcllib/aes/aes.tcl
  source tcllib/sha1/sha256.tcl
}

package require http
package require tls
package require aes
package require sha256

source tcl/lssinfo.tcl

Add missing "package require uuid".

# Loads secondary packages not directly required by BootManager

if {$PLATFORM == "WINDOWS"} {
  source tcllib/aes/aes.tcl
  source tcllib/sha1/sha256.tcl
}

package require http
package require tls
package require aes
package require sha256
package require uuid

source tcl/lssinfo.tcl


source "../tests/includes/init-tests.tcl"

proc cluster_allocate_mixedSlots {n} {
    set slot 16383
    while {$slot >= 0} {
        set node [expr {$slot % $n}]
        lappend slots_$node $slot
        incr slot -1
    }
    for {set j 0} {$j < $n} {incr j} {
        R $j cluster addslots {*}[set slots_${j}]
    }
}

proc create_cluster_with_mixedSlot {masters slaves} {
    cluster_allocate_mixedSlots $masters
    if {$slaves} {
        cluster_allocate_slaves $masters $slaves
    }
    assert_cluster_state ok
}

test "Create a 5 nodes cluster" {
    create_cluster_with_mixedSlot 5 15
}

test "Cluster is up" {
    assert_cluster_state ok
}

test "Cluster is writable" {
    cluster_write_test 0
}

test "Instance #5 is a slave" {
    assert {[RI 5 role] eq {slave}}
}

test "client do not break when cluster slot" {
    R 0 config set client-output-buffer-limit "normal 33554432 16777216 60"
    if { [catch {R 0 cluster slots}] } {
        fail "output overflow when cluster slots"
    }
}

Add a test to prove current tcl cluster client can not handle keys with hash tag.

source "../tests/includes/init-tests.tcl"

proc cluster_allocate_mixedSlots {n} {
    set slot 16383
    while {$slot >= 0} {
        set node [expr {$slot % $n}]
        lappend slots_$node $slot
        incr slot -1
    }
    for {set j 0} {$j < $n} {incr j} {
        R $j cluster addslots {*}[set slots_${j}]
    }
}

proc create_cluster_with_mixedSlot {masters slaves} {
    cluster_allocate_mixedSlots $masters
    if {$slaves} {
        cluster_allocate_slaves $masters $slaves
    }
    assert_cluster_state ok
}

test "Create a 5 nodes cluster" {
    create_cluster_with_mixedSlot 5 15
}

test "Cluster is up" {
    assert_cluster_state ok
}

test "Cluster is writable" {
    cluster_write_test 0
}

test "Instance #5 is a slave" {
    assert {[RI 5 role] eq {slave}}
}

test "client do not break when cluster slot" {
    R 0 config set client-output-buffer-limit "normal 33554432 16777216 60"
    if { [catch {R 0 cluster slots}] } {
        fail "output overflow when cluster slots"
    }
}

test "client can handle keys with hash tag" {
    set cluster [redis_cluster 127.0.0.1:[get_instance_attrib redis 0 port]]
    $cluster set foo{tag} bar
    $cluster close
}


#!/usr/bin/tclsh
# /etc/ports.conf options
package provide darwinports 1.0

namespace eval darwinports {
	proc portpath {args} {
		global portpath
		set portpath $args
	}

	proc distpath {args} {
		global distpath
		set distpath $args
	}

	proc readconf {args} {
		global portpath distpath
		if [file isfile /etc/ports.conf] {
			source /etc/ports.conf
		}
	}

	proc init {args} {
		global portpath distpath libpath auto_path
		# Defaults

		set portpath /usr/darwinports
		darwinports::readconf
		set distpath $portpath/distfiles
		set libpath ${portpath}/Tcl

		if [file isdirectory $libpath] {
			if [catch {pkg_mkIndex $libpath *.tcl *.so *.dylib */*.tcl */*.so */*.dylib} result] {
				return -1
			} else {
				lappend auto_path $libpath
			}
		} else {
			return -1
		}
		return 0
	}
}

Set variables if they are not already set

#!/usr/bin/tclsh
# /etc/ports.conf options
package provide darwinports 1.0

namespace eval darwinports {
	proc portpath {args} {
		global portpath
		set portpath $args
	}

	proc distpath {args} {
		global distpath
		set distpath $args
	}

	proc readconf {args} {
		global portpath distpath
		if [file isfile /etc/ports.conf] {
			source /etc/ports.conf
		}
	}

	proc init {args} {
		global portpath distpath libpath auto_path
		# Defaults

		set portpath /usr/darwinports
		darwinports::readconf
		if ![info exists distpath] {
			set distpath $portpath/distfiles
		}
		if ![info exists libpath] {
			set libpath $portpath/Tcl
		}

		if [file isdirectory $libpath] {
			if [catch {pkg_mkIndex $libpath *.tcl *.so *.dylib */*.tcl */*.so */*.dylib} result] {
				return -1
			} else {
				lappend auto_path $libpath
			}
		} else {
			return -1
		}
		return 0
	}
}


create_project -force -part $::env(XRAY_PART) design design
set_property design_mode PinPlanning [current_fileset]
open_io_design -name io_1

set fp [open $::env(XRAY_PART)_package_pins.csv w]
puts $fp "pin,site,tile"
foreach pin [get_package_pins] {
    set site [get_sites -quiet -of_object $pin]
    if { $site == "" } {
        continue
    }

    set tile [get_tiles -of_object $site]

    puts $fp "$pin,$site,$tile"
}

Add pin functions column to package pins output.

create_project -force -part $::env(XRAY_PART) design design
set_property design_mode PinPlanning [current_fileset]
open_io_design -name io_1

set fp [open $::env(XRAY_PART)_package_pins.csv w]
puts $fp "pin,site,tile,pin_function"
foreach pin [get_package_pins] {
    set site [get_sites -quiet -of_object $pin]
    if { $site == "" } {
        continue
    }

    set tile [get_tiles -of_object $site]
    set pin_function [get_property PIN_FUNC [get_package_pins E18]]

    puts $fp "$pin,$site,$tile,$pin_function"
}


proc test_memory_efficiency {range} {
    r flushall
    set base_mem [s used_memory]
    set written 0
    for {set j 0} {$j < 10000} {incr j} {
        set key key:$j
        set val [string repeat A [expr {int(rand()*$range)}]]
        r set $key $val
        incr written [string length $key]
        incr written [string length $val]
        incr written 2 ;# A separator is the minimum to store key-value data.
    }
    set current_mem [s used_memory]
    set used [expr {$current_mem-$base_mem}]
    set efficiency [expr {double($written)/$used}]
    return $efficiency
}

start_server {tags {"memefficiency"}} {
    foreach {size_range expected_min_efficiency} {
        32    0.15
        64    0.25
        128   0.35
        1024  0.75
        16384 0.90
    } {
        test "Memory efficiency with values in range $size_range" {
            set efficiency [test_memory_efficiency $size_range]
            assert {$efficiency >= $expected_min_efficiency}
        }
    }
}

Fix false positive in memory efficiency test.

proc test_memory_efficiency {range} {
    r flushall
    set base_mem [s used_memory]
    set written 0
    for {set j 0} {$j < 10000} {incr j} {
        set key key:$j
        set val [string repeat A [expr {int(rand()*$range)}]]
        r set $key $val
        incr written [string length $key]
        incr written [string length $val]
        incr written 2 ;# A separator is the minimum to store key-value data.
    }
    set current_mem [s used_memory]
    set used [expr {$current_mem-$base_mem}]
    set efficiency [expr {double($written)/$used}]
    return $efficiency
}

start_server {tags {"memefficiency"}} {
    foreach {size_range expected_min_efficiency} {
        32    0.15
        64    0.25
        128   0.35
        1024  0.75
        16384 0.82
    } {
        test "Memory efficiency with values in range $size_range" {
            set efficiency [test_memory_efficiency $size_range]
            assert {$efficiency >= $expected_min_efficiency}
        }
    }
}


catch {load vtktcl}
# user interface command widget
source ../../examplesTcl/vtkInt.tcl

# create a rendering window and renderer
vtkRenderer ren1
vtkRenderWindow renWin
    renWin AddRenderer ren1
vtkRenderWindowInteractor iren
    iren SetRenderWindow renWin

# create an actor and give it cone geometry
vtkConeSource cone
  cone SetResolution 8
vtkPolyDataMapper coneMapper
  coneMapper SetInput [cone GetOutput]
vtkActor coneActor
  coneActor SetMapper coneMapper

# assign our actor to the renderer
ren1 AddActor coneActor

# enable user interface interactor
iren SetUserMethod {wm deiconify .vtkInteract}
iren Initialize

# prevent the tk window from showing up then start the event loop
wm withdraw .

Change script to request a stereo capable window.

catch {load vtktcl}
# user interface command widget
source ../../examplesTcl/vtkInt.tcl

# create a rendering window and renderer
vtkRenderer ren1
vtkRenderWindow renWin
    renWin AddRenderer ren1
    renWin StereoCapableWindowOn
vtkRenderWindowInteractor iren
    iren SetRenderWindow renWin

# create an actor and give it cone geometry
vtkConeSource cone
  cone SetResolution 8
vtkPolyDataMapper coneMapper
  coneMapper SetInput [cone GetOutput]
vtkActor coneActor
  coneActor SetMapper coneMapper

# assign our actor to the renderer
ren1 AddActor coneActor

# enable user interface interactor
iren SetUserMethod {wm deiconify .vtkInteract}
iren Initialize

# prevent the tk window from showing up then start the event loop
wm withdraw .


yosys -import

synth_ice40 -nocarry

# opt_expr -undriven makes sure all nets are driven, if only by the $undef
# net.
opt_expr -undriven
opt_clean

setundef -zero -params
write_json $::env(OUT_JSON)
write_verilog $::env(OUT_SYNTH_V)

Remove hdlname from ice40 until VPR with blifparser updated is created.

yosys -import

synth_ice40 -nocarry

# opt_expr -undriven makes sure all nets are driven, if only by the $undef
# net.
opt_expr -undriven
opt_clean

# TODO: remove this as soon as new VTR master+wip is pushed: https://github.com/SymbiFlow/vtr-verilog-to-routing/pull/525
attrmap -remove hdlname

setundef -zero -params
write_json $::env(OUT_JSON)
write_verilog $::env(OUT_SYNTH_V)


# Test ADLB store/retrieve
# Does not use Turbine features

package require turbine 0.0.1

namespace import turbine::string_*

turbine::init $env(TURBINE_ENGINES) $env(ADLB_SERVERS)

if { ! [ adlb::amserver ] } {

    set count 10
    if { [ info exists env(COUNT) ] > 0 } {
        set count $env(COUNT)
    }

    set size [ adlb::size ]
    set rank [ adlb::rank ]
    if { $rank == 0 } {
        puts "COUNT: $count"
    }

    # puts "MPI size: $size"
    for { set i $rank } { $i <= $count } { incr i $size } {
        adlb::create $i string:
        adlb::store $i string:data
    }
} else {
    adlb::server
}

turbine::finalize

puts OK

Fix test: data id=0 is ADLB_DATA_ID_NULL

# Test ADLB store/retrieve
# Does not use Turbine features

package require turbine 0.0.1

namespace import turbine::string_*

turbine::init $env(TURBINE_ENGINES) $env(ADLB_SERVERS)

if { ! [ adlb::amserver ] } {

    set count 10
    if { [ info exists env(COUNT) ] > 0 } {
        set count $env(COUNT)
    }

    set size [ adlb::size ]
    set rank [ adlb::rank ]
    if { $rank == 0 } {
        puts "COUNT: $count"
    }

    # puts "MPI size: $size"
    set r [ expr $rank + 1 ]
    for { set i $r } { $i <= $count } { incr i $size } {
        adlb::create $i string:
        adlb::store $i string:data
    }
} else {
    adlb::server
}

turbine::finalize

puts OK


package require vtk

# Image pipeline

vtkImageReader2Factory createReader
set reader [createReader CreateImageReader2 "$VTK_DATA_ROOT/Data/libtiff/test.tif"]
$reader SetFileName "$VTK_DATA_ROOT/Data/libtiff/test.tif"

vtkImageViewer viewer
viewer SetInput [$reader GetOutput]
viewer SetColorWindow 256
viewer SetColorLevel 127.5

#make interface
viewer Render

Fix the test for tiff reader to use same image as jpeg test

package require vtk

# Image pipeline

vtkImageReader2Factory createReader
set reader [createReader CreateImageReader2 "$VTK_DATA_ROOT/Data/beach.tif"]
$reader SetFileName "$VTK_DATA_ROOT/Data/beach.tif"

vtkImageViewer viewer
viewer SetInput [$reader GetOutput]
viewer SetColorWindow 256
viewer SetColorLevel 127.5

#make interface
viewer Render


### Main program for bundle

# Remove -psn_* from ::argv, if present. You get this when invoked
# via the Finder.
if {[regexp {^-psn_} [lindex $argv end]]} {
	set argv [lrange $argv 0 end-1]
	incr argc -1
}

if {[info exists env(BK_GUI)]} {
	# we're being called from BitKeeper, pass through any args and
	# source the real script
	set script [lindex $argv 0]
	set argv [lrange $argv 1 end]
	incr argc -1
	source $script
} else {
	# they opened the bundle ('open BitKeeper.app' or double-click)
	wm withdraw .
	set bkpath [file join \
		{*}[lrange [file split [info script]] 0 end-2] \
		bitkeeper]
	set bk [file join $bkpath bk]
	# Need to append our path at the beginning of PATH and init BK_BIN
	# since we're not being launched from bk
	set env(BK_BIN) $bkpath
	set env(PATH) "${bkpath}:$env(PATH)"
	set script [file join $bkpath gui lib gui]
	if {[file exists $script]} {
		# this is a bk-explorer-enabled tree, just run that
		cd $env(HOME)
		source $script
	} else {
		exec open http://bitkeeper.com/start
	}
}

Fix calling `bk wish` on OS X so that it doesn't launch a web browser.

### Main program for bundle

# Remove -psn_* from ::argv, if present. You get this when invoked
# via the Finder.
set launched_from_bundle 0
if {[regexp {^-psn_} [lindex $argv end]]} {
	set launched_from_bundle 1
	set argv [lrange $argv 0 end-1]
	incr argc -1
}

if {[info exists env(BK_GUI)] || !$launched_from_bundle} {
	# we're being called from BitKeeper, pass through any args and
	# source the real script
	if {[llength $argv]} {
	    set script [lindex $argv 0]
	    set argv [lrange $argv 1 end]
	    incr argc -1
	    source $script
	} else {
	    package require tkcon
	    tkcon show
	}
} else {
	# they opened the bundle ('open BitKeeper.app' or double-click)
	wm withdraw .
	set bkpath [file join \
		{*}[lrange [file split [info script]] 0 end-2] \
		bitkeeper]
	set bk [file join $bkpath bk]
	# Need to append our path at the beginning of PATH and init BK_BIN
	# since we're not being launched from bk
	set env(BK_BIN) $bkpath
	set env(PATH) "${bkpath}:$env(PATH)"
	set script [file join $bkpath gui lib gui]
	if {[file exists $script]} {
		# this is a bk-explorer-enabled tree, just run that
		cd $env(HOME)
		source $script
	} else {
		exec open http://bitkeeper.com/start
	}
}


yosys -import

synth_ice40 -nocarry
ice40_opt -unlut
abc -lut 4
opt_clean

Integrate yosys upstream unlut change.

yosys -import

synth_ice40 -nocarry
ice40_opt
ice40_unlut
simplemap
opt
abc -lut 4
opt_clean


# Converse of acctinfo.tcl --- saves a section of abendstern.rc
# to the server.

if {"" != $::abnet::userid} {
  $ create remoterc.tmp remote
  $ add remote hud STGroup
  $ add remote control_scheme STString
  $ add remote ship_colour STArray
  $ add remote camera STGroup
  $ add remote default_share_ships STBool
  foreach c {hud control_scheme ship_colour camera
             default_share_ships} {
    confcpy remote.$c conf.$c
  }
  $ sync remote
  $ close remote
  ::abnet::putf abendstern.rc remoterc.tmp
  $state setCallback [_ A boot acctinfs] {
    expr {$::abnet::busy? 0 : 200}
  }
}

Fix remoterc.tmp not being deleted once unneeded.

# Converse of acctinfo.tcl --- saves a section of abendstern.rc
# to the server.

if {"" != $::abnet::userid} {
  $ create remoterc.tmp remote
  $ add remote hud STGroup
  $ add remote control_scheme STString
  $ add remote ship_colour STArray
  $ add remote camera STGroup
  $ add remote default_share_ships STBool
  foreach c {hud control_scheme ship_colour camera
             default_share_ships} {
    confcpy remote.$c conf.$c
  }
  $ sync remote
  $ close remote
  ::abnet::putf abendstern.rc remoterc.tmp
  $state setCallback [_ A boot acctinfs] {
    if {$::abnet::busy} {
      return 0
    } else {
      file delete remoterc.tmp
      return 200
    }
  }
}


# This file is expected to be regularly edited to control
# debugging output.  It is sourced by debug-auto.tcl
# The variable INPUT is converted to an array by debug-auto.tcl
# Each token maps to ON or OFF to indicate debugging

set INPUT {
    TURBINE OFF
    TCL_TURBINE OFF
    ADLB OFF
}

Add debug token for messages from cache

# This file is expected to be regularly edited to control
# debugging output.  It is sourced by debug-auto.tcl
# The variable INPUT is converted to an array by debug-auto.tcl
# Each token maps to ON or OFF to indicate debugging

set INPUT {
    TURBINE OFF
    TCL_TURBINE OFF
    ADLB OFF
    CACHE OFF
}


if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded t2ws 0.5 [list source [file join $dir t2ws.tcl]]
package ifneeded t2ws::template 0.3 [list source [file join $dir t2ws_template.tcl]]
package ifneeded t2ws::bauth 0.1 [list source [file join $dir t2ws_bauth.tcl]]

Package updates: t2ws, t2ws::bauth, t2ws::template

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded t2ws 0.6 [list source [file join $dir t2ws.tcl]]
package ifneeded t2ws::template 0.4 [list source [file join $dir t2ws_template.tcl]]
package ifneeded t2ws::bauth 0.2 [list source [file join $dir t2ws_bauth.tcl]]


#!/bin/sh
# \
exec tclsh "$0" ${1+"$@"}

package require textutil

proc awkread {f} {
    while {[gets $f line] >= 0} {
        set record [list]
        set line [string trim $line]
        foreach field [::textutil::splitx $line {\s+}] {
            lappend record [list %str $field]
        }
        puts $record
        puts "#"
    }
}

if {[llength $argv] > 0} {
    foreach filename $argv {
        set f [open $filename]
        awkread $f
        close $f
    }
} else {
    awkread stdin
}

Convert fields into approproate types

#!/bin/sh
# \
exec tclsh "$0" ${1+"$@"}

package require textutil

proc awkread {f} {
    while {[gets $f line] >= 0} {
        set record [list]
        set line [string trim $line]
        foreach field [::textutil::splitx $line {\s+}] {
            if {[string is entier $field]} {
                lappend record $field
            } elseif {[string is double $field]} {
                lappend record $field
            } elseif {[regexp {^(TRUE|[Tt]rue)$} $field]} {
                lappend record true
            } elseif {[regexp {^(FALSE|[Ff]alse)$} $field]} {
                lappend record false
            } else {
                lappend record [list %str $field]
            }
        }
        puts $record
        puts "#"
    }
}

if {[llength $argv] > 0} {
    foreach filename $argv {
        set f [open $filename]
        awkread $f
        close $f
    }
} else {
    awkread stdin
}


package provide spec 0.1

package require nx
package require nx::trait
package require at_exit
package require try

namespace eval Spec {
    namespace import ::tcl::control::*
    namespace import ::at_exit::*
}

source [file join [file dirname [info script]] "configuration.tcl"]
source [file join [file dirname [info script]] "dsl.tcl"]
source [file join [file dirname [info script]] "example.tcl"]
source [file join [file dirname [info script]] "example_group.tcl"]
source [file join [file dirname [info script]] "expectation_handler.tcl"]
source [file join [file dirname [info script]] "matchers.tcl"]
source [file join [file dirname [info script]] "mocks.tcl"]
source [file join [file dirname [info script]] "reporter.tcl"]
source [file join [file dirname [info script]] "runner.tcl"]
source [file join [file dirname [info script]] "world.tcl"]

nx::Class create Spec {
    :require namespace
    :class property [list world [::Spec::World new]]
    :class property [list configuration [Spec::Configuration new]]

    :public class method configure { block } {
        uplevel [list apply $block ${:configuration}]
    }
}

Add a helper method that allows loading dependencies only once.

package provide spec 0.1

package require nx
package require nx::trait
package require at_exit
package require try

namespace eval Spec {
    namespace import ::tcl::control::*
    namespace import ::at_exit::*
}

source [file join [file dirname [info script]] "configuration.tcl"]
source [file join [file dirname [info script]] "dsl.tcl"]
source [file join [file dirname [info script]] "example.tcl"]
source [file join [file dirname [info script]] "example_group.tcl"]
source [file join [file dirname [info script]] "expectation_handler.tcl"]
source [file join [file dirname [info script]] "matchers.tcl"]
source [file join [file dirname [info script]] "mocks.tcl"]
source [file join [file dirname [info script]] "reporter.tcl"]
source [file join [file dirname [info script]] "runner.tcl"]
source [file join [file dirname [info script]] "world.tcl"]

nx::Class create Spec {
    :require namespace
    :class property [list world [::Spec::World new]]
    :class property [list configuration [Spec::Configuration new]]

    :public class method configure { block } {
        uplevel [list apply $block ${:configuration}]
    }

    :public class method require { filename } {
        if { ![info exists :sourced] } {
            set :sourced [list]
        }

        if { !($filename in ${:sourced}) } {
            uplevel [list source $filename]
            lappend :sourced $filename
        }
    }
}


namespace eval Spec {
    Class Expectations
    Expectations proc fail_with { message } {
        # Setting the return level here allows us to tweak generated backtraces
        # for expectation failures a bit. Thanks to this, the backtrace will
        # state that an error occurred during execution of "expect ...",
        # instead of during "Expectations fail_with ...".
        #
        # Also, this keeps the backtrace shorter and more focused, as we're
        # usually not concerned with what happens between the call to "expect"
        # and the generation of the expectation failure.
        #
        # TODO: The return level here is currently hard-coded, but it should be
        #       possible to determine the correct level programmatically.
        return -level 3 -code error -errorcode "EXPECTATION_NOT_MET" $message
    }

    Class PositiveExpectationHandler
    PositiveExpectationHandler proc handle_matcher { actual matcher } {
        if { [$matcher matches? $actual] } { return }
        Expectations fail_with [$matcher failure_message]
    }

    Class NegativeExpectationHandler
    NegativeExpectationHandler proc handle_matcher { actual matcher } {
        if { [$matcher does_not_match? $actual] } { return }
        Expectations fail_with [$matcher negative_failure_message]
    }
}

Switch ::Spec::Expectations, ::Spec::PositiveExpectationHandler and ::Spec::NegativeExpectationHandler to NX.

namespace eval ::Spec {
    nx::Class create Expectations {
        :public class method fail_with { message } {
            # Setting the return level here allows us to tweak generated backtraces
            # for expectation failures a bit. Thanks to this, the backtrace will
            # state that an error occurred during execution of "expect ...",
            # instead of during "Expectations fail_with ...".
            #
            # Also, this keeps the backtrace shorter and more focused, as we're
            # usually not concerned with what happens between the call to "expect"
            # and the generation of the expectation failure.
            #
            # TODO: The return level here is currently hard-coded, but it should be
            #       possible to determine the correct level programmatically.
            return -level 3 -code error -errorcode "EXPECTATION_NOT_MET" $message
        }
    }

    nx::Class create PositiveExpectationHandler {
        :public class method handle_matcher { actual matcher } {
            if { [$matcher matches? $actual] } { return }
            Expectations fail_with [$matcher failure_message]
        }
    }

    nx::Class create NegativeExpectationHandler {
        :public class method handle_matcher { actual matcher } {
            if { [$matcher does_not_match? $actual] } { return }
            Expectations fail_with [$matcher negative_failure_message]
        }
    }
}


# This file is expected to be regularly edited to control
# debugging output.  It is sourced by debug-auto.tcl
# The variable INPUT is converted to an array by debug-auto.tcl
# Each token maps to ON or OFF to indicate debugging

set INPUT {
    TURBINE OFF
    TCL_TURBINE OFF
    ADLB OFF
    CACHE OFF
}

Fix bug with refcounting decrementing array member in foreach loop

# This file is expected to be regularly edited to control
# debugging output.  It is sourced by debug-auto.tcl
# The variable INPUT is converted to an array by debug-auto.tcl
# Each token maps to ON or OFF to indicate debugging

set INPUT {
    TURBINE ON
    TCL_TURBINE ON
    ADLB ON
    CACHE ON
}


package provide spec 0.1

package require XOTcl 2.0
package require at_exit
package require try

namespace eval Spec {
    namespace import ::xotcl::*
    namespace import ::tcl::control::*
    namespace import ::at_exit::*
}

::xotcl::Class create Spec
Spec proc world {} {
    if { ![::xotcl::my exists world ] } {
        ::xotcl::my set world [Spec::World new]
    }

    ::xotcl::my set world
}

source [file join [file dirname [info script]] "dsl.tcl"]
source [file join [file dirname [info script]] "example.tcl"]
source [file join [file dirname [info script]] "example_group.tcl"]
source [file join [file dirname [info script]] "expectation_handler.tcl"]
source [file join [file dirname [info script]] "matchers.tcl"]
source [file join [file dirname [info script]] "reporter.tcl"]
source [file join [file dirname [info script]] "runner.tcl"]
source [file join [file dirname [info script]] "world.tcl"]

Switch the toplevel ::Spec Class to NX.

package provide spec 0.1

package require XOTcl 2.0
package require at_exit
package require try

namespace eval Spec {
    namespace import ::xotcl::*
    namespace import ::tcl::control::*
    namespace import ::at_exit::*
}

source [file join [file dirname [info script]] "dsl.tcl"]
source [file join [file dirname [info script]] "example.tcl"]
source [file join [file dirname [info script]] "example_group.tcl"]
source [file join [file dirname [info script]] "expectation_handler.tcl"]
source [file join [file dirname [info script]] "matchers.tcl"]
source [file join [file dirname [info script]] "reporter.tcl"]
source [file join [file dirname [info script]] "runner.tcl"]
source [file join [file dirname [info script]] "world.tcl"]

nx::Class create Spec {
    :require namespace
    :class property [list world [::Spec::World new]]
}


# global port routines
# the 'main' target is provided by this package
# main is a magic target and should not be replaced
package provide portmain 1.0
package require portutil

register_target main portmain::main
namespace eval portmain {
	variable options
	variable targets
}

# define globals: portname portversion categories maintainers
globals portmain::options portname portversion portrevision categories maintainers workdir worksrc

# define options: portname, portversion, categories, maintainers
options portmain::options portname portversion portrevision categories maintainers workdir worksrc

proc portmain::main {args} {
	global portname
	# puts "Building port: $portname"
	# do nothing
	return 0
}

Add default value for workdir

# global port routines
# the 'main' target is provided by this package
# main is a magic target and should not be replaced
package provide portmain 1.0
package require portutil

register_target main portmain::main
namespace eval portmain {
	variable options
	variable targets
}

# define globals: portname portversion categories maintainers
globals portmain::options portname portversion portrevision categories maintainers workdir worksrc no_worksubdir

# define options: portname, portversion, categories, maintainers
options portmain::options portname portversion portrevision categories maintainers workdir worksrc no_worksubdir

proc portmain::main {args} {
	global portname
	default portmain::options workdir work
	return 0
}


rule simple {

  when HTTP_REQUEST priority 100 {
    # set variable outside irule
    if { $status eq 1 }
      pool foo
    } else {
      pool bar
    }
  }
}

Update example test code for variables

package require -exact testcl 1.0.10
namespace import ::testcl::*

##
# Example demonstrating how to use TesTcl
# This is how you should write your tests
#
# To run example
#
# export TCLLIBPATH=/parent/dir/of/this/file
#
# and run the following command from /parent/dir/of/this/file
#
# jtcl examples/example_irule_variables.tcl
#
##

# Comment out to suppress logging
#log::lvSuppressLE info 0

before {
    event HTTP_REQUEST
}

it "should set pool to foo when status is 1" {
    endstate pool foo
    array set variables { status 1 }
    run irules/variables_irule.tcl simple variables
}

it "should set pool to bar when status is 0" {
    endstate pool bar
    array set variables { status 0 }
    run irules/variables_irule.tcl simple variables
}

stats


yosys -import
plugin -i sdc
plugin -i design_introspection
# Import the commands from the plugins to the tcl interpreter
yosys -import

read_verilog $::env(DESIGN_TOP).v
read_verilog -specify -lib -D_EXPLICIT_CARRY +/xilinx/cells_sim.v
read_verilog -lib +/xilinx/cells_xtra.v
hierarchy -check -auto-top
# Start flow after library reading
synth_xilinx -vpr -flatten -abc9 -nosrl -nodsp -iopad -run prepare:check

# Read the design's timing constraints
read_sdc $::env(DESIGN_TOP).input.sdc

# Propagate the clocks
propagate_clocks

# Write the clocks to file
set fh [open $::env(DESIGN_TOP).txt w]

puts $fh [get_clocks]

puts $fh [get_clocks -include_generated_clocks]

puts $fh [get_clocks -include_generated_clocks clk2]

puts $fh [get_clocks -of [get_nets clk_int_1 clk1] -include_generated_clocks clk_int_1]

puts $fh [get_clocks -of [get_nets]]

puts $fh [get_clocks -of [concat [get_nets clk2] [get_nets clk_int_1 clk]]]

close $fh

Drop vpr switch in synth_xilinx

yosys -import
plugin -i sdc
plugin -i design_introspection
# Import the commands from the plugins to the tcl interpreter
yosys -import

read_verilog $::env(DESIGN_TOP).v
read_verilog -specify -lib -D_EXPLICIT_CARRY +/xilinx/cells_sim.v
read_verilog -lib +/xilinx/cells_xtra.v
hierarchy -check -auto-top
# Start flow after library reading
synth_xilinx -flatten -abc9 -nosrl -nodsp -iopad -run prepare:check
#synth_xilinx

# Read the design's timing constraints
read_sdc $::env(DESIGN_TOP).input.sdc

# Propagate the clocks
propagate_clocks

# Write the clocks to file
set fh [open $::env(DESIGN_TOP).txt w]

puts $fh [get_clocks]

puts $fh [get_clocks -include_generated_clocks]

puts $fh [get_clocks -include_generated_clocks clk2]

puts $fh [get_clocks -of [get_nets clk_int_1 clk1] -include_generated_clocks clk_int_1]

puts $fh [get_clocks -of [get_nets]]

puts $fh [get_clocks -of [concat [get_nets clk2] [get_nets clk_int_1 clk]]]

close $fh


source "../tests/includes/init-tests.tcl"

proc cluster_allocate_mixedSlots {n} {
    set slot 16383
    while {$slot >= 0} {
        set node [expr {$slot % $n}]
        lappend slots_$node $slot
        incr slot -1
    }
    for {set j 0} {$j < $n} {incr j} {
        R $j cluster addslots {*}[set slots_${j}]
    }
}

proc create_cluster_with_mixedSlot {masters slaves} {
    cluster_allocate_mixedSlots $masters
    if {$slaves} {
        cluster_allocate_slaves $masters $slaves
    }
    assert_cluster_state ok
}

test "Create a 5 nodes cluster" {
    create_cluster_with_mixedSlot 5 15
}

test "Cluster is up" {
    assert_cluster_state ok
}

test "Cluster is writable" {
    cluster_write_test 0
}

test "Instance #5 is a slave" {
    assert {[RI 5 role] eq {slave}}
}

test "client do not break when cluster slot" {
    R 0 config set client-output-buffer-limit "normal 33554432 16777216 60"
    if { [catch {R 0 cluster slots}] } {
        fail "output overflow when cluster slots"
    }
}

Add a test to prove current tcl cluster client can not handle keys with hash tag.

source "../tests/includes/init-tests.tcl"

proc cluster_allocate_mixedSlots {n} {
    set slot 16383
    while {$slot >= 0} {
        set node [expr {$slot % $n}]
        lappend slots_$node $slot
        incr slot -1
    }
    for {set j 0} {$j < $n} {incr j} {
        R $j cluster addslots {*}[set slots_${j}]
    }
}

proc create_cluster_with_mixedSlot {masters slaves} {
    cluster_allocate_mixedSlots $masters
    if {$slaves} {
        cluster_allocate_slaves $masters $slaves
    }
    assert_cluster_state ok
}

test "Create a 5 nodes cluster" {
    create_cluster_with_mixedSlot 5 15
}

test "Cluster is up" {
    assert_cluster_state ok
}

test "Cluster is writable" {
    cluster_write_test 0
}

test "Instance #5 is a slave" {
    assert {[RI 5 role] eq {slave}}
}

test "client do not break when cluster slot" {
    R 0 config set client-output-buffer-limit "normal 33554432 16777216 60"
    if { [catch {R 0 cluster slots}] } {
        fail "output overflow when cluster slots"
    }
}

test "client can handle keys with hash tag" {
    set cluster [redis_cluster 127.0.0.1:[get_instance_attrib redis 0 port]]
    $cluster set foo{tag} bar
    $cluster close
}


#----------------------------------------------------------------------------
# $Id$
#
# PLplot TCL demos
#
# Maurice LeBrun
# IFS, University of Texas at Austin
# 23-Jun-1994
#
# To plot these, start up pltcl and type plinit to get a selection of
# device types.  Choose one of the devices then type
# "source tcldemos.tcl", then type "1" for the first demo, "2" for the
# second, and so on.  Not all examples are fully implemented yet.
# Note if you use xwin for the device type, you must type CR in the
# xwin window to move from one plot to the next.
#
# Note: each demo proc is supplied a widget argument if run from a widget,
# or "loopback" if being run from pltcl.  In the latter case, the
# "loopback cmd" does nothing, but is required two make the two styles of
# Tcl scripts compatible.
#----------------------------------------------------------------------------

for {set i 1} {$i <= 18} {incr i} {
    set demo x[format "%02d" $i]
    source $demo.tcl
    proc $i {} "$demo"
}

Fix minor typo in explanation.

#----------------------------------------------------------------------------
# $Id$
#
# PLplot TCL demos
#
# Maurice LeBrun
# IFS, University of Texas at Austin
# 23-Jun-1994
#
# To plot these, start up pltcl and type plinit to get a selection of
# device types.  Choose one of the devices then type
# "source tcldemos.tcl", then type "1" for the first demo, "2" for the
# second, and so on.  Not all examples are fully implemented yet.
# Note if you use xwin for the device type, you must type CR in the
# xwin window to move from one plot to the next.
#
# Note: each demo proc is supplied a widget argument if run from a widget,
# or "loopback" if being run from pltcl.  In the latter case, the
# "loopback cmd" does nothing but is required to make the two styles of
# Tcl scripts compatible.
#----------------------------------------------------------------------------

for {set i 1} {$i <= 18} {incr i} {
    set demo x[format "%02d" $i]
    source $demo.tcl
    proc $i {} "$demo"
}


namespace eval Spec {
    nx::Class create Runner {
        :public class method autorun {} {
            if { [:installed_at_exit?] } {
                return
            }

            set :installed_at_exit true
            at_exit { exit [::Spec::Runner run] }
        }

        :public class method run {} {
            set exit_code 0

            set reporter [[::Spec configuration] reporter]
            $reporter report [[Spec world] example_count] {
                foreach example_group [[Spec world] example_groups] {
                    $example_group execute $reporter
                }
            }

            return $exit_code
        }

        :public class method installed_at_exit? {} {
            expr { [info exists :installed_at_exit] && ${:installed_at_exit} }
        }
    }
}

Return a non-zero exit code if any example fails.

namespace eval Spec {
    nx::Class create Runner {
        :public class method autorun {} {
            if { [:installed_at_exit?] } {
                return
            }

            set :installed_at_exit true
            at_exit { exit [::Spec::Runner run] }
        }

        :public class method run {} {
            set failure_exit_code 1

            set success true

            set reporter [[::Spec configuration] reporter]
            $reporter report [[Spec world] example_count] {
                foreach example_group [[Spec world] example_groups] {
                    set success [expr { [$example_group execute $reporter] && $success }]
                }
            }

            expr { $success ? 0 : $failure_exit_code }
        }

        :public class method installed_at_exit? {} {
            expr { [info exists :installed_at_exit] && ${:installed_at_exit} }
        }
    }
}


#
# config for piaware
#
# Copyright (C) 2014 FlightAware LLC, All Rights Reserved
#

# server name is defined and can be overridden in the Itcl class library
# that handles connections

set serverRetryIntervalSeconds 60

set piawareVersion 2.1
set piawareVersionFull 2.1-1

# how many seconds with no messages received from the ADS-B receiver before
# we will attempt to restart dump1090
set noMessageActionIntervalSeconds 3600

# perform ADS-B traffic check and report every this-many-seconds
set adsbTrafficCheckIntervalSeconds 300

# send health information every this many seconds
set sendHealthInformationIntervalSeconds 300

# number of seconds that no ADS-B producer program (usually) is found running
# for before we will attempt to start it
set adsbNoProducerStartDelaySeconds 360

# port on which flightaware-style messages are received from faup1090 or
# dump1090 or some other mode S beast-style source
set faup1090Port 10001

# where we store our location info
set locationFile "/var/lib/dump1090/latlon"

# vim: set ts=4 sw=4 sts=4 noet :

Modify version being reported to server, since this is a custom build.

#
# config for piaware
#
# Copyright (C) 2014 FlightAware LLC, All Rights Reserved
#

# server name is defined and can be overridden in the Itcl class library
# that handles connections

set serverRetryIntervalSeconds 60

set piawareVersion 2.1
set piawareVersionFull 2.1-1-arcot1

# how many seconds with no messages received from the ADS-B receiver before
# we will attempt to restart dump1090
set noMessageActionIntervalSeconds 3600

# perform ADS-B traffic check and report every this-many-seconds
set adsbTrafficCheckIntervalSeconds 300

# send health information every this many seconds
set sendHealthInformationIntervalSeconds 300

# number of seconds that no ADS-B producer program (usually) is found running
# for before we will attempt to start it
set adsbNoProducerStartDelaySeconds 360

# port on which flightaware-style messages are received from faup1090 or
# dump1090 or some other mode S beast-style source
set faup1090Port 10001

# where we store our location info
set locationFile "/var/lib/dump1090/latlon"

# vim: set ts=4 sw=4 sts=4 noet :


#
# very simple client/server tests
#
# $Id$
#

package require ctable_client

remote_ctable ctable://127.0.0.1/dumbData t

# use to test redirect
#remote_ctable ctable://127.0.0.1:11112/dumbData t

puts "search of t in descending coolness limit 5 / code body"
t search -sort -coolness -limit 5 -key key -array_get_with_nulls data -code {puts "$key -> $data"}
puts ""

puts "search of t in descending coolness limit 5"
t search -sort -coolness -limit 5 -write_tabsep stdout
puts ""

Add a couple of search+ tests.

#
# very simple client/server tests
#
# $Id$
#

package require ctable_client

remote_ctable ctable://127.0.0.1/dumbData t

# use to test redirect
#remote_ctable ctable://127.0.0.1:11112/dumbData t

puts "search of t in descending coolness limit 5 / code body"
t search -sort -coolness -limit 5 -key key -array_get_with_nulls data -code {puts "$key -> $data"}
puts ""

puts "search of t in descending coolness limit 5"
t search -sort -coolness -limit 5 -write_tabsep stdout
puts ""

puts "search+ of t in descending coolness limit 5 / code body"
puts [t index indexable]
t index create show

t search+ -sort -coolness -limit 5 -key key -array_get_with_nulls data -code {puts "$key -> $data"}
puts ""

puts "search+ of t in descending coolness limit 5"
t search+ -sort -coolness -limit 5 -write_tabsep stdout
puts ""


package require -exact testcl 0.9
namespace import ::testcl::*

##
# Example demonstrating how to use TesTcl
# This is how you should write your tests
#
# To run example
#
# export TCLLIBPATH=/parent/dir/of/this/file
#
# and run the following command from /parent/dir/of/this/file
#
# jtcl examples/example_irule_simple.tcl
#
##

# Comment out to suppress logging
#log::lvSuppressLE info 0

before {
  event HTTP_REQUEST
}

it "should handle request using pool bar" {
  on HTTP::uri return "/bar"
  endstate pool bar
  run irules/simple_irule.tcl simple
}

it "should handle request using pool foo" {
  on HTTP::uri return "/foo/admin"
  endstate pool foo
  run irules/simple_irule.tcl simple
}

stats

Update of simple example to test HTTP_RESPONSE event

package require -exact testcl 0.9
namespace import ::testcl::*

##
# Example demonstrating how to use TesTcl
# This is how you should write your tests
#
# To run example
#
# export TCLLIBPATH=/parent/dir/of/this/file
#
# and run the following command from /parent/dir/of/this/file
#
# jtcl examples/example_irule_simple.tcl
#
##

# Comment out to suppress logging
#log::lvSuppressLE info 0

before {
  #in most test cases we are checking request event
  event HTTP_REQUEST
}

it "should handle request using pool bar" {
  #provide uri value to use in test case
  on HTTP::uri return "/bar"
  #define statement which will be end state in iRule execution for this test case
  endstate pool bar
  #execute iRule
  run irules/simple_irule.tcl simple
}

it "should handle request using pool foo" {
  on HTTP::uri return "/foo/admin"
  endstate pool foo
  run irules/simple_irule.tcl simple
}

it "should replace existing Vary http response headers with Accept-Encoding value" {
	#override event type set in before
	event HTTP_RESPONSE
	#define verifications
	verify "there should be only one Vary header" 1 == {HTTP::header count vary}
	verify "there should be Accept-Encoding value in Vary header" "Accept-Encoding" eq {HTTP::header Vary}
	#initialize HTTP headers
	HTTP::header insert Vary "dummy value"
	HTTP::header insert Vary "another dummy value"
	#execute iRule
	run irules/simple_irule.tcl simple
}

stats


package require vtk

# Image pipeline

vtkImageReader2Factory createReader
set reader [createReader CreateImageReader2 "$VTK_DATA_ROOT/Data/libtif/test.tif"]
$reader SetFileName "$VTK_DATA_ROOT/Data/libtiff/test.tif"

vtkImageViewer viewer
viewer SetInput [$reader GetOutput]
viewer SetColorWindow 256
viewer SetColorLevel 127.5

#make interface
viewer Render

Fix typo in the test

package require vtk

# Image pipeline

vtkImageReader2Factory createReader
set reader [createReader CreateImageReader2 "$VTK_DATA_ROOT/Data/libtiff/test.tif"]
$reader SetFileName "$VTK_DATA_ROOT/Data/libtiff/test.tif"

vtkImageViewer viewer
viewer SetInput [$reader GetOutput]
viewer SetColorWindow 256
viewer SetColorLevel 127.5

#make interface
viewer Render


Test to quantize earth.ppm down to 16 colors

catch {load vtktcl}
# Make an image larger by repeating the data.  Tile.

source vtkImageInclude.tcl

# Image pipeline
vtkPNMReader reader
reader ReleaseDataFlagOff
reader SetFileName "../../../vtkdata/earth.ppm"

vtkImageMirrorPad pad
pad SetInput [reader GetOutput]
pad SetOutputWholeExtent -220 340 -220 340 0 0

vtkImageQuantizeRGBToIndex quant
quant SetInput [pad GetOutput]
quant SetNumberOfColors 16
quant Update

vtkImageMapToRGBA map
map SetInput [quant GetOutput]
map SetLookupTable [quant GetLookupTable]

vtkImageViewer viewer
viewer SetInput [map GetOutput]
viewer SetZSlice 0
viewer SetColorWindow 256
viewer SetColorLevel 127
[viewer GetActor2D] SetDisplayPosition 220 220
viewer Render

wm withdraw .


Make sure all of the features of ExtractVOI work.

package require vtk
package require vtkinteraction

# to mark the origin
vtkSphereSource sphere
  sphere SetRadius 2.0
vtkPolyDataMapper sphereMapper
  sphereMapper SetInput [sphere GetOutput]
  sphereMapper ImmediateModeRenderingOn
vtkActor sphereActor
  sphereActor SetMapper sphereMapper

vtkRTAnalyticSource rt
rt SetWholeExtent -50 50 -50 50 0 0

vtkExtractVOI voi
  voi SetInput [rt GetOutput]
  voi SetVOI -11 39 5 45 0 0
  voi SetSampleRate 5 5 1

# Get rid ambiguous triagulation issues.
vtkDataSetSurfaceFilter surf
  surf SetInput [voi GetOutput]
vtkTriangleFilter tris
  tris SetInput [surf GetOutput]

vtkPolyDataMapper mapper
  mapper SetInput [tris GetOutput]
  mapper ImmediateModeRenderingOn
  mapper SetScalarRange 130 280
vtkActor actor
  actor SetMapper mapper

vtkRenderer ren
ren AddActor actor
ren AddActor sphereActor
set camera [ren GetActiveCamera]

#$camera SetPosition 68.1939 -23.4323 12.6465
#$camera SetViewUp 0.46563 0.882375 0.0678508
#$camera SetFocalPoint 3.65707 11.4552 1.83509
#$camera SetClippingRange 59.2626 101.825

vtkRenderWindow renWin
renWin AddRenderer ren

vtkRenderWindowInteractor iren
iren SetRenderWindow renWin
iren Initialize
iren AddObserver UserEvent {wm deiconify .vtkInteract}

wm withdraw .


Add SPI_DEVICE Status reconvergence waiver

# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0
#
# Verix CDC waiver file
# Expression:
#  ControlSignal==""
#  ReconSignal==""
#  MultiClockDomains=="IO_DIV2_CLK::IO_DIV4_CLK"

set_rule_status -rule {W_RECON_GROUPS} -status {Waived}         \
   -expression {(ControlSignal=~"*u_status_23_to_1_sync.*") &&       \
                (ReconSignal=~"*u_spid_status.outclk_p2s_byte_*")} \
   -comment {status bits are converged into SPI line. But transmit bit-by-bit. OK to send old and new status bits in a transaction}


catch {load vtktcl}
if { [catch {set VTK_TCL $env(VTK_TCL)}] != 0} { set VTK_TCL "../../examplesTcl" }
if { [catch {set VTK_DATA $env(VTK_DATA)}] != 0} { set VTK_DATA "../../../vtkdata" }

#
# this is a tcl version of the Mace example
# get the interactor ui

source $VTK_TCL/vtkInt.tcl

# Create the RenderWindow, Renderer and both Actors
#
vtkRenderer ren1
vtkRenderWindow renWin
    renWin AddRenderer ren1
    renWin StereoCapableWindowOn
    renWin SetWindowName "vtk - Mace"
vtkRenderWindowInteractor iren
    iren SetRenderWindow renWin

renWin SetStereoTypeToDresden
renWin StereoRenderOn

# create a sphere source and actor
#
vtkSphereSource sphere

vtkPolyDataMapper   sphereMapper
    sphereMapper SetInput [sphere GetOutput]
    sphereMapper GlobalImmediateModeRenderingOn
vtkLODActor sphereActor
    sphereActor SetMapper sphereMapper

# create the spikes using a cone source and the sphere source
#
vtkConeSource cone
vtkGlyph3D glyph
    glyph SetInput [sphere GetOutput]
    glyph SetSource [cone GetOutput]
    glyph SetVectorModeToUseNormal
    glyph SetScaleModeToScaleByVector
    glyph SetScaleFactor 0.25
vtkPolyDataMapper spikeMapper
    spikeMapper SetInput [glyph GetOutput]
vtkLODActor spikeActor
    spikeActor SetMapper spikeMapper

# Add the actors to the renderer, set the background and size
#
ren1 AddActor sphereActor
ren1 AddActor spikeActor
ren1 SetBackground 0.1 0.2 0.4
renWin SetSize 300 300

# render the image
#
iren SetUserMethod {wm deiconify .vtkInteract}

set cam1 [ren1 GetActiveCamera]
$cam1 Zoom 1.4
iren Initialize

proc TkCheckAbort {} {
  set foo [renWin GetEventPending]
  if {$foo != 0} {renWin SetAbortRender 1}
}
renWin SetAbortCheckMethod {TkCheckAbort}

# prevent the tk window from showing up then start the event loop
wm withdraw .

vtkMatrix4x4 mat
spikeActor SetUserMatrix mat

renWin Render

## Write the image
##vtkWindowToImageFilter w2i
##w2i SetInput renWin

##vtkTIFFWriter tiff
##tiff SetInput [w2i GetOutput]
##tiff SetFileName stereoDresdenMace.tcl.tif
##tiff Write


catch {load vtktcl}

# get the interactor ui
source vtkInt.tcl
# and some nice colors
source colors.tcl

# Now create the RenderWindow, Renderer and Interactor
#
vtkRenderer ren1
vtkRenderWindow renWin
    renWin AddRenderer ren1
vtkRenderWindowInteractor iren
    iren SetRenderWindow renWin

vtkPNMReader image
  image SetFileName "../../vtkdata/B.pgm"

vtkStructuredPointsToImage toImage
    toImage SetInput [image GetOutput]
    toImage SetOutputScalarTypeToUnsignedChar

vtkImageGaussianSmooth gaussian
    eval gaussian SetStandardDeviations 2 2
    gaussian SetDimensionality 2
    gaussian SetStrides 2 2
    gaussian SetRadiusFactors 1 1
    gaussian SetInput [toImage GetOutput]
    gaussian SetInput [image GetOutput]

vtkStructuredPointsGeometryFilter geometry
  geometry SetInput [gaussian GetOutput]

vtkClipPolyData aClipper
    aClipper SetInput [geometry GetOutput]
    aClipper SetValue 127.5
    aClipper GenerateClipScalarsOff
    aClipper InsideOutOn
    [[aClipper GetOutput] GetPointData] CopyScalarsOff
    aClipper Update

vtkPolyDataMapper mapper
  mapper SetInput [aClipper GetOutput]
  mapper ScalarVisibilityOff

vtkActor letter
  letter SetMapper mapper

ren1 AddActor letter
  [letter GetProperty] SetDiffuseColor 0 0 0
  [letter GetProperty] SetRepresentationToWireframe

ren1 SetBackground 1 1 1
renWin SetSize 320 320

iren SetUserMethod {wm deiconify .vtkInteract}
iren Initialize

# render the image
#
renWin Render

# prevent the tk window from showing up then start the event loop
wm withdraw .


Add specs for BeTrue/BeFalse/BeComparedTo Matchers.

lappend auto_path [file join [file dirname [info script]] ".." ".." "lib"]
package require spec/autorun

describe "BeTrueMatcher" {
    before each {
        set matcher [ Spec::Matchers::BeTrueMatcher new ]
    }

    it "matches when actual is a truthy value" {
        expect [ $matcher matches? true ] to be true
        expect [ $matcher matches? tru ] to be true
        expect [ $matcher matches? tr ] to be true
        expect [ $matcher matches? t ] to be true

        expect [ $matcher matches? on ] to be true

        expect [ $matcher matches? yes ] to be true
        expect [ $matcher matches? ye ] to be true
        expect [ $matcher matches? y ] to be true

        expect [ $matcher matches? 1 ] to be true
    }

    it "does not matches when actual is not a truthy value" {
        expect [ $matcher does_not_match? "test" ] to be true
        expect [ $matcher does_not_match? 123 ] to be true
    }

    it "provides actual on #positive_failure_message" {
        $matcher matches? 2
        expect [ $matcher positive_failure_message ] to equal "Expected <2> to be true"
    }

    it "provides actual on #negative_failure_message" {
        $matcher does_not_match? 2
        expect [ $matcher negative_failure_message ] to equal "Expected <2> to not be true"
    }
}

describe "BeFalseMatcher" {
    before each {
        set matcher [ Spec::Matchers::BeFalseMatcher new ]
    }

    it "matches when actual is a falsy value" {
        expect [ $matcher matches? false ] to be true
        expect [ $matcher matches? fals ] to be true
        expect [ $matcher matches? fal ] to be true
        expect [ $matcher matches? fa ] to be true
        expect [ $matcher matches? f ] to be true

        expect [ $matcher matches? off ] to be true
        expect [ $matcher matches? of ] to be true

        expect [ $matcher matches? no ] to be true
        expect [ $matcher matches? n ] to be true

        expect [ $matcher matches? 0 ] to be true
    }

    it "does not matches when actual is not a falsy value" {
        expect [ $matcher does_not_match? "test" ] to be true
        expect [ $matcher does_not_match? 123 ] to be true
    }

    it "provides actual on #positive_failure_message" {
        $matcher matches? 2
        expect [ $matcher positive_failure_message ] to equal "Expected <2> to be false"
    }

    it "provides actual on #negative_failure_message" {
        $matcher does_not_match? 2
        expect [ $matcher negative_failure_message ] to equal "Expected <2> to not be false"
    }
}

describe "BeComparedToMatcher, with < as operator" {
    before each {
        set matcher [ Spec::Matchers::BeComparedToMatcher new 10 "<" ]
    }

    it "matches when actual is < expected" {
        expect [ $matcher matches? 3 ] to be true
    }

    it "does not match when actual is not < expected" {
        expect [ $matcher does_not_match? 11 ] to be true
    }
}


Test out methods implemented on our local tclhttpd server.

# Create the commands for my SOAP-domain package

package require SOAP
set methods {}

lappend methods [ SOAP::create rcsid \
	-name rcsid \
	-uri zsplat-Test \
	-proxy http://localhost:8015/soap/rcsid \
	-params {} ]

lappend methods [ SOAP::create zbase64 \
	-name base64 \
	-uri zsplat-Test \
	-proxy http://localhost:8015/soap/base64 \
	-params {msg string} ]

lappend methods [ SOAP::create ztime \
	-name time \
	-uri zsplat-Test \
	-proxy http://localhost:8015/soap/time \
	-params {} ]

lappend methods [ SOAP::create square \
	-uri zsplat-Test \
	-proxy http://localhost:8015/soap/square \
	-params {num integer} ]

lappend methods [ SOAP::create sort \
	-uri zsplat-Test \
	-proxy http://localhost:8015/soap/sort \
	-params { list string } ]

puts "$methods"
unset methods


catch {load vtktcl}

source vtkImageInclude.tcl
source TkImageViewerInteractor.tcl

# This script uses a vtkTkRenderWidget to create a
# Tk widget that is associated with a vtkRenderWindow.
#source TkInteractor.tcl

vtkPNMReader reader
reader ReleaseDataFlagOff
reader SetFileName "../../../vtkdata/earth.ppm"

vtkImageMagnify magnify
magnify SetInput [reader GetOutput]
magnify SetMagnificationFactors 1 2 1
magnify InterpolateOn

vtkImageViewer viewer
viewer SetInput [magnify GetOutput]
viewer SetColorWindow 256
viewer SetColorLevel 127.5

# Create the GUI: two renderer widgets and a quit button
#
wm withdraw .
toplevel .top

frame .top.f1

vtkTkImageViewerWidget .top.f1.r1 -width 512 -height 512 -iv viewer
#    BindTkRenderWidget .top.f1.r1

button .top.btn  -text Quit -command exit

pack .top.f1.r1 -side left -padx 3 -pady 3 -fill both -expand t
pack .top.f1  -fill both -expand t
pack .top.btn -fill x

BindTkImageViewer .top.f1.r1


Test to quantize earth.ppm down to 64 colors

catch {load vtktcl}
# Make an image larger by repeating the data.  Tile.

source vtkImageInclude.tcl

# Image pipeline
vtkPNMReader reader
reader ReleaseDataFlagOff
reader SetFileName "../../../vtkdata/earth.ppm"

vtkImageMirrorPad pad
pad SetInput [reader GetOutput]
pad SetOutputWholeExtent -220 340 -220 340 0 0

vtkImageQuantizeRGBToIndex quant
quant SetInput [pad GetOutput]
quant SetNumberOfColors 64
quant Update

vtkImageMapToRGBA map
map SetInput [quant GetOutput]
map SetLookupTable [quant GetLookupTable]

vtkImageViewer viewer
viewer SetInput [map GetOutput]
viewer SetZSlice 0
viewer SetColorWindow 256
viewer SetColorLevel 127
[viewer GetActor2D] SetDisplayPosition 220 220
viewer Render

wm withdraw .


Add openocd script to upload code to link proto0

# Copyright (c) 2012 The Chromium OS Authors. All rights reserved.
# Use of this source code is governed by a BSD-style license that can be
# found in the LICENSE file.
#
# Upload link image to flash and run it

reset halt
# Link proto0 has 128KB flash; proto1+ will likely have 256KB, in which
# case this'll need changing.
flash erase_sector 0 0 127
flash write_image ../../../build/link/ec.bin 0
reset


Add file that defines iso values for LC signals

# Copyright lowRISC contributors.
# Licensed under the Apache License, Version 2.0, see LICENSE for details.
# SPDX-License-Identifier: Apache-2.0
#
# Defines paths to signals that require non-zero isolation values in UPF.

# The LC OFF value is set to 0x1010 in RTL. Note that changing this encoding has
# implications on isolation cell values in RTL. Do not change this unless
# absolutely needed. See #4244 for the audit / discussion about which ports
# should have nonzero values.
set UPF_ISO_LC_OFF_PORTS_CLAMP1 {
  top_earlgrey/u_aon_timer_aon/lc_escalate_en_i[3] \
  top_earlgrey/u_aon_timer_aon/lc_escalate_en_i[1] \
  top_earlgrey/u_pinmux_aon/lc_escalate_en_i[3]    \
  top_earlgrey/u_pinmux_aon/lc_escalate_en_i[1]    \
  top_earlgrey/u_pinmux_aon/lc_check_byp_en_i[3]   \
  top_earlgrey/u_pinmux_aon/lc_check_byp_en_i[1]   }


#
# $Id$
#

package require st_shared

puts "Making connection"
set r [::stapi::connect shared://1616/master -build stobj]

puts "created reader $r"

puts [$r share list]
puts [$r share info]

set c [$r search -key k -array_get a -cursor #auto]

while {![$c at_end]} {
    set k [$c key]
    set a [$c array_get]
    $c next
    set orig($k) $a
    set curr($k) $a
    array set row $a
    lappend ids $row(id)
}
$c destroy
set names [array names orig]
set num [llength $names]

puts "Scanning 10000 samples"

set missed 0
for {set i 0} {$i < 10000} {incr i} {
    set n [expr {int(rand() * $num)}]
    set k [lindex $names $n]
    set old $curr($k)
    array set row $old
    set id $row(id)
    set comp {}
    lappend comp [list = id $id]
    set found 0
    set c [$r search -compare $comp -key k -array_get a -cursor #auto]
    while {![$c at_end]} {
	set k [$c key]
	set a [$c array_get]
	$c next
	if {"$a" != "$old"} {
	    #puts "changed $k : $a"
	    lappend changed($k) $id $a
	    set curr($k) $a
        }
	incr found
    }
    $c destroy
    if {!$found} {
	incr missed
    }
    if {$i % 100 == 0} {
	puts -nonewline "$found"; flush stdout
    }
    after 150
}

puts "\n\n10000 passes [llength [array names changed]] modified"

foreach id [array names idwant] {
    if {$idwant($id) != $idfound($id)} {
	puts "$id: wanted $idwant($id) found $idfound($id)"
    }
}
if {$missed} { puts "total: $missed missed" }

puts "deleting STAPI connection"

$r destroy


Add example as printed in chapter 13 of the VTK users guide.

package require vtk
package require vtkinteraction

# This script uses a vtkTkRenderWidget to create a
# Tk widget that is associated with a vtkRenderWindow

# Create the GUI: a render widget and a quit button
wm withdraw .
toplevel .top
frame .top.f1
vtkTkRenderWidget .top.f1.r1 -width 400 -height 400
button .top.btn -text Quit -command exit
pack .top.f1.r1 -side left -padx 3 -pady 3 -fill both -expand t
pack .top.f1 -fill both -expand t
pack .top.btn -fill x

# Get the render window associated with the widget
set renWin [.top.f1.r1 GetRenderWindow]
vtkRenderer ren1
$renWin AddRenderer ren1

# bind the mouse events
::vtk::bind_tk_render_widget .top.f1.r1

# create a Cone source and actor
vtkConeSource cone
vtkPolyDataMapper coneMapper
  coneMapper SetInputConnection [cone GetOutputPort]
  coneMapper GlobalImmediateModeRenderingOn
vtkLODActor coneActor
  coneActor SetMapper coneMapper

# Add the actor to the renderer and set the background
ren1 AddViewProp coneActor
ren1 SetBackground 0.1 0.2 0.4
[ren1 GetActiveCamera] Zoom 0.6


Add primitive reset test -- we weren't testing that very well.

#
# test seeing if the reset method causes memory corruption.
#
# $Id$
#

source nametest-extension.tcl

puts "\n\nloading the table...\n"

source name-data.tcl

puts "done.  resetting..."

n reset

puts "done."

puts "\nreloading the table...\n"

source name-data.tcl

puts "done."

#source cputime.tcl
proc cputime {x} {
    return [time $x]
}

proc test1 {} {
    puts "matching *lehenbauer*"

    n search -compare {{match name "*lehenbauer*"}} -write_tabsep stdout
}

puts [cputime test1]

proc test2 {} {
    puts "matching *Sylvester*Bakerville*"

    n search -compare {{match name "*Sylvester*Bakerville*"}} -write_tabsep stdout
}

puts [cputime test2]

proc test3 {} {
    puts "matching *lehenbauer* count only"

    puts [n search -compare {{match name "*lehenbauer*"}} -countOnly 1]
}

puts [cputime test3]


Add of a client test that checks the results for correctness rather than just pooping them out.

#
# very simple client/server tests
#
# this one checks results of search and search+ to match expected or not
#
# $Id$
#

set expectKey(0) jonas_jr
set expect(jonas_jr) [list id jonas_jr name {Doctor Jonas Venture Junior} home {Spider Skull Island} show {Venture Bros} dad jonas alive 1 gender {} age 45 coolness 120]

set expectKey(1) mom
set expect(mom) [list id mom name Mom home {} show {The Brak Show} dad {} alive 1 gender female age 41 coolness 101]

set expectKey(2) brock
set expect(brock) [list id brock name {Brock Sampson} home {Venture Compound} show {Venture Bros} dad {} alive 1 gender {} age 35 coolness 100]

set expectKey(3) rick
set expect(rick) [list id rick name {Coroner Rock} home {} show {Stroker and Hoop} dad {} alive 1 gender {} age 51 coolness 99]

set expectKey(4) doctor_girlfriend
set expect(doctor_girlfriend) [list id doctor_girlfriend name {Doctor Girlfriend} home {The Cocoon} show {Venture Bros} dad {} alive 1 gender female age 30 coolness 80]

package require ctable_client

remote_ctable ctable://127.0.0.1/dumbData t

# use to test redirect
#remote_ctable ctable://127.0.0.1:11112/dumbData t

puts -nonewline "search of t in descending coolness limit 5 / code body..."
set i 0
t search -sort -coolness -limit 5 -key key -array_get_with_nulls data -code {
    if {$key != $expectKey($i)} {
	error "got key '$key' expected '$expectKey($i)'"
    }

    if {$data != $expect($key)} {
	error "got data of '$data' expected '$expect($key)'"
    }

    incr i
}
puts "OK"

puts -nonewline "search+ of t in descending coolness limit 5 / code body..."
t index create show

set i 0
t search -sort -coolness -limit 5 -key key -array_get_with_nulls data -code {
    if {$key != $expectKey($i)} {
	error "got key '$key' expected '$expectKey($i)'"
    }

    if {$data != $expect($key)} {
	error "got data of '$data' expected '$expect($key)'"
    }

    incr i
}
puts "OK"


catch {load vtktcl}
if { [catch {set VTK_TCL $env(VTK_TCL)}] != 0} { set VTK_TCL "../../examplesTcl" }
if { [catch {set VTK_DATA $env(VTK_DATA)}] != 0} { set VTK_DATA "../../../vtkdata" }

set NUMBER_OF_PIECES 5

# Generate implicit model of a sphere
#
source $VTK_TCL/vtkInt.tcl
source $VTK_TCL/colors.tcl

# Create renderer stuff
#
vtkRenderer ren1
vtkRenderWindow renWin
    renWin AddRenderer ren1
vtkRenderWindowInteractor iren
    iren SetRenderWindow renWin

# create pipeline that handles ghost cells

vtkSphereSource sphere
    sphere SetRadius 3
    sphere SetPhiResolution 100
    sphere SetThetaResolution 150
    # sphere SetStartMethod {tk_messageBox -message "Executing with piece [[sphere GetOutput] GetUpdatePiece]"}

# Just playing with an alternative that is not currently used.
proc NotUsed {} {
  # This filter actually spoils the example because it asks for the whole input.
  # The only reason it is here is because sphere complains it cannot generate ghost cells.
  vtkExtractPolyDataPiece piece
    piece SetInput [sphere GetOutput]
    # purposely put seams in here.
    piece CreateGhostCellsOff

  # purposely put seams in here.
  vtkPolyDataNormals pdn
    pdn SetInput [piece GetOutput]
}

# Just playing with an alternative that is not currently used.
vtkDecimatePro deci
  deci SetInput [sphere GetOutput]
  # this did not remove seams as I thought it would
  deci BoundaryVertexDeletionOff
  #deci PreserveTopologyOn

# Since quadric Clustering does not handle borders properly yet,
# the pieces will have dramatic "eams"
vtkQuadricClustering q
  q SetInput [sphere GetOutput]
  q SetNumberOfXDivisions 5
  q SetNumberOfYDivisions 5
  q SetNumberOfZDivisions 10
  q UseInputPointsOn

vtkPolyDataStreamer streamer
  #streamer SetInput [deci GetOutput]
  streamer SetInput [q GetOutput]
  #streamer SetInput [pdn GetOutput]
  streamer SetNumberOfStreamDivisions $NUMBER_OF_PIECES

vtkPolyDataMapper mapper
  mapper SetInput [streamer GetOutput]
  mapper ScalarVisibilityOff
  mapper SetPiece 0
  mapper SetNumberOfPieces 2
  mapper ImmediateModeRenderingOn

vtkActor actor
    actor SetMapper mapper
    eval [actor GetProperty] SetColor $english_red

# Add the actors to the renderer, set the background and size
#

[ren1 GetActiveCamera] SetPosition 5 5 10
[ren1 GetActiveCamera] SetFocalPoint 0 0 0
ren1 AddActor actor
ren1 SetBackground 1 1 1
renWin SetSize 500 500
iren Initialize

# render the image
#
iren SetUserMethod {wm deiconify .vtkInteract}

# prevent the tk window from showing up then start the event loop
wm withdraw .


package require turbine 0.1
turbine_init

turbine_file 0 0.txt
turbine_file 1 1.txt
turbine_file 2 2.txt

turbine_rule 0 0 { } { 0 } { touch 0.txt }
turbine_rule 1 1 { 0 } { 1 } { touch 1.txt }
turbine_rule 2 2 { 1 } { 2 } { touch 2.txt }

turbine_engine
turbine_finalize
puts OK


Add of demo that uses connection and result objects.

#
# program to insert the sampledata.txt data set into pgtest_people
# using the new-fangled connection and result objects
#
# $Id$
#

package require Pgtcl

proc doit {} {
    set fp [open sampledata.txt]
    set conn [pg_connect -conninfo ""]

    while {[gets $fp line] >= 0} {
	set statement "insert into pgtest_people values ([pg_quote [lindex $line 0]], [pg_quote [lindex $line 1]], [pg_quote [lindex $line 2]], [pg_quote [lindex $line 3]], [pg_quote [lindex $line 4]], [pg_quote [lindex $line 5]]);"

	set result [$conn exec $statement]
        if {[$result -status] != "PGRES_COMMAND_OK"} {
	    puts "[pg_result $result -error] executing '$statement'"
	}
	$result -clear
    }
}

if !$tcl_interactive doit


Add tcl version of the testing script, just for fun.

#!/usr/bin/env tclsh

set red "\033\[0;31m"
set grn "\033\[0;32m"
set nc  "\033\[0m"

set pass "${grn}PASS!${nc}"
set fail "${red}FAIL!${nc}"

set stats.total 0
set stats.ok 0
set stats.fail 0

proc print_fail_report {t out expected} {
	global fail

	set hr [join [lrepeat 65 "-"] ""]
	puts "${t}: ${fail}"
	puts $hr
	puts "Got:\n${out}"
	puts $hr
	puts "Expected:\n${expected}"
	puts $hr
}

proc print_pass_report {t} {
	global pass

	puts "${t}: ${pass}"
}

proc print_stats {} {
	global red grn nc stats.total stats.ok stats.fail

	set hr [join [lrepeat 72 "█"] ""]
	set hrcol [expr {${stats.fail} ? $red : $grn}]
	puts "\nSummary (total: ${stats.total})"
	puts "${grn}  PASS${nc}: ${stats.ok}"
	puts "${red}  FAIL${nc}: ${stats.fail}"
	puts "${hrcol}${hr}${nc}"
}

proc read_file {filename} {
	set f [open $filename r]
	set data [read $f]
	close $f
	return $data
}

proc run_test {t} {
	global stats.total stats.ok stats.fail

	incr stats.total
	set cursorpos [string range [file extension [glob "${t}/cursor.*"]] 1 end]
	set expected [read_file "${t}/out.expected"]
	set filename "${t}/test.go"

	set out [read_file "| gocode -in ${filename} autocomplete ${filename} ${cursorpos}"]
	if {$out eq $expected} {
		print_pass_report $t
		incr stats.ok
	} else {
		print_fail_report $t $out $expected
		incr stats.fail
	}
}

if {$argc == 1} {
	run_test $argv
} else {
	foreach t [lsort [glob test.*]] {
		run_test $t
	}
}

print_stats


catch {load vtktcl}
# Make an image larger by repeating the data.  Tile.

source vtkImageInclude.tcl

# Image pipeline
vtkPNMReader reader
reader ReleaseDataFlagOff
reader SetFileName "../../../vtkdata/earth.ppm"

vtkImageMirrorPad pad
pad SetInput [reader GetOutput]
pad SetOutputWholeExtent -230 350 -230 350 0 92

vtkImageViewer viewer
viewer SetInput [pad GetOutput]
viewer SetZSlice 22
viewer SetColorWindow 255
viewer SetColorLevel 127
[viewer GetActor2D] SetDisplayPosition 230 230

#make interface
source WindowLevelInterface.tcl


Add some failing specs for ExampleGroup.

lappend auto_path [file join [file dirname [info script]] ".." "lib"]
package require spec/autorun

source [file join [file dirname [info script]] "spec_helper.tcl"]

# describe "The top level group" {
#     it "runs its children" {
#         set ::examples_run 0

#         set group [ExampleGroup describe "parent" {
#             describe "child" {
#                 it "does something" {
#                     incr ::examples_run
#                 }
#             }
#         }]

#         $group run
#         expect $::examples_run to equal 1
#     }

#     describe "with a failure" {
#         it "runs its children" {
#             set ::examples_run 0

#             set group [ExampleGroup describe "parent" {
#                 it "fails" {
#                     incr ::examples_run
#                     error "fail"
#                 }

#                 describe "child" {
#                     it "does something" {
#                         incr ::examples_run
#                     }
#                 }
#             }]

#             $group run
#             expect $::examples_run to equal 2
#         }
#     }
# }

describe "before, after, and around hooks" {
    it "runs the before alls in order" {
        set group [ExampleGroup describe]
        set ::order {}

        $group before all { lappend ::order 1 }
        $group before all { lappend ::order 2 }
        $group before all { lappend ::order 3 }
        $group example "example" { }

        $group run

        expect $order to equal { 1 2 3 }
    }

    it "runs the before eachs in order" {
        set group [ExampleGroup describe]
        set ::order {}

        $group before each { lappend ::order 1 }
        $group before each { lappend ::order 2 }
        $group before each { lappend ::order 3 }
        $group example "example" { }

        $group run

        expect $order to equal { 1 2 3 }
    }

    it "runs the after eachs in reverse order" {
        set group [ExampleGroup describe]
        set ::order {}

        $group after each { lappend ::order 1 }
        $group after each { lappend ::order 2 }
        $group after each { lappend ::order 3 }
        $group example "example" { }

        $group run

        expect $order to equal { 3 2 1 }
    }

    it "runs the after alls in order" {
        set group [ExampleGroup describe]
        set ::order {}

        $group after all { lappend ::order 1 }
        $group after all { lappend ::order 2 }
        $group after all { lappend ::order 3 }
        $group example "example" { }

        $group run

        expect $order to equal { 3 2 1 }
    }
}


Add of test that resets a table several times and refills it -- this caused a crash at one point.

#
#
#
#
# $Id$
#

source searchtest-def.tcl

proc test {} {

    source dumb-data.tcl

    t reset
}

time test 100


set setup_proc ""
set teardown_proc ""

proc TEST_SETUP {setup} {
	global setup_proc
	set setup_proc $setup
}

proc TEST_TEARDOWN {teardown} {
	global teardown_proc
	set teardown_proc $teardown
}

proc TEST_CASE {test_name test_body} {
	global setup_proc
	global teardown_proc

	catch {eval $setup_proc}
	puts $test_name
	eval $test_body
	catch {eval $teardown_proc}
}