source [file dirname [info script]]/testing.tcl

needs constraint jim
needs cmd array
needs cmd ref

test alias-1.1 "One word alias" {
	set x 2
	alias newincr incr
	newincr x 
} {3}

test alias-1.4 "Two word alias" {
	alias infoexists info exists
	infoexists x
} {1}

test alias-1.5 "Replace alias" {
	alias newincr infoexists
	newincr x
} {1}

test alias-1.6 "Delete alias" {
	rename newincr ""
	catch {newincr x}
} {1}

test alias-1.7 "Replace alias with proc" {
	proc infoexists {n} {
		return yes
	}
	infoexists any
} {yes}

test alias-1.8 "Replace proc with alias" {
	alias infoexists info exists
	infoexists any
} {0}

test curry-1.1 "One word curry" {
	set x 2
	set one [curry incr]
	$one x 
} {3}

test curry-1.4 "Two word curry" {
	set two [curry info exists]
	list [$two x] [$two y]
} {1 0}

test curry-1.5 "Delete curry" {
	unset one two
	collect
} {2}

test local-1.2 "local curry in proc" {
	proc a {} {
		local set p [curry info exists]
		set x 1
		list $p [$p x] [$p y]
	}
	lassign [a] p exists_x exists_y
	list [info procs $p] $exists_x $exists_y
} {{} 1 0}

test local-1.2 "set local curry in proc" {
	proc a {} {
		set p [local curry info exists]
		set x 1
		list $p [$p x] [$p y]
	}
	lassign [a] p exists_x exists_y
	list [info procs $p] $exists_x $exists_y
} {{} 1 0}

test local-1.3 "local alias in proc" {
	proc a {} {
		local alias p info exists
		set x 1
		list [p x] [p y]
	}
	lassign [a] exists_x exists_y
	list [info procs p] $exists_x $exists_y
} {{} 1 0}

test local-1.5 "local proc in proc" {
	set ::x 1
	proc a {} {
		local proc b {} { incr ::x }
		b
		set ::x
	}
	a
	list [info procs b] $::x
} {{} 2}

test local-1.6 "local lambda in lsort" {
	lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
} {a d f g}

test local-1.7 "check no reference procs" {
	info procs "<reference*"
} {}

test local-1.8 "local on non-proc" {
	list [catch {local set x blah} msg] $msg
} {1 {not a proc: "blah"}}

test local-1.9 "local on existing proc" {
	proc x {} {
		proc a {b} {incr b}
		local function a
		set c [lambda b {incr b -1}]
		local function $c
		lappend result [a 1] [$c 2]
	}
	set result [x]
	list [info procs a] $result 
} {{} {2 1}}

test statics-1.1 "missing static variable init" {
	unset -nocomplain c
	catch {
		proc a {b} {c} {
			# No initialiser for c
		}
	}
} 1

test statics-1.2 "static variable with invalid name" {
	catch {
		proc a {b} "{c\0d 4}" {
		}
	}
} 1

test statics-1.3 "duplicate static variable" {
	catch {
		proc a {b} {{c 1} {c 2}} {
		}
	}
} 1

test statics-1.4 "bad static variable init" {
	catch {
		proc a {b} {{c 1 2}} {
		}
	}
} 1

test local-2.1 "proc over existing proc" {
	proc a {b} {incr b}
	proc t {x} {
		proc a {b} {incr b -1}
		a $x
	}
	unset -nocomplain x
	lappend x [a 5]
	lappend x [t 5]
	lappend x [a 5]
} {6 4 4}

test local-2.2 "local proc over existing proc" {
	proc a {b} {incr b}
	proc t {x} {
		local proc a {b} {incr b -1}
		a $x
	}
	unset -nocomplain x
	lappend x [a 5]
	lappend x [t 5]
	lappend x [a 5]
} {6 4 6}

test local-2.3 "local proc over existing proc" {
	proc a {b} {incr b}
	proc t {x} {
		local proc a {b} {incr b -1}
		a $x
	}
	unset -nocomplain x
	lappend x [a 5]
	lappend x [t 5]
	lappend x [a 5]
} {6 4 6}

test upcall-1.1 "upcall pushed proc" {
	proc a {b} {incr b}
	local proc a {b} {
		incr b 10
		# invoke the original defn via upcall
		return [upcall a $b]
	}
	# Should call the new defn which will call the original defn
	a 3
} 14

test upcall-1.2 "upcall in proc" {
	proc a {b} {incr b}
	proc t {c} {
		local proc a {b} {
			incr b 10
			return [upcall a $b]
		}
		a $c
	}
	unset -nocomplain x
	lappend x [t 5]
	lappend x [a 5]
	set x
} {16 6}

test upcall-1.3 "double upcall" {
	proc a {} {return 1}
	local proc a {} {list 2 {*}[upcall a]}
	local proc a {} {list 3 {*}[upcall a]}
	a
} {3 2 1}

test upcall-1.4 "upcall errors" {
	proc a {} {return 1}
	list [catch {upcall a} msg] $msg
} {1 {no previous proc: "a"}}

test upcall-1.4 "upcall errors" {
	proc a {} {upcall a}
	list [catch a msg] $msg
} {1 {no previous proc: "a"}}

testreport