diff options
Diffstat (limited to 'tests')
58 files changed, 28582 insertions, 27 deletions
diff --git a/tests/all.tcl b/tests/all.tcl index 0a6f57f..8c0425d 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -18,5 +18,9 @@ configure {*}$argv -testdir [file dir [info script]] if {[singleProcess]} { interp debug {} -frame 1 } -runAllTests +if {[info exists ::env(TCLTEST_SHELL_OPTIONS)]} { + exit [runAllTests [interpreter] $::env(TCLTEST_SHELL_OPTIONS)] +} else { + exit [runAllTests] +} proc exit args {} diff --git a/tests/interp.test b/tests/interp.test index 4bc9fe2..2588e8d 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" @@ -50,13 +50,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp slaves ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer} test interp-1.8 {options for interp command} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -3576,6 +3576,31 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { unset -nocomplain result interp delete slave } -result foo +test interp-37.1 {interp regexp} { + list [catch {interp regexp} msg] $msg +} {1 {wrong # args: should be "interp regexp path ?type?"}} +test interp-37.2 {interp regexp} { + list [catch {interp regexp {} invalid} msg] $msg +} {1 {bad type "invalid": must be classic or pcre}} +test interp-37.3 {interp regexp} { + list [catch {interp regexp {} classic bogus} msg] $msg +} {1 {wrong # args: should be "interp regexp path ?type?"}} +test interp-37.4 {interp regexp} -setup { + unset -nocomplain ::env(TCL_REGEXP_PCRE) + interp create slave +} -body { + slave eval {interp regexp {}} +} -cleanup { + interp delete slave +} -result {classic} +test interp-37.5 {interp regexp} -setup { + unset -nocomplain ::env(TCL_REGEXP_PCRE) + interp create slave +} -body { + slave eval {interp regexp {} pcre} +} -cleanup { + interp delete slave +} -result {pcre} test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { catch {interp delete a} diff --git a/tests/l-core.test b/tests/l-core.test new file mode 100644 index 0000000..4e6aae4 --- /dev/null +++ b/tests/l-core.test @@ -0,0 +1,22690 @@ +# Test the L language. +# Copyright (c) 2007-2009 BitMover, Inc. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* + testConstraint exec [llength [info commands exec]] +} + +# Run these tests first, before setting the _L_TEST env variable. + +test err-1.1 {test that syntax err causes no code to be run} -body { +catch {L { syntax error }} try {} +L { puts("this should not be run"); } +} -output {} + +test err-1.2 {test that compiler warning causes no code to be run} -body { +catch {L { int err_not_used; }} try {} +L { puts("this should not be run"); } +} -output {} + +test err-1.3 {test that compiler error causes no code to be run} -body { +catch {L { int err_illegal_type = "bad"; }} try {} +L { puts("this should not be run"); } +} -output {} + +test err-1.4 {test that compiler error causes no code to be run 2} -body { +catch {L { +typedef int err1_4; +class err1_4; // caught in parser; calls L_err() instead of L_errf() +}} try {} +L { puts("this should not be run"); } +} -output {} + +# This causes L to keep running L code even after a compile error. +set ::env(_L_TEST) 1 + +test no-eq-ops-1 {test that old eq ops are now errors} -body { +#lang L --line=1 +"s" eq "s"; +"s" ne "s"; +"s" lt "s"; +"s" le "s"; +"s" gt "s"; +"s" ge "s"; +} -returnCodes error -match regexp -result {.*1: L Error: illegal comparison operator +.*2: L Error: illegal comparison operator +.*3: L Error: illegal comparison operator +.*4: L Error: illegal comparison operator +.*5: L Error: illegal comparison operator +.*6: L Error: illegal comparison operator +} + +# This tells L to run in a backwards compatibility mode for +# the old eq/ne/le/lt/ge/gt string-comparison operators. +set ::env(_L_ALLOW_EQ_OPS) 1 + +test lfile-1.0 {Test autowrapping of empty .l file} -setup { + set fname [makeFile {} lfile-1.0.l] +} -constraints { + exec +} -body { + exec [interpreter] $fname +} -cleanup { + removeFile lfile-1.0.l +} -result {} + +test lfile-1.1 {Test autowrapping of .l works} -setup { + set fname [makeFile { + void main() { + printf("hi mom\n"); + } + } lfile-1.1.l] +} -constraints { + exec +} -body { + exec [interpreter] $fname +} -cleanup { + removeFile lfile-1.1.l +} -result {hi mom} + +test lfile-1.1 {Test #lang L wrapping with -L and --L cmd-line options} -setup { + set fname [makeFile { + void main() { + puts("this is L"); + } + } lfile-1.1.n] +} -constraints { + exec +} -body { + set s1 [exec [interpreter] -L $fname] + set s2 [exec [interpreter] --L $fname] + puts $s1 + puts $s2 +} -cleanup { + removeFile lfile-1.1.n +} -output {this is L +this is L +} + +test lfile-1.3 {Test .l mapping via source command} -setup { + set fname [makeFile {printf("hello there");} lfile-1.3.l] +} -body { + source $fname +} -cleanup { + removeFile lfile-1.3.l +} -output {hello there} + +test lfile-1.4 {Test that in a Tcl script L does not call a Tcl main} -body { +proc main {} { puts "bad 1" } +} -output {} + +test lfile-1.5 {Test that L mains in multiple interps get invoked} -body { +#lang L --line=1 +void lfile_1_5() +{ + // Touch files instead of puts'ing since the slave interps seem + // to not get tcltest's puts so -output{} doesn't match it. + + string cmd1 = <<'END' +slave1 eval {#lang L +void main() { fclose(fopen("interp1", "w")); }} +END + string cmd2 = <<'END' +slave2 eval {#lang L +void main() { fclose(fopen("interp2", "w")); }} +END + eval("interp create slave1"); + eval("interp create slave2"); + eval(cmd1); + eval(cmd2); + unless (exists("interp1")) puts("bad 1"); + unless (exists("interp2")) puts("bad 2"); +} +lfile_1_5(); +} -cleanup { + removeFile "interp1" + removeFile "interp2" +} -output {} + +test lfile-1.6 {Test a Tcl file sourced from an L file} -setup { + set fname [makeFile {puts "in Tcl"} lfile-1.6.tcl] +} -body { +#lang L --line=1 +source("lfile-1.6.tcl"); +void lfile_1_6() +{ + puts("in L"); +} +lfile_1_6(); +} -cleanup { + removeFile lfile-1.6.tcl +} -output {in Tcl +in L +} + +test lhtml-1 {test lhtml in a .lhtml file} -setup { + set fname [makeFile {<?puts(nonewline: "line=${__LINE__} file=${__FILE__}");?> +line2 +<? +int lhtml1 = 4; +?> +line4 +<?unless (__LINE__ == 7) puts ("bad __LINE__=${__LINE__}"); +while (lhtml1--) puts(nonewline: "[${lhtml1}]"); +unless (__LINE__ == 9) puts ("bad __LINE__=${__LINE__}"); +?> +this with <?= "an L string" ?> inline +<?=__LINE__?> +} lhtml-1.lhtml] +} -body { +#lang L +void lhtml_1() +{ + int ret; + string got; + string tclsh = interpreter(); + string want = <<'END' +line=1 file=lhtml-1.lhtml +line2 + +line4 +[3][2][1][0] +this with an L string inline +12 +END + ret = system({tclsh, "lhtml-1.lhtml"}, undef, &got, undef); + unless (ret == 0) puts("bad 1"); + unless (got == want) puts("bad 2 '${got}'"); +} +lhtml_1(); +} -output {} + +test lhtml-2 {test #lang Lhtml} -body { +#lang Lhtml --line=1 +line <?=__LINE__?> of Lhtml +#lang tcl +puts "tcl code" +#lang Lhtml +more Lhtml +<?puts(nonewline: 1+2+3);?> +} -output {line 1 of Lhtml +tcl code +more Lhtml +6 +} + +test lhtml-3 {test errors in Lhtml document} -setup { + set fname [makeFile {<?puts(1+"bad1");?> +<?puts(1+"bad2"); +puts(1+"bad3"); +?> +line5 +<? +puts(1+"bad4"); +?> +} lhtml-3.lhtml] +} -body { +#lang L +void lhtml_3() +{ + int ret; + string err, out; + string tclsh = interpreter(); + string want = <<'END' +lhtml-3.lhtml:1: L Error: expected type int or float but got string in arithmetic operator +lhtml-3.lhtml:2: L Error: expected type int or float but got string in arithmetic operator +lhtml-3.lhtml:3: L Error: expected type int or float but got string in arithmetic operator +lhtml-3.lhtml:7: L Error: expected type int or float but got string in arithmetic operator +END + ret = system({tclsh, "lhtml-3.lhtml"}, undef, &out, &err); + if (ret == 0) puts("bad 1"); + unless (err =~ /${want}/) puts("bad 2 '${err}'"); +} +lhtml_3(); +} -output {} + +test lhtml-4 {test lhtml document parsing} -body { +# This test is from Oscar. Check that the Lhtml delims in the +# embedded code are not mistaken for the real delims. +#lang Lhtml +<html> +<head> +<title>The TITLE</title> +</head> +<body> +<h1>Header: <? printf("%s <? foo ?>", 2 + 2); ?></h1> +</body> +</html> +} -output {<html> +<head> +<title>The TITLE</title> +</head> +<body> +<h1>Header: 4 <? foo ?></h1> +</body> +</html> +} + +test lhtml-5 {test lhtml with L loops} -body { +#lang Lhtml +<html> +<tr> +<? int lhtml5; ?> +<? for (lhtml5 = 0; lhtml5 < 3; ++lhtml5) { ?> + <td><? puts(nonewline: lhtml5); ?></td> +<? } ?> +</tr> +</html> +} -output {<html> +<tr> + + + <td>0</td> + + <td>1</td> + + <td>2</td> + +</tr> +</html> +} + +test lhtml-6 {test premature EOF in lhtml document} -body { +#lang Lhtml --line=1 +<? // no ending delim +} -returnCodes error -match regexp -result {.*2: L Error: premature EOF +} + +test parse-1.0 {Test parsing an empty L script} -body { +#lang L --line=1 +} + +test parse-1.1 {Test parsing an L script that is just white space} -body { +#lang L --line=1 + + + +} + +test opts-1 {test command options 1} -body { +#lang L -nowarn +void opts_1() +{ + int not_used; // not used warning should be suppressed + printf("good"); +} +opts_1(); +} -output {good} + +test opts-2 {test command options 2} -body { +#lang L --nowarn +void opts_2() +{ + int not_used; // not used warning should be suppressed + printf("good"); +} +opts_2(); +} -output {good} + +test opts-2.1 {test command options 3} -body { +#lang L +#pragma nowarn +void opts_2_1() +{ + int not_used; // not used warning should be suppressed + printf("good"); +} +opts_2_1(); +} -output {good} + +test opts-4 {test command options 4} -body { +#lang L -poly +void opts_4() +{ + string s = "3"; + printf("%d", s+1); // would be an err w/o the -poly +} +opts_4(); +} -output {4} + +test opts-5 {test command options 5} -body { +#lang L --poly +void opts_5() +{ + string s = "3"; + printf("%d", s+1); // would be an err w/o the --poly +} +opts_5(); +} -output {4} + +test opts-6.1.2 {test -norun command option} -body { +#lang L -norun +void opts_6_1_2() +{ + /* -norun means compile but do not run */ + puts("should not see this"); +} +opts_6_1_2(); +} -output {} + +test opts-6.1.3 {test --norun command option} -body { +#lang L --norun +void opts_6_1_3() +{ + /* --norun means compile but do not run */ + puts("should not see this"); +} +opts_6_1_3(); +} -output {} + +test opts-6.2 {test that --norun option compiles} -body { +#lang L --norun +void opts_6_2() +{ + string s = "This is + an error"; +} +opts_6_2(); +} -returnCodes error -match regexp -result {.*missing string terminator.*} + +test opts-6.3 {test bad command option} -body { +#lang L -bad +void opts_6_3() {} +} -returnCodes error -result {L Error: illegal option '-bad' +} + +test opts-7 {test -nowarn command-line option} -setup { + set file [makeFile { + private void f() { + int not_used; + puts("good"); + } + f(); + } opts7.l .] +} -constraints { + exec +} -body { + # The script created above should not compile and run unless + # the command-line options are handled correctly. + set s1 [exec [interpreter] -nowarn $file] + set s2 [exec [interpreter] --nowarn $file] + puts $s1 + puts $s2 +} -cleanup { + removeFile $file +} -output "good\ngood\n" + +test opts-7.1 {test -norun command-line option} -setup { + set file [makeFile { + puts("should not get run"); + } opts7.1.l .] +} -constraints { + exec +} -body { + # The script created above should be compiled but not run + # if the command-line options are handled correctly. + set s1 [exec [interpreter] -norun $file] + set s2 [exec [interpreter] --norun $file] + puts $s1 + puts $s2 +} -cleanup { + removeFile $file +} -output "\n\n" + +test opts-8 {test -poly command-line option} -setup { + set file [makeFile { + private void f() { + string s = "3"; + printf("%d\n", s+1); + } + f(); + } opts8.l .] +} -constraints { + exec +} -body { + # The script created above should not compile and run unless + # the command-line options are handled correctly. + set s1 [exec [interpreter] -poly $file] + set s2 [exec [interpreter] --poly $file] + puts $s1 + puts $s2 +} -cleanup { + removeFile $file +} -output "4\n4\n" + +test opts-9 {test multiple command-line options} -setup { + set file [makeFile { + private void f() { + int not_used; + string s = "3"; + printf("%d\n", s+1); + } + f(); + } opts9.l .] +} -constraints { + exec +} -body { + # The script created above should not compile and run unless + # the command-line options are handled correctly. + set s1 [exec [interpreter] -poly -nowarn $file] + set s2 [exec [interpreter] --poly --nowarn $file] + puts $s1 + puts $s2 +} -cleanup { + removeFile $file +} -output "4\n4\n" + +test opts-10 {test multiple command-line options with app args} -setup { + set file [makeFile { + void main(int ac, string av[]) { + int i; + string s; + for (i = 1; i < ac; ++i) s .= av[i]; + puts(s); + } + } opts10.l .] +} -constraints { + exec +} -body { + # Check the application arguments are correctly passed to the L + # main() even in the presence of tclsh command-line args. + set s1 [exec [interpreter] $file] + set s2 [exec [interpreter] $file arg1] + set s3 [exec [interpreter] $file arg1 arg2] + set s4 [exec [interpreter] -nowarn $file] + set s5 [exec [interpreter] -nowarn $file arg1] + set s6 [exec [interpreter] -nowarn $file arg1 arg2] + set s7 [exec [interpreter] -nowarn -poly $file] + set s8 [exec [interpreter] -nowarn -poly $file arg1] + set s9 [exec [interpreter] -nowarn -poly $file arg1 arg2] + puts $s1 + puts $s2 + puts $s3 + puts $s4 + puts $s5 + puts $s6 + puts $s7 + puts $s8 + puts $s9 +} -cleanup { + removeFile $file +} -output "\narg1\narg1arg2\n\narg1\narg1arg2\n\narg1\narg1arg2\n" + +test opts-11 {test bad command-line option} -setup { + set file [makeFile { + void main() {} + } opts11.l . ] +} -body { +#lang L --line=1 +void opts_11() +{ + int ret; + string err, out[]; + string tclsh = eval("interpreter"); + + ret = system({tclsh, "--bad", "opts11.l"}, undef, &out, &err); + unless (ret == 1) puts("bad 1"); + unless (err =~ /L Error: illegal option '--bad'/) puts("bad 2 ${err}"); +} +opts_11(); +} -output {} + +test parse-1.2 {Test parsing an empty L file} -setup { + set fName [makeFile {} LFileTest] +} -constraints { + exec +} -body { + exec [interpreter] $fName +} -cleanup { + removeFile LFileTest +} -result {} + +test parse-1.3 {Test parsing an L file that just has whitespace} -setup { + set fName [makeFile { + + + + } LFileTest] +} -constraints { + exec +} -body { + exec [interpreter] $fName +} -cleanup { + removeFile LFileTest +} -result {} + +test parse-1.4 {parse an L function named by a pattern} -body { +#lang L --line=1 +poly Parse14Pattern_*(int a, ...rest) +{ + puts("${$1}${a}${rest}"); +} +#lang tcl +} -result {} + +test parse-1.5 {test handling of illegal character} -body { +#lang L --line=1 +@ +} -returnCodes error -match glob -result {*1: L Error: illegal character +@ +^ +} + +test parse-1.5.1 {test handling of illegal character in string interpolation} -body { +#lang L --line=1 +"${3@}"; +} -returnCodes error -match glob -result {*1: L Error: illegal character +"$\{3@ + ^ +} +# " sync up the quotes for emacs + +test parse-1.6 {test syntax error message 1} -body { +#lang L --line=1 +void parse_1_6() +{ +// Test that the err msg indenting is correct. +// No tab. +for() +} +} -returnCodes error -match glob -result {*5: L Error: syntax error, unexpected ) +for() + ^ +} + +test parse-1.7 {test syntax error message 2} -body { +#lang L --line=1 +void parse_1_7() +{ + // Test that the err msg indenting is correct. + // 1 tab. + for() +} +} -returnCodes error -match glob -result {*5: L Error: syntax error, unexpected ) + for() + ^ +} + +test parse-1.8 {test syntax error message 3} -body { +#lang L --line=1 +void parse_1_8() +{ + // Test that the err msg indenting is correct. + // 1 tab and spaces. + for() +} +} -returnCodes error -match glob -result {*5: L Error: syntax error, unexpected ) + for() + ^ +} + +test parse-1.9 {test syntax error message 4} -body { +#lang L --line=1 +void parse_1_9() +{ + // Test that the err msg indenting is correct. + // 2 tabs. + for() +} +} -returnCodes error -match glob -result {*5: L Error: syntax error, unexpected ) + for() + ^ +} + +test parse-1.10 {test syntax error message 5} -body { +#lang L --line=1 +void parse_1_10() +{ + // Test that the err msg indenting is correct. + // 2 tabs with spaces in between. + for() +} +} -returnCodes error -match glob -result {*5: L Error: syntax error, unexpected ) + for() + ^ +} + +test parse-1.11 {test syntax error message for error on line 1} -body { +#lang L --line=1 +void parse_1_11() { for() } // syntax error on line 1 +} -returnCodes error -match glob -result {*1: L Error: syntax error, unexpected ) +void parse_1_11() \{ for() + ^ +} + +test scan-1.1 {test detection of run-away string 1} -body { +#lang L --line=1 +void scan_1_1() +{ + string s = "This is bad + and should be an error"; + puts(s); +} +} -returnCodes {error} -match regexp -result {.*missing string terminator \"\n} + +test scan-1.2 {test detection of run-away string 2} -body { +#lang L --line=1 +void scan_1_2() +{ + string s = "This is bad +} +#" +} -returnCodes {error} -match regexp -result {.*missing string terminator \"\n} + +test scan-1.3 {test detection of run-away string 3} -body { +#lang L --line=1 +void scan_1_3() +{ + string s = 'This is bad + and should be an error'; + puts(s); +} +} -returnCodes {error} -match regexp -result {.*missing string terminator \'\n} + +test scan-1.4 {test detection of run-away string 4} -body { +#lang L --line=1 +void scan_1_4() +{ + string s = 'This is bad +} +#' +} -returnCodes {error} -match regexp -result {.*missing string terminator \'\n} + +test scan-1.4.2 {test detection of run-away string 5} -body { +#lang L --line=1 +void scan_1_4_2() +{ + string s = `echo this is bad +} +} -returnCodes {error} -match regexp -result {.*missing string terminator `\n} + +test scan-1.4.3 {test detection of run-away string 5} -body { +#lang L --line=1 +void scan_1_4_3() +{ + string s = `echo this is bad +>foo`; +} +} -returnCodes {error} -match regexp -result {.*missing string terminator `\n} + +test scan-1.4.4 {test detection of run-away regexp 1} -body { +#lang L --line=1 +void scan_1_4_4() +{ + string s = "x"; + + s =~ /xbad_no_terminator; +} +} -returnCodes {error} -match regexp -result {.*run-away regular expression\n} + +test scan-1.4.5 {test detection of run-away regexp 2} -body { +#lang L --line=1 +void scan_1_4_5() +{ + string s = "x"; + + s =~ s/x/bad_no_terminator; +} +} -returnCodes {error} -match regexp -result {.*run-away regular expression\n} + +test scan-1.4.6 {test detection of run-away regexp 3} -body { +#lang L --line=1 +void scan_1_4_6() +{ + string s = "x"; + + s =~ s/xbad_no_terminator/x; +} +} -returnCodes {error} -match regexp -result {.*run-away regular expression\n} + +test scan-1.5 {check escapes in single-quoted strings} -body { +#lang L --line=1 +void scan_1_5() +{ + string s; + + s = '\a\t\n\001'; + unless (length(s) == 10) puts("bad 1.0"); + unless ((s[0] eq "\\") && (s[1] eq "a")) puts("bad 1.1"); + unless ((s[2] eq "\\") && (s[3] eq "t")) puts("bad 1.2"); + unless ((s[4] eq "\\") && (s[5] eq "n")) puts("bad 1.3"); + unless ((s[6] eq "\\") && (s[7] eq "0")) puts("bad 1.4"); + unless ((s[8] eq "0") && (s[9] eq "1")) puts("bad 1.5"); + + s = '\\\''; + unless (length(s) == 2) puts("bad 2.0"); + unless ((s[0] eq "\\") && (s[1] eq "'")) puts("bad 2.1"); + + /* + * The following test doesn't work unless run from the + * command line. Perhaps tcltest is munging the string. ? + s = 'line\ +break'; + unless (s eq "line\nbreak") puts("bad 3.1"); + */ +} +scan_1_5(); +} -output {} + +test scan-1.6 {check escapes in double-quoted strings} -body { +#lang L --line=1 +void scan_1_6() +{ + string s; + + s = "\a\t\n\r\\\""; + unless (length(s) == 6) puts("bad 1.0"); + unless ((s[0] eq "a") && (s[1] eq "\t")) puts("bad 1.1"); + unless ((s[2] eq "\n") && (s[3] eq "\r")) puts("bad 1.2"); + unless ((s[4] eq "\\") && (s[5] eq "\"")) puts("bad 1.3"); + + /* + * The following test doesn't work unless run from the + * command line. Perhaps tcltest is munging the string. ? + s = "line\ +break"; + unless (s eq "line\nbreak") puts("bad 2.1"); + */ +} +scan_1_6(); +} -output {} + +test scan-1.7 {test here documents 1} -body { +#lang L --line=1 +void scan_1_7() +{ + /* Vary the whitespace. */ + + string s1,s2,s3,s4,s5,s6,s7,s8,s10,s11; + + s1 = <<'E' +str1 +E + unless (s1 eq "str1\n") puts("bad 1"); + + s2 = <<'EN' +str2 +EN + unless (s2 eq "str2\n") puts("bad 2"); + + s3 = <<'END' +str3 +END + unless (s3 eq "str3\n") puts("bad 3"); + + s4 =<<'END' +str4 +END + unless (s4 eq "str4\n") puts("bad 4"); + + s5 = <<'END' +str5 +END + unless (s5 eq "str5\n") puts("bad 5"); + + s6 = <<'END' +str6 +END + unless (s6 eq "str6\n") puts("bad 6"); + + s7 = <<'END' +str7 +END + unless (s7 eq "str7\n") puts("bad 7"); + + s8 = +<<'END' +str8 +END + unless (s8 eq "str8\n") puts("bad 8"); + + /* + * These test the patterns in the scanner that check for a ; + * after the end delim. Note that there are spaces after + * some of the ; below. + */ + + s10 = <<'END' +NOTEND; +NOTEND ; +NOTEND; +NOTEND ; +END + unless (s10 eq "NOTEND;\nNOTEND ;\nNOTEND; \nNOTEND ; \n") { + puts("bad 10"); + } + + s11 = <<END +NOTEND; +NOTEND ; +NOTEND; +NOTEND ; +END + unless (s11 eq "NOTEND;\nNOTEND ;\nNOTEND; \nNOTEND ; \n") { + puts("bad 11"); + } + + /* Semicolons are allowed after the delim now. */ + + s11 = <<END +NOTEND; +END; + unless (s11 == "NOTEND;\n") puts("bad 12"); + + s11 = <<'END' +NOTEND; +END; + unless (s11 == "NOTEND;\n") puts("bad 13"); + + /* + * Test whitespace prefix. + */ + + s11 = + <<END + line1 + + line2 + ENDNOT + END; + unless (s11 == "line1\n\nline2\nENDNOT\n") puts("bad 19.1"); + + s11 = + <<'END' + line1 + + line2 + ENDNOT + END; + unless (s11 == "line1\n\nline2\nENDNOT\n") puts("bad 19.2"); +} +scan_1_7(); +} -output {} + +test scan-1.8 {test here documents 2} -body { +#lang L --line=1 -nowarn +string ::scan_1_8a; +void scan_1_8() +{ + string s; + string foo = "foo"; + + /* Check string interpolation. */ + + s = <<END +interpolated string ${foo} +END + unless (s eq "interpolated string foo\n") puts("bad 1"); + + s = <<'END' +uninterpolated string ${foo} +END + unless (s eq "uninterpolated string \${foo}\n") puts("bad 2"); + + /* + * The scanner handles an ID inside a here document + * differently than a non-ID, so try both. + */ + + s = <<END +${foo} +aword +two words +END + unless (s eq "foo\naword\ntwo words\n") puts("bad 3"); + + s = <<'END' +${foo} +aword +two words +END + unless (s eq "\${foo}\naword\ntwo words\n") puts("bad 4"); + + /* + * Ensure delimeter isn't found mistakenly. It isn't + * allowed to have leading or trailing whitespace or + * anything else. + */ + + s = <<END +EN +EN D +END + ENDx +ENDEND +END + unless (s eq "EN\nEN D\nEND \n ENDx\nENDEND\n") puts("bad 5"); + + s = <<'END' +EN +EN D +END + ENDx +ENDEND +END + unless (s eq "EN\nEN D\nEND \n ENDx\nENDEND\n") puts("bad 6"); + + /* + * Check escapes: + * non-interpolated here doc: + * no escapes + * interpolated here doc: + * \\ \$ \` get escaped + * \<newline> gets ignored + * \x for anything else, not escaped + * + * We can't test \<newline> by simply writing it here because the + * tcltest parsing messes with it. + */ + + s = <<END +$\\\$\`\n\tx +END + unless (s eq "$\\$`\\n\\tx\n") puts("bad 9.1"); + + s = <<'END' +a\tb\nc\\d\x\\\' +END + unless (s eq "a\\tb\\nc\\\\d\\x\\\\\\'\n") puts("bad 9.2"); + + /* + * Checking \<newline> is tough since tcltest's parsing of + * the test source won't let \<newline> through. So create + * strings of L code and eval those. + * + * Note: The :: in front of the global scan_1_8a works around + * an L bug with global upvar shadows which will be fixed + * soon in a different cset. + */ + // x\<newline> + // y + L("::scan_1_8a = <<END\nx\\\ny\nEND\n"); + unless (::scan_1_8a eq "xy\n") puts("bad 9.3 ${::scan_1_8a}"); + L("::scan_1_8a = <<'END'\nx\\\ny\nEND\n"); + unless (::scan_1_8a eq "x\\\ny\n") puts("bad 9.4"); + // x\<newline> + // y\<newline> + L("::scan_1_8a = <<END\nx\\\ny\\\nEND\n"); + unless (::scan_1_8a eq "xy") puts("bad 9.5"); + L("::scan_1_8a = <<'END'\nx\\\ny\\\nEND\n"); + unless (::scan_1_8a eq "x\\\ny\\\n") puts("bad 9.6"); + // \<newline> + L("::scan_1_8a = <<END\n\\\nEND\n"); + unless (::scan_1_8a eq "") puts("bad 9.7"); + L("::scan_1_8a = <<'END'\n\\\nEND\n"); + unless (::scan_1_8a eq "\\\n") puts("bad 9.8"); + + /* Check `cmd` inside interpolated here document. */ + s = <<END +abc +`perl -e 'print "cmd"'` +def +END + unless (s eq "abc\ncmd\ndef\n") puts("bad 20.1"); + + /* Check multiple `cmd` in a here document. */ + + s = <<END +abc +`perl -e 'print "cmd1"'``perl -e 'print "cmd2"'` +def +END + unless (s eq "abc\ncmd1cmd2\ndef\n") puts("bad 21.1"); + + s = <<END +abc +`perl -e 'print "cmd1"'``perl -e 'print "cmd2"'``perl -e 'print "cmd3"'` +def +END + unless (s eq "abc\ncmd1cmd2cmd3\ndef\n") puts("bad 21.2"); +} +scan_1_8(); +} -output {} + +test scan-1.9 {test here document error 1} -body { +#lang L --line=1 +void +scan_1_9() +{ + /* + * Error, since nothing is allowed after the END except + * a newline. + */ + string s1 = <<'END'err +END +} +scan_1_9(); +} -returnCodes {error} -match regexp -result {.*8: L Error: illegal characters after here-document delimeter +} + +test scan-1.10 {test here document error 2} -body { +#lang L --line=1 +void +scan_1_10() +{ + /* + * Error, since nothing is allowed after the END except + * a newline. + */ + string s1 = <<END err +END +} +scan_1_10(); +} -returnCodes {error} -match regexp -result {.*8: L Error: illegal characters after here-document delimeter +} + +test scan-1.11 {test nested here documents error} -body { +#lang L --line=1 +void +scan_1_11() +{ + string s1, s2 = <<END +${s1=<<BAD +should be error +BAD +} +END +} +scan_1_11(); +} -returnCodes {error} -match regexp -result ".*nested here documents illegal.*" + +test scan-1.12 {test here document error 3} -body { +#lang L --line=1 +void +scan_1_12() +{ + /* + * White space before or after the delim is illegal. + */ + + string s = << END + END; +} +scan_1_12(); +} -returnCodes {error} -match regexp -result {.*8: L Error: illegal characters before here-document delimeter +} + +test scan-1.13 {test here document error 4} -body { +#lang L --line=1 +void +scan_1_13() +{ + /* + * White space before or after the delim is illegal. + */ + + string s = <<END + END; +} +scan_1_13(); +} -returnCodes {error} -match regexp -result {.*8: L Error: illegal characters after here-document delimeter +} + +test scan-1.14 {test here document error 5} -body { +#lang L --line=1 +void +scan_1_14() +{ + /* + * <<-END as the delim works in the Bourne shell but is + * an error in L. + */ + + string s = <<-END + END; +} +scan_1_14(); +} -returnCodes {error} -match regexp -result {.*9: L Error: <<- unsupported, use =\\n\\t<<END to strip one leading tab +} + +test scan-1.15 {test here document error 6} -body { +#lang L --line=1 +void +scan_1_15() +{ + /* + * <<-'END' as the delim works in the Bourne shell but is + * an error in L. + */ + + string s = <<-'END' + END; +} +scan_1_15(); +} -returnCodes {error} -match regexp -result {.*9: L Error: <<- unsupported, use =\\n\\t<<END to strip one leading tab +} + +test scan-1.16 {check auto string concatenation} -body { +#lang L --line=1 +void scan_1_16() +{ + string s; + + s = "a" +"b" +"c"; + unless (s eq "abc") puts("bad 1"); + + s = "d" + "e" + "f"; + unless (s eq "def") puts("bad 2"); + + s = 'a' +'b' +'c'; + unless (s eq "abc") puts("bad 3"); + + s = 'd' + 'e' + 'f'; + unless (s eq "def") puts("bad 4"); +} +scan_1_16(); +} -output {} + +test scan-1.17 {check \u escapes in strings} -body { +#lang L --line=1 +void scan_1_17() +{ + string s; + + s = "\u3"; + unless (ord(s) == 0x3) puts("bad 1.1"); + s = "\u34"; + unless (ord(s) == 0x34) puts("bad 1.2"); + s = "\u345"; + unless (ord(s) == 0x345) puts("bad 1.3"); + s = "\u3456"; + unless (ord(s) == 0x3456) puts("bad 1.4"); + + s = "xy\u3z"; + unless (length(s) == 4) puts("bad 2.1"); + unless ((ord(s[2]) == 0x3) && (s[3] eq "z")) puts("bad 2.2"); + s = "xy\u34z"; + unless (length(s) == 4) puts("bad 2.3"); + unless ((ord(s[2]) == 0x34) && (s[3] eq "z")) puts("bad 2.4"); + s = "xy\u345z"; + unless (length(s) == 4) puts("bad 2.5"); + unless ((ord(s[2]) == 0x345) && (s[3] eq "z")) puts("bad 2.6"); + s = "xy\u3456z"; + unless (length(s) == 4) puts("bad 2.7"); + unless ((ord(s[2]) == 0x3456) && (s[3] eq "z")) puts("bad 2.8"); + s = "xy\u34567"; + unless (length(s) == 4) puts("bad 2.9"); + unless ((ord(s[2]) == 0x3456) && (s[3] eq "7")) puts("bad 2.10"); +} +scan_1_17(); +} -output {} + +test scan-2.1 {test #line directive} -body { +#lang L --line=1 +#line 1 "scan2-1.l" +void scan_2_a() +{ + bad1; +} + +#line 2 "scan2-2.l" +void scan_2_b() +{ + bad2; +} + + + + + + +#line 13 "scan2-3.l" +void scan_2_c() +{ + bad3; +} +} -returnCodes {error} -match regexp -result {scan2-1.l:3: L Error: undeclared variable: bad1 +scan2-2.l:4: L Error: undeclared variable: bad2 +scan2-3.l:15: L Error: undeclared variable: bad3 +} + +# This is test include-1.0 with #line's thrown in. +test scan-2.2 {test #line directive with include files} -setup { + set fname [makeFile {#line 1 "foo.l" + ++scan_2_2; + unless (basename(__FILE__) eq "foo.l") puts("bad 1"); + unless (__LINE__ == 3) puts("bad 2"); + } scan-2.2.l [file dirname [info script]]] +} -body { +#lang L --line=1 +unless (__LINE__ == 1) puts("bad 1.1"); +int scan_2_2 = 0; +puts(scan_2_2); +unless (__LINE__ == 4) puts("bad 1.2"); +#include "scan-2.2.l" +unless (__LINE__ == 6) puts("bad 1.3"); +puts(scan_2_2); +// Check variations in spacing and punctation. +// The compiler should include scan-2.2.l only once. +#include "scan-2.2.l" +unless (__LINE__ == 11) puts("bad 1.4"); +#include "scan-2.2.l" +unless (__LINE__ == 13) puts("bad 1.5"); +#include "scan-2.2.l" +unless (__LINE__ == 15) puts("bad 1.6"); +#include"scan-2.2.l" +unless (__LINE__ == 17) puts("bad 1.7"); +puts(scan_2_2); +} -cleanup { + removeFile $fname +} -output {0 +1 +1 +} + +# This is test include-1.1 with #line's thrown in. +test scan-2.3 {test #line directive with nested include files} -setup { +# +# The code for these files isn't indented because L recognizes +# include() only when it starts at the beginning of the line. +# + set fname1 [makeFile {#line 1 "foo1.l" +#include "scan-2.3-2.l" +unless (basename(__FILE__) eq "foo1.l") puts("bad 1"); +unless (__LINE__ == 3) puts("bad 2 ${__LINE__}"); +} scan-2.3-1.l [file dirname [info script]]] + set fname2 [makeFile {#line 1 "foo2.l" +int scan_2_3a = 3; +unless (basename(__FILE__) eq "foo2.l") puts("bad 3"); +unless (__LINE__ == 3) puts("bad 4"); +#include "scan-2.3-3.l" +unless (basename(__FILE__) eq "foo2.l") puts("bad 5"); +unless (__LINE__ == 6) puts("bad 6 ${__LINE__}"); +} scan-2.3-2.l .] + set fname3 [makeFile {#line 1 "foo3.l" +int scan_2_3b = 4; +unless (basename(__FILE__) eq "foo3.l") puts("bad 7"); +unless (__LINE__ == 3) puts("bad 8"); +} scan-2.3-3.l .] +} -body { +#lang L +#line 1 "foo4.l" +unless (__LINE__ == 1) puts("bad 10.0"); +unless (__FILE__ eq "foo4.l") puts("bad 10.1"); +#include "scan-2.3-1.l" +unless (__LINE__ == 4) puts("bad 10.1.2"); +unless (__FILE__ eq "foo4.l") puts("bad 10.2"); +unless (scan_2_3a == 3) puts("bad 10.3"); +unless (scan_2_3b == 4) puts("bad 10.4"); +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 +} -output {} + +test scan-2.4 {test malformed #line directives} -body { +#lang L --line=1 +#line 0 +#line +#line xyx +} -returnCodes error -match regexp -result {.*1: L Error: malformed #line +.*2: L Error: malformed #line +.*3: L Error: malformed #line +} + +test scan-3.1 {test line numbers in compile- and run-time messages, .l file} -setup { + +# This test creates three .l files. One is given to L, and the other two are +# brought in via #include or source(). Several things are tested with the same +# code. First, line #s in type errors which the compiler will complain about +# unless compiling with --poly. Second, line #s in run-time errors which +# selectively can be hit by setting the SCAN31 environment variable. +# Third, __LINE__. + +##################################################### +# scan-3.1-1.l + set fname1 [makeFile { +string g = getenv("SCAN31"); +unless (__LINE__ == 3) puts("bad 1.1"); +if ("${basename(__FILE__)}:${__LINE__}" == g) g + 1; // line 4 +#include "scan-3.1-2.l" +source("scan-3.1-3.l"); +unless (__LINE__ == 7) puts("bad 1.2"); +void main() +{ + f1(); + f2(); + + if ("${basename(__FILE__)}:${__LINE__}" == g) g + 1; // line 13 +} +puts("test ran"); +} scan-3.1-1.l .] + +##################################################### +# scan-3.1-2.l + set fname2 [makeFile { +/* + * This code conditionally causes a run-time error. + */ +unless (__LINE__ == 5) puts("bad 2.1"); +void f1() { + if ("${basename(__FILE__)}:${__LINE__}" == g) g + 1; // line 7 +} +unless (__LINE__ == 9) puts("bad 2.2"); +} scan-3.1-2.l .] + +##################################################### +# scan-3.1-3.l + set fname3 [makeFile { +/* + * This code conditionally causes a run-time error. + */ +extern string ::g; +unless (__LINE__ == 6) puts("bad 3.1"); +void f2() { + if ("${basename(__FILE__)}:${__LINE__}" == ::g) ::g + 1; // line 8 +} +unless (__LINE__ == 10) puts("bad 3.2"); +} scan-3.1-3.l .] + +} -body { +#lang L +void scan31_chk(string cmd[], string expected{string}[]) +{ + int bad, ret; + string err, exs[], k, out, s; + + foreach (k=>exs in expected) { + putenv("SCAN31=%s", k); + ret = system(cmd, undef, &out, &err); + unless (ret == 1) puts("bad 2.1"); + bad = 0; + foreach (s in exs) { + unless (err =~ /${s}/) { + puts("bad 2.2: expected '${s}'"); + ++bad; + } + } + if (bad) { + puts("Got:"); + puts("-----------------------------------------------"); + puts(err); + puts("-----------------------------------------------"); + } + } +} +void scan_3_1() +{ + int ret; + string err, out; + string expected{string}[]; + string tclsh = interpreter(); + + /* + * The first run gets the compiler error messages. + */ + expected = { + "0" => { + 'scan-3.1-1.l:4: L Error: expected type int', + 'scan-3.1-2.l:7: L Error: expected type int', + 'scan-3.1-1.l:13: L Error: expected type int', + }, + }; + scan31_chk({tclsh, "scan-3.1-1.l"}, expected); + + /* + * The next run gets the run-time error messages. + * Use --poly so the type errors in the test code do not + * prevent compilation. Run several times and pass in the + * necessary cmd-line options so the code hits each of its + * various possible run-time errors. + */ + expected = { + "scan-3.1-1.l:4" => { + 'use non-numeric string as operand of "\+"', + 'procedure "\d+%l_toplevel" line 4', + }, + "scan-3.1-1.l:13" => { + 'use non-numeric string as operand of "\+"', + 'procedure "main" line 13', + }, + "scan-3.1-2.l:7" => { + 'use non-numeric string as operand of "\+"', + 'procedure "f1" line 7', + 'procedure "main" line 10', + }, + "scan-3.1-3.l:8" => { + 'use non-numeric string as operand of "\+"', + 'procedure "f2" line 8', + 'procedure "main" line 11', + }, + }; + scan31_chk({tclsh, "--poly", "scan-3.1-1.l"}, expected); + + /* + * Finally, let the code run without any errors so that the + * checks of __LINE__ in it are run. + */ + putenv("SCAN31=0"); + ret = system({tclsh, "--poly", "scan-3.1-1.l"}, undef, &out, &err); + if (ret) puts("bad 3.1"); + unless (out == "test ran\n") puts("bad 3.2"); +} +scan_3_1(); +} -output {} + +test scan-3.2 {test line numbers in compile- and run-time messages, .tcl file} -setup { + +# This test is like scan-3.1 but with .tcl files instead of .l files. + +##################################################### +# scan-3.2-1.tcl + set fname1 [makeFile { +#lang L +string g = getenv("SCAN31"); +unless (__LINE__ == 4) puts("bad 1.1"); +if ("${basename(__FILE__)}:${__LINE__}" == g) g + 1; // line 5 +#lang tcl +# more Tcl code +source scan-3.2-2.tcl +#lang L +unless (__LINE__ == 10) puts("bad 1.2"); +if ("${basename(__FILE__)}:${__LINE__}" == g) g + 1; // line 11 +f1(); +puts("test ran"); +} scan-3.2-1.tcl .] + +##################################################### +# scan-3.2-2.tcl + set fname2 [makeFile { +#lang L +unless (__LINE__ == 3) puts("bad 2.1"); +if ("${basename(__FILE__)}:${__LINE__}" == g) g + 1; // line 4 +void f1() { + if ("${basename(__FILE__)}:${__LINE__}" == g) g + 1; // line 6 +} +unless (__LINE__ == 8) puts("bad 2.2"); +} scan-3.2-2.tcl .] + +} -body { +#lang L --nowarn +void scan_3_2() +{ + int ret; + string err, out; + string expected{string}[]; + string tclsh = interpreter(); + + /* + * The first run gets the compiler error messages in the + * first block of L code. + */ + expected = { + "0" => { + 'scan-3.2-1.tcl:5: L Error: expected type int', + }, + }; + scan31_chk({tclsh, "scan-3.2-1.tcl"}, expected); + + /* + * The next run gets the run-time error messages. + * Use --poly so the type errors in the test code do not + * prevent compilation. Run several times and pass in the + * necessary cmd-line options so the code hits each of its + * various possible run-time errors. + */ + expected = { + "scan-3.2-1.tcl:5" => { + 'use non-numeric string as operand of "\+"', + 'procedure "\d+%l_toplevel" line 5', + }, + "scan-3.2-1.tcl:11" => { + 'use non-numeric string as operand of "\+"', + 'procedure "\d+%l_toplevel" line 11', + }, + "scan-3.2-2.tcl:4" => { + 'use non-numeric string as operand of "\+"', + 'procedure "\d+%l_toplevel" line 4', + }, + "scan-3.2-2.tcl:6" => { + 'use non-numeric string as operand of "\+"', + 'procedure "f1" line 6', + 'procedure "\d+%l_toplevel" line 12', + }, + }; + scan31_chk({tclsh, "--poly", "scan-3.2-1.tcl"}, expected); + + /* + * Finally, let the code run without any errors so that the + * checks of __LINE__ in it are run. + */ + putenv("SCAN31=0"); + ret = system({tclsh, "--poly", "scan-3.2-1.tcl"}, undef, &out, &err); + if (ret) puts("bad 3.1"); + unless (out == "test ran\n") puts("bad 3.2"); +} +scan_3_2(); +} -output {} + +test scan-4 {check for regression if "L" passed as an arg} -body { +#lang L +string scan_4f(...args) +{ + return (join(" ", args)); +} +void scan_4() +{ + unless (eval("scan_4f a b") == "a b") puts("bad 1"); + unless (eval("scan_4f L") == "L") puts("bad 2"); + unless (eval("scan_4f L L") == "L L") puts("bad 3"); + unless (eval("scan_4f a L") == "a L") puts("bad 4"); + unless (eval("scan_4f L b") == "L b") puts("bad 5"); + unless (eval("scan_4f a L b") == "a L b") puts("bad 6"); +} +scan_4(); +} -output {} + +test scan-5 {check that trailing newline is scanned} -body { +#lang L +// The L-compiler scanner requires comments to end in a newline. +#lang tcl +# But a past compiler bug would eat them, causing syntax errors. +#lang L +// This test checks that case. +} -output {} + +test scan-6 {test 'and','or','xor','not' unimplemented reserved words} -body { +#lang L --line=1 +void scan_6() +{ + if (1 and 2) {} + if (1 or 2) {} + if (1 or (2 and 3)) {} + if (not 1 xor 2) {} +} +} -returnCodes error -match regexp -result {.*3: L Error: 'and','or','xor','not' are unimplemented reserved words +.*4: L Error: 'and','or','xor','not' are unimplemented reserved words +.*5: L Error: 'and','or','xor','not' are unimplemented reserved words +.*6: L Error: 'and','or','xor','not' are unimplemented reserved words +} + +test unicode-1 {test unicode in string constants and here documents} -body { +#lang L --line=1 +void unicode_1() +{ + string h, j, s; + + // This has twelve Hebrew characters including two ASCII spaces + // in an interpolated string (double quotes). + h = "זו השפה שלנו"; + unless (length(h) == 12) puts("bad 1.1"); + unless (ord(h[0]) == 0x05d6) puts("bad 1.2"); // Zayen + unless (ord(h[1]) == 0x05d5) puts("bad 1.3"); // Vav + unless (ord(h[2]) == 0x0020) puts("bad 1.4"); // space + unless (ord(h[3]) == 0x05d4) puts("bad 1.5"); // He + unless (ord(h[4]) == 0x05e9) puts("bad 1.6"); // Shin + unless (ord(h[5]) == 0x05e4) puts("bad 1.7"); // Pe + unless (ord(h[6]) == 0x05d4) puts("bad 1.8"); // He + unless (ord(h[7]) == 0x0020) puts("bad 1.9"); // space + unless (ord(h[8]) == 0x05e9) puts("bad 1.10"); // Shin + unless (ord(h[9]) == 0x05dc) puts("bad 1.11"); // Lamed + unless (ord(h[10]) == 0x05e0) puts("bad 1.12"); // Hun + unless (ord(h[11]) == 0x05d5) puts("bad 1.13"); // Vav + if (defined(h[12])) puts("bad 1.14"); + + // Same string as above except in an interpolated here + // document (and therefore with a trailing ASCII newline. + h = <<END +זו השפה שלנו +END + unless (length(h) == 13) puts("bad 2.1"); + unless (ord(h[0]) == 0x05d6) puts("bad 2.2"); // Zayen + unless (ord(h[1]) == 0x05d5) puts("bad 2.3"); // Vav + unless (ord(h[2]) == 0x0020) puts("bad 2.4"); // space + unless (ord(h[3]) == 0x05d4) puts("bad 2.5"); // He + unless (ord(h[4]) == 0x05e9) puts("bad 2.6"); // Shin + unless (ord(h[5]) == 0x05e4) puts("bad 2.7"); // Pe + unless (ord(h[6]) == 0x05d4) puts("bad 2.8"); // He + unless (ord(h[7]) == 0x0020) puts("bad 2.9"); // space + unless (ord(h[8]) == 0x05e9) puts("bad 2.10"); // Shin + unless (ord(h[9]) == 0x05dc) puts("bad 2.11"); // Lamed + unless (ord(h[10]) == 0x05e0) puts("bad 2.12"); // Hun + unless (ord(h[11]) == 0x05d5) puts("bad 2.13"); // Vav + unless (ord(h[12]) == 0x0a) puts("bad 2.14"); // newline + if (defined(h[13])) puts("bad 2.15"); + + // This has 14 Kanji characters including two Kanji (0x3000) spaces + // in an uninterpolated string (single quotes). + j = '私は 日本語が 分かります'; + unless (length(j) == 13) puts("bad 3.1"); + unless (ord(j[0]) == 0x79c1) puts("bad 3.2"); + unless (ord(j[1]) == 0x306f) puts("bad 3.3"); + unless (ord(j[2]) == 0x3000) puts("bad 3.4"); + unless (ord(j[3]) == 0x65e5) puts("bad 3.5"); + unless (ord(j[4]) == 0x672c) puts("bad 3.6"); + unless (ord(j[5]) == 0x8a9e) puts("bad 3.7"); + unless (ord(j[6]) == 0x304c) puts("bad 3.8"); + unless (ord(j[7]) == 0x3000) puts("bad 3.9"); + unless (ord(j[8]) == 0x5206) puts("bad 3.10"); + unless (ord(j[9]) == 0x304b) puts("bad 3.11"); + unless (ord(j[10]) == 0x308a) puts("bad 3.12"); + unless (ord(j[11]) == 0x307e) puts("bad 3.13"); + unless (ord(j[12]) == 0x3059) puts("bad 3.14"); + if (defined(j[13])) puts("bad 3.15"); + + // Same as above, but an uninterpolated here document. + j = <<'END' +私は 日本語が 分かります +END + unless (length(j) == 14) puts("bad 4.1"); + unless (ord(j[0]) == 0x79c1) puts("bad 4.2"); + unless (ord(j[1]) == 0x306f) puts("bad 4.3"); + unless (ord(j[2]) == 0x3000) puts("bad 4.4"); + unless (ord(j[3]) == 0x65e5) puts("bad 4.5"); + unless (ord(j[4]) == 0x672c) puts("bad 4.6"); + unless (ord(j[5]) == 0x8a9e) puts("bad 4.7"); + unless (ord(j[6]) == 0x304c) puts("bad 4.8"); + unless (ord(j[7]) == 0x3000) puts("bad 4.9"); + unless (ord(j[8]) == 0x5206) puts("bad 4.10"); + unless (ord(j[9]) == 0x304b) puts("bad 4.11"); + unless (ord(j[10]) == 0x308a) puts("bad 4.12"); + unless (ord(j[11]) == 0x307e) puts("bad 4.13"); + unless (ord(j[12]) == 0x3059) puts("bad 4.14"); + unless (ord(j[13]) == 0x0a) puts("bad 4.15"); + if (defined(j[14])) puts("bad 4.16"); + + // Some diacritics. + s = "Algunos signos diacríticos del español"; + unless (length(s) == 38) puts("bad 5.1"); + unless (ord(s[20]) == 0x00ed) puts("bad 5.2"); + unless (ord(s[35]) == 0x00f1) puts("bad 5.3"); +} +unicode_1(); +} -output {} + +test unicode-2 {test manipulation of unicode strings} -body { +#lang L --line=1 +void unicode_2() +{ + string h = "זו השפה שלנו"; + string j = '私は 日本語が 分かります'; + + h .= j; + unless (h eq "זו השפה שלנו私は 日本語が 分かります") puts("bad 1.0"); + unless (length(h) == 25) puts("bad 1.1"); + unless (ord(h[0]) == 0x05d6) puts("bad 1.2"); + unless (ord(h[1]) == 0x05d5) puts("bad 1.3"); + unless (ord(h[2]) == 0x0020) puts("bad 1.4"); + unless (ord(h[3]) == 0x05d4) puts("bad 1.5"); + unless (ord(h[4]) == 0x05e9) puts("bad 1.6"); + unless (ord(h[5]) == 0x05e4) puts("bad 1.7"); + unless (ord(h[6]) == 0x05d4) puts("bad 1.8"); + unless (ord(h[7]) == 0x0020) puts("bad 1.9"); + unless (ord(h[8]) == 0x05e9) puts("bad 1.10"); + unless (ord(h[9]) == 0x05dc) puts("bad 1.11"); + unless (ord(h[10]) == 0x05e0) puts("bad 1.12"); + unless (ord(h[11]) == 0x05d5) puts("bad 1.13"); + unless (ord(h[12]) == 0x79c1) puts("bad 1.14"); + unless (ord(h[13]) == 0x306f) puts("bad 1.15"); + unless (ord(h[14]) == 0x3000) puts("bad 1.16"); + unless (ord(h[15]) == 0x65e5) puts("bad 1.17"); + unless (ord(h[16]) == 0x672c) puts("bad 1.18"); + unless (ord(h[17]) == 0x8a9e) puts("bad 1.19"); + unless (ord(h[18]) == 0x304c) puts("bad 1.20"); + unless (ord(h[19]) == 0x3000) puts("bad 1.21"); + unless (ord(h[20]) == 0x5206) puts("bad 1.22"); + unless (ord(h[21]) == 0x304b) puts("bad 1.23"); + unless (ord(h[22]) == 0x308a) puts("bad 1.24"); + unless (ord(h[23]) == 0x307e) puts("bad 1.25"); + unless (ord(h[24]) == 0x3059) puts("bad 1.26"); + if (defined(h[25])) puts("bad 1.27"); + + // Delete one of the Kanji characters. + undef(h[12]); + unless (h eq "זו השפה שלנוは 日本語が 分かります") puts("bad 2.0"); + unless (length(h) == 24) puts("bad 2.1"); + unless (ord(h[0]) == 0x05d6) puts("bad 2.2"); + unless (ord(h[11]) == 0x05d5) puts("bad 2.3"); + unless (ord(h[12]) == 0x306f) puts("bad 2.4"); + unless (ord(h[23]) == 0x3059) puts("bad 2.5"); + if (defined(h[24])) puts("bad 2.6"); + + // Now delete the first space. + undef(h[2]); + unless (h eq "זוהשפה שלנוは 日本語が 分かります") puts("bad 3.0"); + unless (length(h) == 23) puts("bad 3.1"); + unless (ord(h[0]) == 0x05d6) puts("bad 3.2"); + unless (ord(h[2]) == 0x05d4) puts("bad 3.3"); + unless (ord(h[22]) == 0x3059) puts("bad 3.4"); + if (defined(h[23])) puts("bad 3.5"); +} +unicode_2(); +} -output {} + +test unicode-3 {test unicode strings in regexp and substitution} -body { +#lang L --line=1 +void unicode_3() +{ + string h = "זו השפה שלנו"; + string r; + + /* These test wide chars in both regexp and string. */ + + unless (h =~ /זו/) puts("bad 1.1"); + if (h =~ /ך/) puts("bad 1.2"); + unless (h =~ /זו השפה שלנו/) puts("bad 1.3"); + unless (h =~ /השפה שלנו/) puts("bad 1.4"); + if (h =~ /^השפה שלנו/) puts("bad 1.5"); + unless (h =~ /זו.*שלנו/) puts("bad 1.6"); + + h =~ s/ש//; + unless (length(h) == 11) puts("bad 2.1"); + unless (h eq "זו הפה שלנו") puts("bad 2.2"); + h = "זו השפה שלנו"; + h =~ s/ש//g; + unless (length(h) == 10) puts("bad 2.3"); + unless (h eq "זו הפה לנו") puts("bad 2.4"); + + h = "זו השפה שלנו"; + r = "ש"; + h =~ s/${r}//; + unless (length(h) == 11) puts("bad 3.1"); + unless (h eq "זו הפה שלנו") puts("bad 3.2"); + h = "זו השפה שלנו"; + h =~ s/${r}//g; + unless (length(h) == 10) puts("bad 3.3"); + unless (h eq "זו הפה לנו") puts("bad 3.4"); + + h = "זו השפה שלנו"; + unless (h =~ /זו (השפ)ה שלנו/) puts("bad 4.1"); + unless (length($1) == 3) puts("bad 4.2"); + unless ($1 eq "השפ") puts("bad 4.3"); + + /* Test an ascii regexp and a wide string. */ + + h = "זו השפה שלנו"; + unless (h =~ / /) puts("bad 10.1"); + h =~ s/ //; + unless (h == "זוהשפה שלנו") puts("bad 10.2"); + h = "זו השפה שלנו"; + h =~ s/ //g; + unless (h == "זוהשפהשלנו") puts("bad 10.3"); +} +unicode_3(); +} -output {} + +test unicode-4 {test file I/O with unicode strings} -body { +#lang L --line=1 +void unicode_4() +{ + string h = "זו השפה שלנו"; + string j = '私は 日本語が 分かります'; + string s; + FILE f; + + unless (f = fopen("unicode4", "w")) puts("bad 0.1"); + fconfigure(f, encoding: "utf-8"); + write(f, h, String_bytelength(h)); + write(f, "\n", 1); + fprintf(f, "%s\n", j); + fclose(f); + + unless (f = fopen("unicode4", "r")) puts("bad 0.2"); + fconfigure(f, encoding: "utf-8"); + s = <f>; + unless (length(s) == 12) puts("bad 1.1"); + unless (ord(s[0]) == 0x05d6) puts("bad 1.2"); + unless (ord(s[1]) == 0x05d5) puts("bad 1.3"); + unless (ord(s[2]) == 0x0020) puts("bad 1.4"); + unless (ord(s[3]) == 0x05d4) puts("bad 1.5"); + unless (ord(s[4]) == 0x05e9) puts("bad 1.6"); + unless (ord(s[5]) == 0x05e4) puts("bad 1.7"); + unless (ord(s[6]) == 0x05d4) puts("bad 1.8"); + unless (ord(s[7]) == 0x0020) puts("bad 1.9"); + unless (ord(s[8]) == 0x05e9) puts("bad 1.10"); + unless (ord(s[9]) == 0x05dc) puts("bad 1.11"); + unless (ord(s[10]) == 0x05e0) puts("bad 1.12"); + unless (ord(s[11]) == 0x05d5) puts("bad 1.13"); + if (defined(s[12])) puts("bad 1.14"); + s = <f>; + unless (length(s) == 13) puts("bad 3.1"); + unless (ord(s[0]) == 0x79c1) puts("bad 3.2"); + unless (ord(s[1]) == 0x306f) puts("bad 3.3"); + unless (ord(s[2]) == 0x3000) puts("bad 3.4"); + unless (ord(s[3]) == 0x65e5) puts("bad 3.5"); + unless (ord(s[4]) == 0x672c) puts("bad 3.6"); + unless (ord(s[5]) == 0x8a9e) puts("bad 3.7"); + unless (ord(s[6]) == 0x304c) puts("bad 3.8"); + unless (ord(s[7]) == 0x3000) puts("bad 3.9"); + unless (ord(s[8]) == 0x5206) puts("bad 3.10"); + unless (ord(s[9]) == 0x304b) puts("bad 3.11"); + unless (ord(s[10]) == 0x308a) puts("bad 3.12"); + unless (ord(s[11]) == 0x307e) puts("bad 3.13"); + unless (ord(s[12]) == 0x3059) puts("bad 3.14"); + if (defined(s[13])) puts("bad 3.15"); + fclose(f); + unlink("unicode4"); +} +unicode_4(); +} -output {} + +test unicode-5 {test split built-in with unicode strings} -body { +#lang L --line=1 +void unicode_5() +{ + string a[], s; + + // This contains ASCII spaces. + a = split("זו השפה שלנו"); + unless (length(a) == 3) puts("bad 1.1"); + unless (a[0] eq "זו") puts("bad 1.2"); + unless (a[1] eq "השפה") puts("bad 1.3"); + unless (a[2] eq "שלנו") puts("bad 1.4"); + + // Note that these aren't ASCII spaces. + a = split("私は 日本語が 分かります"); + unless (length(a) == 3) puts("bad 2.1"); + unless (a[0] eq "私は") puts("bad 2.2"); + unless (a[1] eq "日本語が") puts("bad 2.3"); + unless (a[2] eq "分かります") puts("bad 2.4"); + + // Split a unicode string with a unicode regexp. + a = split(/ש/, "זו השפה שלנו"); + unless (length(a) == 3) puts("bad 3.1"); + unless (a[0] eq "זו ה") puts("bad 3.2"); + unless (a[1] eq "פה ") puts("bad 3.3"); + unless (a[2] eq "לנו") puts("bad 3.4"); + + // Split a unicode string with an ascii regexp. + a = split(/ /, "זו השפה שלנו"); + unless (length(a) == 3) puts("bad 4.1"); + unless (a[0] eq "זו") puts("bad 4.2"); + unless (a[1] eq "השפה") puts("bad 4.3"); + unless (a[2] eq "שלנו") puts("bad 4.4"); + + // Split a string containing nulls. + s = Binary_format("a*a2a*", "x", "b", "yd"); // xb\0yd + a = split(/\0/, s); + unless (length(a) == 2) puts("bad 5.1"); + unless (a[0] eq "xb") puts("bad 5.2"); + unless (a[1] eq "yd") puts("bad 5.3"); +} +unicode_5(); +} -output {} + +test cmdsubst-1 {test command substitution} -body { +#lang L --line=1 +void cmdsubst_1() +{ + string cmd, s1, s2; + + if (platform() eq "windows") { + cmd = "sh echo"; + } else { + cmd = "echo"; + } + + `${cmd} testing1 >foo.txt`; + s1 = `cat foo.txt`; + unless (s1 eq "testing1") puts("bad 1.1"); + `rm -f foo.txt`; + + s1 = "testing2"; + `${cmd} ${s1} >foo.txt`; + s1 = `cat foo.txt`; + unless (s1 eq "testing2") puts("bad 2.1"); + `rm -f foo.txt`; + + s1 = "testing3"; + s2 = "xyz"; + `${cmd} ${s1}${s2} >foo.txt`; + s1 = `cat foo.txt`; + unless (s1 eq "testing3xyz") puts("bad 3.1"); + `rm -f foo.txt`; + + s1 = "testing4"; + s2 = "pdq"; + `${cmd} ${s1}-${s2} >foo.txt`; + s1 = `cat foo.txt`; + unless (s1 eq "testing4-pdq") puts("bad 4.1"); + `rm -f foo.txt`; + + s1 = "testing"; + s2 = "xyz"; + `${cmd} ${s1}${5}${s2} ${"zyx"} >foo.txt`; + s1 = `cat foo.txt`; + unless (s1 eq "testing5xyz zyx") puts("bad 5.1"); + `rm -f foo.txt`; + + /* + * Check escapes: + * \$ \` \\ get escaped + * \<newline> gets ignored + * \x for anything else, does not get escaped + * + * These are a bit confusing. Once escaped by backtick + * processing, the command string undergoes Bourne-shell-style + * quoting. And because tcltest parsing messes with a + * \<newline> in the source, we can't simply write one of + * those here, so create strings of L code and eval those. + */ + + `${cmd} \r\n\t\a$x\$\\\\ \`backquote\` >foo.txt`; + s1 = `cat foo.txt`; + unless (s1 eq "rnta$x$\\ `backquote`") puts("bad 10.1"); + `rm -f foo.txt`; + + L("`${cmd} x\\\ny >foo.txt`;\n"); + s1 = `cat foo.txt`; + unless (s1 eq "xy") puts("bad 10.2"); + `rm -f foo.txt`; +} +cmdsubst_1(); +} -output {} + +test cmdsubst-2 {test command substitution errors} -body { +#lang L --line=1 +void cmdsubst_2() +{ + string s = `a-nonexistent-command arg`; + if (defined(s)) puts("bad 1"); +} +cmdsubst_2(); +} -output {} + +test proc-1.0 {Test L function definition.} -body { +#lang L --line=1 +void proc_1_0(void) { + puts("foo"); +} +#lang tcl +proc_1_0 +} -output "foo\n" + + +test proc-1.1 {Test L function returns.} -body { +#lang L --line=1 +void proc_1_1_f1() { + puts("whiz"); +} +string proc_1_1_f2() { + puts("bang"); + return "foo"; + return "bar"; +} +void proc_1_1_f3() { + return; +} +void proc_1_1(void) { + puts(proc_1_1_f1()); + puts(proc_1_1_f2()); + puts(proc_1_1_f3()); +} +#lang tcl +proc_1_1 +} -output "whiz\n\nbang\nfoo\n\n" + +test proc-1.2 {Test L function parameters.} -body { +#lang L --line=1 +void proc_1_2(string arg1, string arg2) { + puts(arg1); + puts(arg2); +} +#lang tcl +proc_1_2 "val1" "val2" +} -output "val1\nval2\n" + +test proc-1.3 {Test variable arity functions} -body { +#lang L --line=1 +void proc_1_3_foo(...stuff) { + int i; + for (i=0; defined(stuff[i]); i++) { + printf("%s ", stuff[i]); + } + printf("\n"); +} +void proc_1_3_bar(int a, ...stuff) { + puts(a); + puts(stuff); +} +void proc_1_3() { + proc_1_3_foo("a", "b", "c", "d"); + proc_1_3_foo(); + proc_1_3_bar(1, 2, 3, 4); + proc_1_3_bar(1); +} +#lang tcl +proc_1_3 +} -output "a b c d \n\n1\n2 3 4\n1\n\n" + +test proc-1.4 {Ensure rest parameter comes last} -body { +#lang L --line=1 -nowarn +void proc_1_4(int a, ...b, int c) { + puts("oops"); +} +#lang tcl +proc_1_4 +} -returnCodes {error} -match glob -result "*:1: L Error: Rest parameter must be last\n" + +test proc-1.5 {test parameter multiple declaration} -body { +#lang L --line=1 -nowarn +void proc_1_5_1(int a, int a) {} +void proc_1_5_2(int a, int a, int a) {} +} -returnCodes error -match regexp -result {.*1: L Error: multiple declaration of local a +.*2: L Error: multiple declaration of local a +.*2: L Error: multiple declaration of local a +} + +test proc-1.6 {check ignored function return value} -body { +#lang L --line=1 +int proc_1_6_foo() { return (1); } +void proc_1_6() +{ + /* + * This test checks that an ignored function's return value is + * properly popped off the run-time stack. If it's not, the + * unbalanced stack will cause a Tcl panic in a debug build. + */ + + int i; + int n = 100; + + for (i = 0; i < n; ++i) { + proc_1_6_foo(); + } +} +proc_1_6(); +} -output {} + +test proc-1.7 {check extern functions} -setup { + proc proc_1_7 {} { puts "good" } +} -body { +#lang L --line=1 + extern void proc_1_7(); + proc_1_7(); +} -output {good +} + +test proc-1.8 {test (expand)} -body { +#lang L --line=1 +string proc_1_8_concat(...args) +{ + poly p; + string s = ""; + + foreach (p in args) s .= p; + return (s); +} +int proc_1_8_sum(int a, int b, int c) +{ + return (a + b + c); +} +/* Return a string array of n elements, starting at "1" and counting up. */ +string[] proc_1_8_arr(int n) +{ + int i; + string s[]; + + for (i = 1; i <= n; ++i) push(&s, (string)i); + return (s); +} +void proc_1_8() +{ + int i1[] = { 10 }; + int i2[] = { 20, 30 }; + int i3[] = { 40, 50, 60 }; + string s; + string sa[] = { "a", "b", "c" }; + string sb[] = { "d", "e" }; + poly p = { "a", "b", "c" }; + + unless (proc_1_8_concat((expand){}) eq "") puts("bad 0.1"); + + unless (proc_1_8_concat((expand)sa) eq "abc") puts("bad 1.1"); + unless (proc_1_8_concat("x", (expand)sa) eq "xabc") puts("bad 2.1"); + unless (proc_1_8_concat((expand)sa, "y") eq "abcy") puts("bad 3.1"); + unless (proc_1_8_concat("x", (expand)sa, "y") eq "xabcy") { + puts("bad 4.1"); + } + unless (proc_1_8_concat("x", (expand)sa, (expand)sb, "y") eq "xabcdey") { + puts("bad 5.1"); + } + unless (proc_1_8_concat((expand)sa, (expand)sa, (expand)sa) + eq "abcabcabc") { + puts("bad 6.1"); + } + + unless (proc_1_8_sum((expand)i1, 2, 3) == 15) puts("bad 10.1"); + unless (proc_1_8_sum((expand)i2, 2) == 52) puts("bad 11.1"); + unless (proc_1_8_sum((expand)i3) == 150) puts("bad 12.1"); + + unless (proc_1_8_concat((expand)p) eq "abc") puts("bad 20.1"); + + unless (proc_1_8_concat((expand)proc_1_8_arr(1)) eq "1") { + puts("bad 30.1"); + } + unless (proc_1_8_concat((expand)proc_1_8_arr(2)) eq "12") { + puts("bad 31.1"); + } + unless (proc_1_8_concat((expand)proc_1_8_arr(3)) eq "123") { + puts("bad 32.1"); + } + + /* These test expand inside of a list {}. */ + + unless (proc_1_8_concat((expand){(expand){1}}) eq "1") { + puts("bad 40.1"); + } + unless (proc_1_8_concat((expand){(expand){1,2}}) eq "12") { + puts("bad 40.3"); + } + unless (proc_1_8_concat((expand){(expand){1,2,3}}) eq "123") { + puts("bad 40.5"); + } + + sa = { (expand){"1","2"}, "3", (expand){"4"}, "5", (expand){"6","7","8"} }; + unless (length(sa) == 8) puts("bad 41.1"); + unless (proc_1_8_concat((expand)sa) eq "12345678") puts("bad 41.2"); + + sa = { (expand)"1" }; + unless ((length(sa) == 1) && (sa[0] eq "1")) puts("bad 42.1"); + sa = { (expand)"1", (expand)"2" }; + unless ((length(sa) == 2) && (sa[0] eq "1") && (sa[1] eq "2")) { + puts("bad 42.2"); + } + + /* + * Test some expands inside of nested calls to verify that + * they are not mistakenly caught as errors. + */ + s = proc_1_8_concat((expand){"1"}, + proc_1_8_concat((expand){"2"}, + proc_1_8_concat((expand){"3","4"}), + (expand){"5","6"}), + (expand){"7"}); + unless (s eq "1234567") puts("bad 45.1"); +} +proc_1_8(); +} -output {} + +test proc-1.9 {test (expand) errors} -body { +#lang L --line=1 --nowarn +private int foo(...args) { return (0); } +void proc_1_9() +{ + string a[]; + + foo((expand)a + 1); + foo(1 ? (expand)a : 1); + {(expand)a + 1}; + {1 ? (expand)a : 1}; + {"x", {1 ? (expand)a : 1}}; + (expand)a; + foo((expand)a, (expand)a+1); + foo("x", foo((expand)a+1)); +} +} -returnCodes error -match regexp -result {.*6: L Error: \(expand\) illegal in this context +.*7: L Error: \(expand\) illegal in this context +.*8: L Error: \(expand\) illegal in this context +.*9: L Error: \(expand\) illegal in this context +.*10: L Error: \(expand\) illegal in this context +.*11: L Error: \(expand\) illegal in this context +.*12: L Error: \(expand\) illegal in this context +.*13: L Error: \(expand\) illegal in this context +} + +test var-1.0 {Test L variable assignment and reference} -body { +#lang L --line=1 +void var_1_0(void) +{ + string s; + s = "Hello"; + puts(s); +} +#lang tcl +var_1_0 +} -output "Hello\n" + +test var-1.1 {L global variables} -body { +#lang L --line=1 +int lglobal1_1 = 1; +void var_1_1(void) +{ + puts(lglobal1_1); +} +#lang tcl +var_1_1 +} -output "1\n" + + +test var-1.2 {L global variables, harder} -body { +#lang L --line=1 +int lglobal1_2 = 3; +void var_1_2(void) +{ + puts(lglobal1_2); + lglobal1_2 = 4; + var_1_2_aux(); + puts(lglobal1_2); +} + +void var_1_2_aux() +{ + puts(lglobal1_2); + lglobal1_2 = 5; +} +#lang tcl +var_1_2 +} -output "3\n4\n5\n" + +test var-1.2.2 {L global variable access from inside function} -body { +#lang L --line=1 +private int g = 123; +void var_1_2_2() +{ + /* + * This tests a past compiler bug where the upvars for the + * global shadows were emitted at the point of variable use, + * which doesn't work if the use doesn't get executed, like + * the first reference to "g" below. + */ + for (; 0; g); + unless (g == 123) puts("bad 1"); +} +var_1_2_2(); +} -output {} + +test var-1.2.3 {L global variable access from inside class} -body { +#lang L --line=1 -nowarn +/* + * Like the above test (var-1.2.2) but with class variables as well. + */ +private int g = 321; +class class_var_1_2_3a +{ + public int l1 = g; // should see the global "g" + public int g = 654; // shadows the global + public int l2 = g; // should see the local "g" +} +class class_var_1_2_3b +{ + public int l1 = g; // should see the global "g" + public int g = 456; // shadows the global + public int l2 = g; // should see the local "g" +} +void var_1_2_3() +{ + unless (g == 321) puts("bad 1"); + unless (class_var_1_2_3a->l1 == 321) puts("bad 2"); + unless (class_var_1_2_3a->g == 654) puts("bad 3"); + unless (class_var_1_2_3a->l2 == 654) puts("bad 4"); + unless (class_var_1_2_3b->l1 == 321) puts("bad 5"); + unless (class_var_1_2_3b->g == 456) puts("bad 6"); + unless (class_var_1_2_3b->l2 == 456) puts("bad 7"); + if (1) { + int g = 987; + unless (g == 987) puts("bad 10"); + } + unless (g == 321) puts("bad 20"); +} +var_1_2_3(); +} -output {} + +test var-1.3 {A global array of structs} -body { +#lang L --line=1 + +struct var_1_3_point { int x, y; }; +struct var_1_3_point lglobal1_3[5]; + +void var_1_3(void) +{ + int i = 0; + + puts(lglobal1_3); + while (i < 5) { + lglobal1_3[i].x = i * 10; + lglobal1_3[i].y = i * 20; + i++; + } + puts(lglobal1_3); + var_1_3_aux(3); + puts(lglobal1_3); +} + +void var_1_3_aux(int i) +{ + lglobal1_3[i].x = i * 35; + lglobal1_3[i].y = i * 45; +} +#lang tcl +var_1_3 +} -output { +{0 0} {10 20} {20 40} {30 60} {40 80} +{0 0} {10 20} {20 40} {105 135} {40 80} +} + +test var-1.4 {Test extern variables} -body { +set var_1_4_v1 "extern test 1" +set var_1_4_v2 "extern test 2" +namespace eval var_1_4_ns { + variable foo "extern test 3" +} +#lang L --line=1 +extern string var_1_4_v1; +extern string ::var_1_4_v2; +extern string var_1_4_ns::foo; +extern string ::var_1_4_ns::foo; // really the same var as var_1_4_ns::foo +void var_1_4() +{ + unless (var_1_4_v1 eq "extern test 1") puts("bad 1"); + unless (::var_1_4_v2 eq "extern test 2") puts("bad 2"); + unless (var_1_4_ns::foo eq "extern test 3") puts("bad 3"); + unless (::var_1_4_ns::foo eq "extern test 3") puts("bad 4"); +} +var_1_4(); +} -output {} + +test var-1.5 {Variable function names} -body { +#lang L --line=1 +void var_1_5() { + /* + * This used to be supported but is no longer (2/24/09). + * This is now an error. + */ + string printfvar = "printf"; + printfvar("Earth calling printf\n"); +} +#lang tcl +var_1_5 +} -returnCodes error -match regexp -result {.*7: L Error: 'printfvar' is declared but not as a function +} + +test var-2 {test taking value of a function name} -body { +#lang L --line=1 +void var_2() +{ + /* This used to cause a crash. */ + puts(printf); +} +var_2(); +} -returnCodes error -match regexp -result {.*4: L Error: cannot use a function name as a value +} + +test lang-1.0 {Test lang parsing} -body { +# These are some Tcl Comments +#lang L --line=1 +void lang_1_0(void) +{ + puts("worked"); +} + +#lang tcl +# More comments + # starting after first column (space) + # starting after first column (tab) + # starting after first column (tab, space) +#pragm -- not a pragma +#pragmatic -- also not a pragma + #pragma -- yes, not a pragma +# pragma -- not a pragma +lang_1_0 +} -output "worked\n" + +test lang-2.0 {Test failure path in lang parsing} -body { +#lang(foo) +void lang_2_0(void) +{ + puts("worked"); +} + +#lang tcl +lang_2_0 +} -returnCodes {error} -result {malformed pragma} + +# no output because we're not calling any functions +test lang-3.0 {Test not switching back to Tcl} -body { +#lang L --line=1 +void lang_3_0(void) +{ + puts("worked"); +} +} + +test pragma-1 {test bad #pragma} -body { +#lang L --line=1 +#pragma bad +} -returnCodes error -match regexp -result {.*1: L Error: illegal attribute 'bad' +} + +test decl-1.0 {Variable and parameter declaration syntax} -body { +#lang L --line=1 -nowarn +void decl_1_0_fun1() { } +void decl_1_0_fun2(void) { } +void decl_1_0_fun3() { } +int fdecl_1_0_un4() { } +void decl_1_0_fun5(int foo) { } +hash decl_1_0_fun6(hash foo, hash bar[], hash baz[23]) { } +void decl_1_0_fun7(int foo, float bar, hash baz, string quux, poly quuux) { } +void decl_1_0_fun8() { + int foo, bar[], baz[84][42][1]; + string foo1[19], mani[], padmi = "hum"; + hash whee; + if (0) { + int bleh = 5; + } else { + if (1) { + poly padmi1 = "om"; + puts(padmi1); + } + } +} +#lang tcl +decl_1_0_fun8 +} -output "om\n"; + +test decl-1.1 {Hairy literal hash syntax in initializers} -body { +#lang L --line=1 -nowarn +void initmewoo() { + hash h = { "key" => "val", "key2" => "val" }; +} +#lang tcl +} + +test decl-1.2 {Undeclared variable error} -body { +#lang L --line=1 +void decl_1_2_undecl() { + foo = "bar"; + puts(cheese); +} +#lang tcl +decl_1_2_undecl +} -returnCodes error -match glob -result {*L Error: undeclared variable: foo +*L Error: undeclared variable: cheese +} + +test decl-1.3 {Variable shadowing} -body { +#lang L --line=1 +void decl_1_3_shadow() { + int foo = 1; + if (1) { + int foo = 2; + puts(foo); + } + puts(foo); +} +#lang tcl +decl_1_3_shadow +} -returnCodes error -match glob -result {*L Error: multiple declaration of local foo +} + +test decl-1.3.1 {test variable shadowing warnings} -body { +#lang L --line=1 +string decl_1_3_1g; +private string decl_1_3_1gp; +class decl_1_3_1cl +{ + public string decl_1_3_1cls; + instance { + public string decl_1_3_1inst; + }; + public void foo(decl_1_3_1cl self) + { + string decl_1_3_1g = ""; + string decl_1_3_1gp = ""; + string decl_1_3_1cls = ""; + string decl_1_3_1inst = ""; + } +} +void decl_1_3_1() +{ + string decl_1_3_1g = ""; + string decl_1_3_1gp = ""; +} +} -returnCodes error -match regexp -result {.*11: L Warning: local variable decl_1_3_1g shadows a global declared at.*:1 +.*12: L Warning: local variable decl_1_3_1gp shadows a global declared at.*:2 +.*13: L Warning: local variable decl_1_3_1cls shadows a class variable declared at.*:5 +.*14: L Warning: local variable decl_1_3_1inst shadows a class instance variable declared at.*:7 +.*19: L Warning: local variable decl_1_3_1g shadows a global declared at.*:1 +.*20: L Warning: local variable decl_1_3_1gp shadows a global declared at.*:2 +} + +test decl-1.4 {Single dimensional initializers actually initialize} -body { +#lang L --line=1 +void decl_1_4 () { + int foo[] = {4, 5, 6}; + hash bar = {"foo" => 4, "bar" => 5, "baz" => 6}; + struct { int x; int y; } point = { 1024, 768 }; + + printf("%s\n", foo); + printf("%s\n", bar); + printf("%s\n", point); +} +#lang tcl +decl_1_4 +} -output "4 5 6\nfoo 4 bar 5 baz 6\n1024 768\n" + +# Test decl-1.5 removed. + +test decl-1.6 {Check scoping rule errors for globals and externs} -body { +#lang L --line=1 -nowarn +/* + * The L scoping rules are as follows: + * + * - A name multiply declared at the global scope is illegal. + * - A name multiply declared in a local scope or any enclosing scopes + * is illegal. + * - A local name hides a global of the same name. + * - A name is not visible outside the scope in which it is declared. + * - A name is not visible in a scope before it is declared. + * + * This test checks the error cases. + */ +int decl_1_6_g1 = decl_1_6_g2; // error -- g2 used before being declared +int decl_1_6_g2; +void foo_decl_1_6() +{ + decl_1_6_g3 = 1; // error -- g3 used before being declared +} +int decl_1_6_g3; +void decl_1_6() +{ + int l; + int l; // error -- name already declared locally + puts(decl_1_6_extern); // error -- extern not yet declared + if (1) { + if (1) { + int decl_1_6_extern; + decl_1_6_extern = 3; + } + } + if (1) { + int l2; + int l; // error -- name already declared locally + if (1) { + int l2; // error -- name already declared locally + } + } +} +int decl_1_6_g2; // error -- multiply declared at global scope +void decl_1_6_bad() +{ + extern int decl_1_6_g; // error -- externs illegal in local scopes +} +} -returnCodes error -match regexp -result {.*13: L Error: undeclared variable: decl_1_6_g2 +.*17: L Error: undeclared variable: decl_1_6_g3 +.*23: L Error: multiple declaration of local l +.*24: L Error: undeclared variable: decl_1_6_extern +.*33: L Error: multiple declaration of local l +.*35: L Error: multiple declaration of local l2 +.*39: L Error: multiple declaration of global decl_1_6_g2 +.*42: L Error: externs legal only at global scope +} + +test decl-1.7 {Check scoping rules for globals and externs} -body { +#lang L --line=1 -nowarn +/* + * This test checks the non-error cases of the scoping rules described + * above. + */ +extern string decl_1_7_extern; +string decl_1_7_g1; +string decl_1_7_g2 = "g2"; +string decl_1_7_g3; +void decl_1_7() +{ + string s = decl_1_7_g2; // read the global + string decl_1_7_g2 = "g2local"; // now shadow the global + + unless (s eq "g2") puts("bad 1"); + unless (decl_1_7_g2 eq "g2local") puts("bad 2"); + + decl_1_7_extern = "ex"; + unless (decl_1_7_extern eq "ex") puts("bad 3"); + + decl_1_7_g1 = "g1"; + unless (decl_1_7_g1 eq "g1") puts("bad 4"); + + if (1) { + string decl_1_7_g1; // shadow a global, already referenced + string decl_1_7_g3; // shadow a global, not yet referenced + decl_1_7_g1 = "local1"; // sets the local + decl_1_7_g3 = "local3"; // sets the local + unless (decl_1_7_g1 eq "local1") puts("bad 5"); + unless (decl_1_7_g3 eq "local3") puts("bad 6"); + } + unless (decl_1_7_g1 eq "g1") puts("bad 7"); +} +#lang tcl +decl_1_7 +} -output "" + +test decl-1.7.5 {check legal multiple extern variable declarations} -body { +set decl_1_7_5_var "extern test" +#lang L --line=1 +extern string decl_1_7_5_var; +extern string decl_1_7_5_var; // legal -- has same type as prior declaration +void decl_1_7_5() +{ + unless (decl_1_7_5_var eq "extern test") puts("bad 1"); +} +decl_1_7_5(); +} -output {} + +test decl-1.7.6 {check illegal multiple extern variable declarations} -body { +#lang L --line=1 +extern string decl_1_7_6_var; +extern int decl_1_7_6_var; // err -- not the same type +} -returnCodes error -match regexp -result {.*2: L Error: extern re-declaration type does not match other declaration +} + +test decl-1.8 {Check illegal variable names} -body { +#lang L --line=1 -nowarn +void _decl_1_8() // err -- function names cannot begin with _ +{ + int _bad; // err -- locals cannot begin with _ +} +} -returnCodes error -match regexp -result {.*1: L Error: function names cannot begin with _ +.*3: L Error: local variable names cannot begin with _ +} + +test decl-1.9 {Check mixing types on single decl line} -body { +#lang L --line=1 +void decl_1_9() { + /* + * This is a regression test. L used to get the types wrong. + * This just checks that the compiler issues no type errors. + */ + string h1{int}, s1; + string s2; + string h2{int}; + + s1 = s2; + h1 = h2; + s1 = "s1"; + s2 = "s2"; + h1{1} = "one"; + h2{1} = "one"; +} +#lang tcl +decl_1_9 +} -output {} + +test decl-1.10 {multiple declaration of main in same script disallowed} -body { +#lang L --line=1 +void main() +{ +} +void main() +{ +} +void main() +{ +} +} -returnCodes error -match regexp -result {.*4: L Error: function main already declared +.*7: L Error: function main already declared +} + +test decl-1.10.1 {argc, argv, or env should never cause unused-variable warning} -setup { + # Put these in their own files since only one main() can be defined. + makeFile { + void main(string argv[]) {} + } decl-1.10.1-1.l + makeFile { + void main(int argc, string argv[]) {} + } decl-1.10.1-2.l + makeFile { + void main(int argc, string argv[], string env{string}) {} + } decl-1.10.1-3.l +} -body { +#lang L --line=1 +void decl_1_10_1() +{ + int ret; + string tclsh = interpreter(); + string out, err; + + ret = system({tclsh, "decl-1.10.1-1.l"}, undef, &out, &err); + unless (ret == 0) puts("bad 1.1: ${out} ${err}"); + + ret = system({tclsh, "decl-1.10.1-2.l"}, undef, &out, &err); + unless (ret == 0) puts("bad 2.1: ${out} ${err}"); + + ret = system({tclsh, "decl-1.10.1-3.l"}, undef, &out, &err); + unless (ret == 0) puts("bad 3.1: ${out} ${err}"); +} +decl_1_10_1(); +} -output {} + +test decl-1.11.1 {private globals 1} -body { +#lang L --line=1 +private string priv_global = "test 1"; +private void priv_global_test_fn() +{ + puts(priv_global); +} +void decl_1_11_1() +{ + unless (priv_global eq "test 1") puts("bad decl_1_11_1"); +} +priv_global_test_fn(); +decl_1_11_1(); +} -output "test 1\n" + +test decl-1.11.2 {private globals 2} -body { +#lang L --line=1 +/* + * This test declares the same (private) names as the previous test. + * They should not clash. + */ +private string priv_global = "test 2"; +private void priv_global_test_fn() +{ + puts(priv_global); +} +priv_global_test_fn(); +/* + * Call the previous test's function. It should see the value of its + * own private global, not ours. + */ +decl_1_11_1(); +} -output "test 2\n" + +test decl-1.11.3 {test public/private global declaration errors} -body { +#lang L --line=1 -nowarn +private int decl_1_11_3_priv_first; +int decl_1_11_3_priv_first; + +int decl_1_11_3_publ_first; +private int decl_1_11_3_publ_first; + +private int two_privates; +private int two_privates; + +private void decl_1_11_1() {} // already declared in earlier test + +private string stdin; // already declared in libl + +void decl_1_11_3() +{ + public string bad1; + private string bad2; +} +} -returnCodes {error} -match regexp -result {.*2: L Error: multiple declaration of global decl_1_11_3_priv_first +.*5: L Error: multiple declaration of global decl_1_11_3_publ_first +.*8: L Error: multiple declaration of global two_privates +.*10: L Error: function decl_1_11_1 already declared +.*12: L Error: multiple declaration of global stdin +.*16: L Error: public/private qualifiers illegal for locals +.*17: L Error: public/private qualifiers illegal for locals +} + +test decl-1.12.1 {public globals 1} -body { +#lang L --line=1 +/* + * This simply tests that the "public" qualifier on a global + * declaration acts like a no-op. + */ +public string decl_1_12_s = "public decl test"; +public void decl_1_12_1() +{ + puts(decl_1_12_s); +} +decl_1_12_1(); +} -output "public decl test\n" + +test decl-1.12.1 {public globals 2} -body { +#lang L --line=1 +/* This is the second half of the test above. */ +public void decl_1_12_2() +{ + puts(decl_1_12_s); // print global defined in the previous test +} +decl_1_12_2(); +} -output "public decl test\n" + +test if-1.0 {If statements} -body { +#lang L --line=1 +void if_1_0() { + if (1) puts("0 working"); + if (0) { + puts("1 broken"); + } + puts("between"); + if (1) { + puts("1 working"); + } +} +#lang tcl +if_1_0 +} -output "0 working\nbetween\n1 working\n" + + +test if-1.1 {If statements with else clauses and multistatement bodies} -body { +#lang L --line=1 +void if_1_1() { + if (1) { + puts("1 working"); + puts("."); + } else { + puts("1 broken"); + puts("."); + } + + if (0) { + puts("2 broken"); + puts("."); + puts("."); + } else { + puts("2 working"); + puts("."); + puts("."); + } +} +#lang tcl +if_1_1 +} -output "1 working\n.\n2 working\n.\n.\n" + + +test if-1.2 {"else if" clauses} -body { +#lang L --line=1 +void if_1_2() { + if (0) { + puts("1 broken"); + } else if (1) { + puts("1 working"); + } + + puts("between"); + + if (0) { + puts("2 broken"); + } else if (0) { + puts("2.2 broken"); + } else { + puts("2 working"); + } +} +#lang tcl +if_1_2 +} -output "1 working\nbetween\n2 working\n" + +test if-1.3 {nested if statements} -body { +#lang L --line=1 +void if_1_3() { + if (1) { + puts("1 before"); + if (0) { + puts("1 broken"); + } else { + puts("1 working"); + } + puts("1 after"); + } else { + puts("1.1 broken"); + } + puts("1 done"); +} +#lang tcl +if_1_3 +} -output "1 before\n1 working\n1 after\n1 done\n" + +test if-1.4 {else is only allowed with curly braces} -body { +#lang L --line=1 +void if_1_4(void) +{ + if (0) puts("1 broken"); else puts("1 even more broken"); +} +#lang tcl +} -returnCodes error -match glob -result {*3: L Error: syntax error, unexpected else + if (0) puts("1 broken"); else + ^ +} + +test unless-1.0 {unless statements} -body { +#lang L --line=1 +void unless_1_0() { + unless(0) puts("0 working"); + unless(0) { + puts("1 working"); + } + unless(1) { + puts("2 broken"); + } else { + puts("2 working"); + } + unless(1) { + puts("3 broken"); + } else unless (1) { + puts("3.1 broken"); + } else { + puts("3 working"); + } +} +#lang tcl +unless_1_0 +} -output "0 working\n1 working\n2 working\n3 working\n" + +test unless-1.1 {unless and if statements mixed} -body { +#lang L --line=1 +void unless_1_1() { + unless(1) { + puts("1 broken"); + } else if (0) { + puts("1.1 broken"); + } else unless(0) { + puts("1 working"); + } + puts("done"); +} +#lang tcl +unless_1_1 +} -output "1 working\ndone\n" + +test return-1.1 {return from void function allowed} -body { +#lang L --line=1 +void return_1_1() { return; } +} -returnCodes normal + +test return-1.2 {returning int from void function disallowed} -body { +#lang L --line=1 +void return_1_2() { return 0; } +} -returnCodes error -match regexp -result ".*void function cannot return value" + +test return-1.3 {returning string from void function disallowed} -body { +#lang L --line=1 +void return_1_3() { return "str"; } +} -returnCodes error -match regexp -result ".*void function cannot return value" + +test return-1.4 {returning float from void function disallowed} -body { +#lang L --line=1 +void return_1_4() { return 2.99792458; } +} -returnCodes error -match regexp -result ".*void function cannot return value" + +test return-1.5 {returning array from void function disallowed} -body { +#lang L --line=1 +void return_1_5() { + int a[3]; + return a; +} +} -returnCodes error -match regexp -result ".*void function cannot return value" + +test return-1.6 {returning hash from void function disallowed} -body { +#lang L --line=1 +void return_1_6() { + hash h; + return h; +} +} -returnCodes error -match regexp -result ".*void function cannot return value" + +test return-1.7 {returning struct from void function disallowed} -body { +#lang L --line=1 +void return_1_7() { + struct { int x,y; } s; + return s; +} +} -returnCodes error -match regexp -result ".*void function cannot return value" + +test return-1.8 {returning poly from void function disallowed} -body { +#lang L --line=1 +void return_1_8() { + poly p; + return p; +} +} -returnCodes error -match regexp -result ".*void function cannot return value" + +test return-1.9.1 {return from global scope 1} -body { +#lang L --line=1 +return; +} -output {} + +test return-1.9.2 {return from global scope 2} -body { +#lang L --line=1 +return(1); +} -result {1} -output {} + +test return-1.9.3 {return from global scope 3} -body { +#lang L --line=1 +return("ret"); +} -result {ret} -output {} + +test return-2.1 {int return value from int function allowed} -body { +#lang L --line=1 +int return_2_1_f() { return 123; } +unless (return_2_1_f() == 123) printf("BAD\n"); +} -output "" + +test return-2.2 {float return value from float function allowed} -body { +#lang L --line=1 +float return_2_2_f() { return 123.456; } +unless (return_2_2_f() == 123.456) printf("BAD\n"); +} -output "" + +test return-2.3 {string return value from string function allowed} -body { +#lang L --line=1 +string return_2_3_f() { return "str"; } +unless (return_2_3_f() eq "str") printf("BAD\n"); +} -output "" + +test return-2.4 {array return value from array function allowed} -body { +#lang L --line=1 +int[] return_2_4_f() +{ + int a[3] = {2,3,5}; + return a; +} +void return_2_4() +{ + int res[] = return_2_4_f(); + unless ((res[0] == 2) && (res[1] == 3) && (res[2] == 5)) { + printf("BAD\n"); + } +} +#lang tcl +return_2_4 +} -output "" + +test return-2.5 {hash return value from hash function allowed} -body { +#lang L --line=1 +hash return_2_5_f() +{ + hash h; + h{"one"} = 1; + h{"two"} = 2; + h{"ten"} = 10; + return h; +} +void return_2_5() +{ + hash res = return_2_5_f(); + unless ((res{"one"} == 1) && (res{"two"} == 2) && (res{"ten"} == 10)) { + printf("BAD\n"); + } +} +#lang tcl +return_2_5 +} -output "" + +test return-2.6 {struct return value from struct function allowed} -body { +#lang L --line=1 +struct return_2_6_s { + int x, y, z; +}; +struct return_2_6_s return_2_6_f() +{ + struct return_2_6_s s; + s.x = 1; + s.y = 2; + s.z = 3; + return s; +} +void return_2_6() +{ + struct return_2_6_s res = return_2_6_f(); + unless ((res.x == 1) && (res.y == 2) && (res.z == 3)) printf("BAD\n"); +} +#lang tcl +return_2_6 +} -output "" + +# Spot-check some of the type-checking cases to ensure that return-value +# type checking is being done. Do not check all possible permutations. + +test return-3.1 {int return value from string function disallowed} -body { +#lang L --line=1 +string return_3_1() { return 1; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.2 {float return value from string function disallowed} -body { +#lang L --line=1 +string return_3_2() { return 1.2; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.3 {int return value from hash function disallowed} -body { +#lang L --line=1 +hash return_3_3() { return 1; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.4 {array return value from hash function disallowed} -body { +#lang L --line=1 +hash return_3_4() { int a[3]; return a; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.5 {int return value from struct function disallowed} -body { +#lang L --line=1 +struct s35 { + int x, y; +}; +struct s35 return_3_5() { return 1; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.6 {hash return value from struct function disallowed} -body { +#lang L --line=1 +struct s36 { + int x, y; +}; +struct s36 return_3_6() { hash h; return h; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.7 {int return value from array function disallowed} -body { +#lang L --line=1 +int[] return_3_7() { return 1; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.8 {struct return value from array function disallowed} -body { +#lang L --line=1 +struct s38 { + int x, y; +}; +int[] return_3_8() { struct s38 s; return s; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.9 {hash return value from array function disallowed} -body { +#lang L --line=1 +int[] return_3_9() { hash h; return h; } +} -returnCodes error -match regexp -result ".*incompatible return type" + +test return-3.10 {void return value from non-void function disallowed} -body { +#lang L --line=1 +int return_3_10_int() { return; } +} -returnCodes error -match regexp -result ".*must specify return value" + +test return-3.11 {check not returning a value from functon error} -body { +#lang L --line=1 +private string f() +{ + if (0) return ("not taken"); +} +void return_3_10() +{ + f(); +} +return_3_10(); +} -returnCodes error -match regexp -result {no value returned from function} + +test syntax-1.0 {single-line comments a la C++} -body { +#lang L --line=1 +# this kind of comment valid only on line 1 +void syntax_1_0() { + // single-line comments are + puts("working"); //see? + //////cruftilioucious +} + +#lang tcl +syntax_1_0 +} -output "working\n" + +test syntax-1.0.1 {hash-comment errors} -body { +#lang L --line=1 + # err -- starts on column 2 +void syntax_1_0_1() +{ +# err -- not on line 1 + # err -- same +} +} -returnCodes {error} -match regexp -result {.*1: L Error: # comment must start at first column +.*4: L Error: # comment valid only on line 1 +.*5: L Error: # comment valid only on line 1 +} + +test syntax-1.1 {structure syntax} -body { +#lang L --line=1 -nowarn + +struct syntax_1_1_point { + int x, y; + string label; + float froboz[128]; + struct { int m, n; } sub_struct; +}; + +void syntax_1_1() { + struct { string firstname; string lastname; } him; + struct { string firstname; string lastname; } me = {"john", "doe"}; + struct syntax_1_1_point p1, p2 = { + 1, 2, "label", {1.0}, {1,2} } , p3; + puts("didn't crash"); +} + +#lang tcl +syntax_1_1 +} -output "didn't crash\n" + +test syntax-1.2 {interpolated strings} -body { +#lang L --line=1 +void syntax_1_2() +{ + string s = "xxx"; + int h{int} = { 1=>1, 3 => 4 }; + int hh{int}{int} = { 2 => {1=>3,4=>5} }; + string hs{string} = { "1" => "1" }; + + /* Check interpolations at beginning, middle, and end of a string. */ + unless ("${s} start" eq "xxx start") puts("bad 1.1"); + unless ("middle ${s} start" eq "middle xxx start") puts("bad 1.2"); + unless ("end ${s}" eq "end xxx") puts("bad 1.3"); + unless ("1${s}${s}2" eq "1xxxxxx2") puts("bad 1.4"); + unless ("1${s} ${s}2" eq "1xxx xxx2") puts("bad 1.5"); + unless ("1${s}2${s}3${s}" eq "1xxx2xxx3xxx") puts("bad 1.6"); + + /* Test that braces are counted properly within an interpolation. */ + unless ("a${h{3}}b" eq "a4b") puts("bad 2.1"); + unless ("a${hh{2}{4}}b" eq "a5b") puts("bad 2.2"); + unless ("a${hh{2}{h{1}}}b" eq "a3b") puts("bad 2.4"); + unless ("a${hh{2}{h{h{1}}}}b" eq "a3b") puts("bad 2.5"); + unless ("a${hh{2}{h{h{h{1}}}}}b" eq "a3b") puts("bad 2.6"); + + /* + * These have a right brace after the right brace that ends the + * interpolation. The left and right braces are still balanced + * because the tcl test parsing dies if they are not, but L does + * not require it inside strings. + */ + unless ("{a${h{3}}}b" eq "{a4}b") puts("bad 3.1"); + unless ("{a${hh{2}{4}}}b" eq "{a5}b") puts("bad 3.2"); + unless ("{a${hh{2}{h{1}}}}b" eq "{a3}b") puts("bad 3.4"); + unless ("{a${hh{2}{h{h{1}}}}}b" eq "{a3}b") puts("bad 3.5"); + unless ("{a${hh{2}{h{h{h{1}}}}}}b" eq "{a3}b") puts("bad 3.6"); + + /* Test nested interpolations. */ + unless ("1 ${"3 ${s} 4"} 2" eq "1 3 xxx 4 2") puts("bad 4.1"); + unless ("1 ${"3 ${"5 ${s} 6"} 4"} 2" eq "1 3 5 xxx 6 4 2") { + puts("bad 4.2"); + } + unless ("1 ${"3 ${"5 ${"7 ${s} 8"} 6"} 4"} 2" eq "1 3 5 7 xxx 8 6 4 2") { + puts("bad 4.3"); + } + + /* Test that braces are counted properly in nested interpolations. */ + unless ("a ${hs{"${1}"}} b" eq "a 1 b") puts("bad 5.1"); + unless ("a ${hs{hs{"${1}"}}} b" eq "a 1 b") puts("bad 5.2"); + unless ("a ${hs{hs{"${h{1}}"}}} b" eq "a 1 b") puts("bad 5.2"); + unless ("a ${hs{hs{"${h{h{1}}}"}}} b" eq "a 1 b") puts("bad 5.3"); + unless ("a ${hs{"${h{h{1}}}"}} b" eq "a 1 b") puts("bad 5.4"); +} +syntax_1_2(); +} -output {} + +test syntax-1.2.1 {check string interpolations nested too deeply} -body { +#lang L --line=1 +void syntax_1_2_1() +{ + "1${"2${"3${"4${"5${"6${"7${"8${"9${"10${"11${12}"}"}"}"}"}"}"}"}"}"}"; +} +} -returnCodes {error} -match regexp -result {.*3: L Error: string interpolation nesting too deep -- aborting +} + +test syntax-1.3 {tcl options short-cut} -body { +#lang L --line=1 +private string args(...args) +{ + return(join(" ", args)); +} +void syntax_1_3() +{ + /* + * Test the Tcl option syntax (option:), and specifically that + * it works even with reserved words. The scanner includes + * the colon when scanning these just for this reason. + */ + + unless (args(one:) eq "-one") puts("bad 1"); + unless (args(one: "x") eq "-one x") puts("bad 2"); + unless (args(one:,"x") eq "-one x") puts("bad 3"); + unless (args(one: "x","y") eq "-one x y") puts("bad 4"); + unless (args(one:,"x","y") eq "-one x y") puts("bad 5"); + unless (args(one: "x", two:) eq "-one x -two") puts("bad 6"); + unless (args(one:,"x", two:) eq "-one x -two") puts("bad 7"); + unless (args(one:,"x", two: "y") eq "-one x -two y") puts("bad 8"); + unless (args(one:,"x", two:,"y") eq "-one x -two y") puts("bad 9"); + unless (args(one:, two:) eq "-one -two") puts("bad 10"); + unless (args(one:, two:, three:) eq "-one -two -three") puts("bad 11"); + + unless (args(break:) eq "-break") puts("bad 20"); + unless (args(case:) eq "-case") puts("bad 20.2"); + unless (args(class:) eq "-class") puts("bad 21"); + unless (args(constructor:) eq "-constructor") puts("bad 22"); + unless (args(continue:) eq "-continue") puts("bad 23"); + unless (args(default:) eq "-default") puts("bad 23.2"); + unless (args(destructor:) eq "-destructor") puts("bad 24"); + unless (args(do:) eq "-do") puts("bad 25"); + unless (args(else:) eq "-else") puts("bad 26"); + unless (args(eq:) eq "-eq") puts("bad 27"); + unless (args(expand:) eq "-expand") puts("bad 28"); + unless (args(extern:) eq "-extern") puts("bad 29"); + unless (args(float:) eq "-float") puts("bad 30"); + unless (args(for:) eq "-for") puts("bad 31"); + unless (args(foreach:) eq "-foreach") puts("bad 32"); + unless (args(ge:) eq "-ge") puts("bad 33"); + unless (args(goto:) eq "-goto") puts("bad 34"); + unless (args(gt:) eq "-gt") puts("bad 35"); + unless (args(if:) eq "-if") puts("bad 36"); + unless (args(instance:) eq "-instance") puts("bad 37"); + unless (args(int:) eq "-int") puts("bad 38"); + unless (args(le:) eq "-le") puts("bad 39"); + unless (args(lt:) eq "-lt") puts("bad 40"); + unless (args(ne:) eq "-ne") puts("bad 41"); + unless (args(poly:) eq "-poly") puts("bad 42"); + unless (args(private:) eq "-private") puts("bad 43"); + unless (args(public:) eq "-public") puts("bad 44"); + unless (args(return:) eq "-return") puts("bad 45"); + unless (args(split:) eq "-split") puts("bad 46"); + unless (args(string:) eq "-string") puts("bad 47"); + unless (args(struct:) eq "-struct") puts("bad 48"); + unless (args(switch:) eq "-switch") puts("bad 48.2"); + unless (args(typedef:) eq "-typedef") puts("bad 49"); + unless (args(unless:) eq "-unless") puts("bad 50"); + unless (args(void:) eq "-void") puts("bad 51"); + unless (args(while:) eq "-while") puts("bad 52"); +} +syntax_1_3(); +} -output {} + +test syntax-1.4 {string appendation} -body { +#lang L --line=1 +void syntax_1_4() { + printf("these" "strings" + "stick" "together.\n"); +} +#lang tcl +syntax_1_4 +} -output "thesestringssticktogether.\n" + +test errmsg-1 {check cascading err msg avoidance, local var} -body { +#lang L --line=1 +void errmsg_1() +{ + errmsg_1_i = 0; + ++errmsg_1_i; + ++errmsg_1_i; + ++errmsg_1_i; +} +int errmsg_1_i; // should *not* produce a multiply declared variable err +} -returnCodes {error} -match regexp -result {^.*3: L Error: undeclared variable: errmsg_1_i +\s*$} + +test errmsg-2 {check cascading err msg avoidance, global var} -body { +#lang L --line=1 +++errmsg_2_g; +++errmsg_2_g; +++errmsg_2_g; +int errmsg_2_g; // should *not* produce a multiply declared variable err +} -returnCodes {error} -match regexp -result {^.*1: L Error: undeclared variable: errmsg_2_g +\s*$} + +test errmsg-3 {check cascading err msg avoidance, class var} -body { +#lang L --line=1 +class errmsg_3 +{ + private int v1 = errmsg_3_undecl1+1; + public int errmsg_3_undecl1; + private int v2 = errmsg_3_undecl1+1; + + private int v3 = errmsg_3_undecl2+1; + private int v4 = errmsg_3_undecl2+1; + public int errmsg_3_undecl2; + private int v5 = errmsg_3_undecl2+1; +} +int errmsg_3_undecl1; +int errmsg_3_undecl2; +} -returnCodes {error} -match regexp -result {^.*3: L Error: undeclared variable: errmsg_3_undecl1 +[^\n]+7: L Error: undeclared variable: errmsg_3_undecl2 +\s*$} + +test errmsg-4 {check cascading err msg avoidance, class instance var} -body { +#lang L --line=1 +class errmsg_4 +{ + instance { + private int v1 = errmsg_4_undecl1+1; + public int errmsg_4_undecl1; + private int v2 = errmsg_4_undecl1+1; + + private int v3 = errmsg_4_undecl2+1; + private int v4 = errmsg_4_undecl2+1; + public int errmsg_4_undecl2; + private int v5 = errmsg_4_undecl2+1; + }; +} +int errmsg_4_undecl1; +int errmsg_4_undecl2; +} -returnCodes {error} -match regexp -result {^.*4: L Error: undeclared variable: errmsg_4_undecl1 +[^\n]+8: L Error: undeclared variable: errmsg_4_undecl2 +\s*$} + +test op-1.0 {increment and decrement operators} -body { +#lang L --line=1 +void op_1_0() { + int i = 1; + + puts("pre:"); + puts(i); + ++i; + puts(i); + puts(++i); + --i; + puts(i); + puts(--i); + + puts("post:"); + puts(i); + i++; + puts(i); + puts(i++); + puts(i); + i--; + puts(i); + puts(i--); + puts(i); +} +#lang tcl +op_1_0 +} -output "pre:\n1\n2\n3\n2\n1\npost:\n1\n2\n2\n3\n2\n2\n1\n" + +test op-1.0.1 {increment and decrement operator side effects} -body { +#lang L --line=1 +class op_1_0_1_cls +{ + instance { public int n; } +} +void op_1_0_1() +{ + /* + * This test checks that the argument to ++ or -- is evaluated + * exactly once. + */ + + int i; + int a[]; + op_1_0_1_cls o[] = { op_1_0_1_cls_new(), op_1_0_1_cls_new() }; + + i = 0; + a[0] = 13; + ++(a[i++]); + unless ((i == 1) && (a[0] == 14)) puts("bad 1"); + + i = 0; + a[0] = 13; + (a[i++])++; + unless ((i == 1) && (a[0] == 14)) puts("bad 2"); + + i = 0; + o[0]->n = 13; + o[1]->n = 13; + ++(o[i++]->n); + unless ((i == 1) && (o[0]->n == 14)) puts("bad 3"); + unless (o[1]->n == 13) puts("bad 3.1"); + + i = 0; + o[0]->n = 13; + o[1]->n = 13; + (o[i++]->n)++; + unless ((i == 1) && (o[0]->n == 14)) puts("bad 4"); + unless (o[1]->n == 13) puts("bad 4.1"); +} +op_1_0_1(); +} -output {} + +test op-1.1 {plus, minus, multiply, divide, and modulus operators} -body { +#lang L --line=1 +void op_1_1() { + int i = 2; + puts(i + 5); + puts(i - 50); + puts(i * 500); + puts(i / 2); + puts(i / 4.0); + puts((i + 5) % 3); + // precedence + puts(i + i / i - i * i % i); +} +#lang tcl +op_1_1 +} -output "7\n-48\n1000\n1\n0.5\n1\n3\n" + +test op-1.2 {unary plus and minus} -body { +#lang L --line=1 +void op_1_2() { + int i = -2; + int j = +2; + + puts(i); + i = i + -100; + puts(i); + puts(i * -3); + puts(-8 - -2); + + puts(j); + j = j + +100; + puts(j); + puts(j * +3); + puts(+8 - +2); +} +#lang tcl +op_1_2 +} -output "-2\n-102\n306\n-6\n2\n102\n306\n6\n" + +test op-1.3.1 {numeric comparison operators} -body { +#lang L --line=1 +void op_1_3_1() +{ + unless (-1 < 1) puts("bad 1.1"); + unless (1 > -1) puts("bad 1.2"); + unless (1 == 1) puts("bad 1.3"); + unless (1 <= 1) puts("bad 1.4"); + unless (-1 <= 1) puts("bad 1.5"); + unless (1 >= -1) puts("bad 1.6"); + unless (1 >= 0) puts("bad 1.7"); + unless (0 != 1) puts("bad 1.8"); + + if (1 < 1) puts("bad 2.1"); + if (1 > 1) puts("bad 2.2"); + if (1 == 0) puts("bad 2.3"); + if (1 != 1) puts("bad 2.4"); + if (1 <= -1) puts("bad 2.5"); + if (-1 >= 1) puts("bad 2.6"); + + // Verify that these are numeric compares, not lexicographic. + unless ((int)"1" == (int)"01") puts("bad 3.1"); + if ((int)"1" != (int)"01") puts("bad 3.2"); + if ((int)"1" > (int)"01") puts("bad 3.3"); + if ((int)"01" < (int)"1") puts("bad 3.4"); + if ((int)" 2" <= (int)"1") puts("bad 3.5"); // note: it's space 2 + if ((int)"1" >= (int)" 2") puts("bad 3.6"); + unless ((int)"00" == (int)"0") puts("bad 3.7"); +} +op_1_3_1(); +} -output {} + +test op-1.3.2 {string comparison operators} -body { +#lang L --line=1 +void op_1_3_2() +{ + if ("0" == "00") puts("bad 1.1"); + if ("1" == "01") puts("bad 1.2"); + if (" 1" == "1") puts("bad 1.3"); + + unless ("0" < "1") puts("bad 2.1"); + unless ("a" < "b") puts("bad 2.2"); + unless ("2" > "1") puts("bad 2.3"); + unless (" 2" < "1") puts("bad 2.4"); + unless ("b" > "a") puts("bad 2.5"); + + unless ("0" <= "0") puts("bad 3.1"); + unless ("0" <= "1") puts("bad 3.2"); + unless ("a" <= "a") puts("bad 3.3"); + unless ("a" <= "b") puts("bad 3.4"); + unless ("1" >= "1") puts("bad 3.5"); + unless ("2" >= "1") puts("bad 3.6"); + unless ("a" >= "a") puts("bad 3.7"); + unless ("b" >= "a") puts("bad 3.8"); +} +op_1_3_2(); +} -output {} + +test op-1.3.3 {composite equality operator} -body { +#lang L --line=1 +void op_1_3_3() +{ + string as1[], as2[]; + int ai1[], ai2[]; + string hs1{string}, hs2{string}; + int hi1{string}, hi2{string}; + string{string} ahs1[], ahs2[]; + struct { + string a; + string b; + } sts1, sts2; + struct { + int a; + int b; + } sti1, sti2; + + /* + * Cases to test: + * - Type contains only strings. + * - Type contains non-strings and that a numeric compare is done. + * - Array or hash w/same size, but same or different elts. + * - Array or hash that differs in size (w/fewer or greater elts). + */ + + as1 = { "one", "two", "three" }; + as2 = { "one", "two", "three" }; + unless (eq(as1,as2)) puts("bad 1.1"); + as2 = { "one", "two" }; + if (eq(as1,as2)) puts("bad 1.2"); + as2 = { "one", "two", "three", "four" }; + if (eq(as1,as2)) puts("bad 1.3"); + as2 = { "one", "two", "four" }; + if (eq(as1,as2)) puts("bad 1.4"); + + ai1 = { 1, 2, 3 }; + ai2 = { 1, 2, 3 }; + unless (eq(ai1,ai2)) puts("bad 2.1"); + ai2 = { 1, 2 }; + if (eq(ai1,ai2)) puts("bad 2.2"); + ai2 = { 1, 2, 3, 4 }; + if (eq(ai1,ai2)) puts("bad 2.3"); + ai2 = { 1, 2, 4 }; + if (eq(ai1,ai2)) puts("bad 2.4"); + /* Check that a numeric compare is done. */ + ai2 = (poly)"01 2 003"; + unless (eq(ai1,ai2)) puts("bad 2.5"); + + hs1 = { "k1"=>"v1", "k2"=>"v2", "k3"=>"v3" }; + hs2 = { "k1"=>"v1", "k2"=>"v2", "k3"=>"v3" }; + unless (eq(hs1,hs2)) puts("bad 10.1"); + hs2 = { "k1"=>"v1", "k2"=>"v2" }; + if (eq(hs1,hs2)) puts("bad 10.2"); + hs2 = { "k1"=>"v1", "k2"=>"v2", "k3"=>"v3", "k4"=>"v4" }; + if (eq(hs1,hs2)) puts("bad 10.3"); + hs2 = { "k1"=>"v1", "k2"=>"v2", "k4"=>"v4" }; + if (eq(hs1,hs2)) puts("bad 10.4"); + + hi1 = { "1"=>1, "2"=>2, "3"=>3 }; + hi2 = { "1"=>1, "2"=>2, "3"=>3 }; + unless (eq(hi1,hi2)) puts("bad 11.1"); + hi2 = { "1"=>1, "2"=>2, "3"=>3, "4"=>4 }; + if (eq(hi1,hi2)) puts("bad 11.2"); + hi2 = { "1"=>1, "2"=>2 }; + if (eq(hi1,hi2)) puts("bad 11.3"); + hi2 = { "1"=>1, "2"=>2, "4"=>4 }; + if (eq(hi1,hi2)) puts("bad 11.4"); + /* Check that a numeric compare is done. */ + hi2 = (poly)"1 01 2 2 3 003"; + unless (eq(hi1,hi2)) puts("bad 11.5"); + + sts1 = { "a", "b" }; + sts2 = { "a", "b" }; + unless (eq(sts1,sts2)) puts("bad 20.1"); + sts2 = { "a", "c" }; + if (eq(sts1,sts2)) puts("bad 20.1"); + + sti1 = { 1, 2 }; + sti2 = { 1, 2 }; + unless (eq(sti1,sti2)) puts("bad 21.1"); + sti2 = { 1, 3 }; + if (eq(sti1,sti2)) puts("bad 21.2"); + /* Check that a numeric compare is done. */ + sti2 = (poly)"01 002"; + unless (eq(sti1,sti2)) puts("bad 21.3"); + + /* + * More cases (prompted by bugs): + * - hash w/underlying dict elements added in different order + * - two hashes w/same key but different value + */ + + hs1 = { "k1"=>"v1", "k2"=>"v2" }; + hs2 = { "k2"=>"v2", "k1"=>"v1" }; + unless (eq(hs1,hs2)) puts("bad 22.1"); + + hs1 = { "k"=>"v1" }; + hs2 = { "k"=>"v2" }; + if (eq(hs1,hs2)) puts("bad 22.2"); + + push(&ahs1, hs1); + push(&ahs1, hs2); + push(&ahs2, hs1); + push(&ahs2, hs2); + unless (eq(ahs1,ahs2)) puts("bad 23.1"); +} +op_1_3_3(); +} -output {} + +test op-1.3.4 {composite equality operator 2} -body { +#lang L --line=1 +void op_1_3_4() +{ + /* + * Test a composite type w/numerics that contains a composite + * type without them. The outer type must be compared element + * by element but the inner type can be compared with a single + * string comparison of its string rep. + */ + + struct { + int i; + struct { + string a[]; + string b[]; + } st; + int j; + } st1, st2; + + st1 = { 1, { {"a","b"}, {"c","d"} }, 2 }; + st2 = { 1, { {"a","b"}, {"c","d"} }, 2 }; + unless (eq(st1,st2)) puts("bad 1.1"); + + st1 = { 1, { {"a","b"}, {"c","d"} }, 2 }; + st2 = { 1, { {"a","b"}, {"c","e"} }, 2 }; + if (eq(st1,st2)) puts("bad 1.2"); + + st1 = { 1, { {"a","b"}, {"c","d"} }, 2 }; + st2 = { 1, { {"a","b"}, {"c","d"} }, 3 }; + if (eq(st1,st2)) puts("bad 1.3"); + + st1 = { 1, { {"a","b"}, {"c","d"} }, 2 }; + st2 = (poly)"1 {{a b} {c d}} 2"; + unless (eq(st1,st2)) puts("bad 1.4"); +} +op_1_3_4(); +} -output {} + +test op-1.3.5 {composite comparison errors} -body { +#lang L --line=1 +void op_1_3_5() +{ + string sa[]; + string ha{string}; + struct { + int i, j; + } st; + + sa != sa; + sa < sa; + sa <= sa; + sa > sa; + sa >= sa; + + ha != ha; + ha < ha; + ha <= ha; + ha > ha; + ha >= ha; + + st != st; + st < st; + st <= st; + st > st; + st >= st; +} +} -returnCodes {error} -match regexp -result {.*9: L Error: only eq\(\) allowed on non-scalar types +.*10: L Error: only eq\(\) allowed on non-scalar types +.*11: L Error: only eq\(\) allowed on non-scalar types +.*12: L Error: only eq\(\) allowed on non-scalar types +.*13: L Error: only eq\(\) allowed on non-scalar types +.*15: L Error: only eq\(\) allowed on non-scalar types +.*16: L Error: only eq\(\) allowed on non-scalar types +.*17: L Error: only eq\(\) allowed on non-scalar types +.*18: L Error: only eq\(\) allowed on non-scalar types +.*19: L Error: only eq\(\) allowed on non-scalar types +.*21: L Error: only eq\(\) allowed on non-scalar types +.*22: L Error: only eq\(\) allowed on non-scalar types +.*23: L Error: only eq\(\) allowed on non-scalar types +.*24: L Error: only eq\(\) allowed on non-scalar types +.*25: L Error: only eq\(\) allowed on non-scalar types +} + +test op-1.4 {lexicographic comparison operators} -body { +#lang L --line=1 +void op_1_4() { + // These operators are now obsolete, but with the _L_ALLOW_EQ_OPS env + // variable set, the compiler will allow them. + + if ("aa" lt "ab") { puts("1okay"); } else { puts("1broken"); } + if ("ab" gt "aa") { puts("2okay"); } else { puts("2broken"); } + if ("aa" eq "aa") { puts("3okay"); } else { puts("3broken"); } + if ("aa" le "aa") { puts("4okay"); } else { puts("4broken"); } + if ("aa" le "ab") { puts("5okay"); } else { puts("5broken"); } + if ("aa" ge "aa") { puts("6okay"); } else { puts("6broken"); } + if ("ab" ge "aa") { puts("7okay"); } else { puts("7broken"); } + if ("aa" ne "ab") { puts("8okay"); } else { puts("8broken"); } + // now from the other side + puts("--"); + if ("aa" lt "aa") { puts("1broken"); } else { puts("1okay"); } + if ("aa" gt "aa") { puts("2broken"); } else { puts("2okay"); } + if ("ab" eq "aa") { puts("3broken"); } else { puts("3okay"); } + if ("aa" ne "aa") { puts("4broken"); } else { puts("4okay"); } + if ("ab" le "aa") { puts("5broken"); } else { puts("5okay"); } + if ("aa" ge "ab") { puts("6broken"); } else { puts("6okay"); } + + // Verify that these do not use Tcl's numeric compare. + // These are exactly the opposite tests to those at the end of + // op-1.3 above. + if ("1" eq "01") puts("bad 1"); + unless ("1" ne "01") puts("bad 2"); + unless ("1" gt "01") puts("bad 3"); + unless ("01" lt "1") puts("bad 4"); + unless (" 2" le "1") puts("bad 5"); + unless ("1" ge " 2") puts("bad 6"); +} +#lang tcl +op_1_4 +} -output "1okay\n2okay\n3okay\n4okay\n5okay\n6okay\n7okay\n8okay +--\n1okay\n2okay\n3okay\n4okay\n5okay\n6okay\n" + + +test op-1.5 {boolean operators} -body { +#lang L --line=1 +void op_1_5() { + int true = 1, false = 0; + if (true && true) { puts("1okay"); } else { puts("1broken"); } + if (!false) { puts("2okay"); } else { puts("2broken"); } + if (false || true) { puts("3okay"); } else { puts("3broken"); } + if (true && !false) { puts("4okay"); } else { puts("4broken"); } + // && has higher precedence than || + if (false && false || true) { puts("5okay"); } else { puts("5broken"); } + // now from the other side + puts("--"); + if (true && !true) { puts("1broken"); } else { puts("1okay"); } + if (false || false) { puts("2broken"); } else { puts("2okay"); } + if (!true) { puts("3broken"); } else { puts("3okay"); } + +} +#lang tcl +op_1_5 +} -output "1okay\n2okay\n3okay\n4okay\n5okay\n--\n1okay\n2okay\n3okay\n" + + +test op-1.6 {bitwise operators} -body { +#lang L --line=1 +void op_1_6(){ + int bits = 715827882; + + puts(bits << 1); + puts(bits >> 1); + puts(bits >> 29); + puts(-1 << 10); + puts(-1024 >> 9); + puts(~bits); + puts(bits & ~bits); + puts(bits | ~bits); + puts(bits ^ (bits + 1)); + +} +#lang tcl +op_1_6 +} -output "1431655764\n357913941\n1\n-1024\n-2\n-715827883\n0\n-1\n1\n" + + +test op-1.7 {logical operator short-circuiting} -body { +#lang L --line=1 +int +puts_int(string str) { + puts(str); + return 9; +} +void op_1_7(){ + puts(0 && puts_int("1")); + puts(1 && puts_int("2")); + puts(0 || puts_int("3")); + puts(1 || puts_int("4")); +} +#lang tcl +op_1_7 +} -output "0\n2\n9\n3\n9\n1\n" + +test op-1.8 {compound assignment operators, simple lvalues} -body { +#lang L --line=1 +void op_1_8() { + int foo = 0; + + puts(foo += 2); + puts(foo); + puts(foo -= 3); + puts(foo); + puts(foo *= 4); + puts(foo); + puts(foo /= -2); + puts(foo); + foo = 17; + puts(foo %= 7); + puts(foo); + puts(foo |= 9); + puts(foo); + puts(foo &= 8); + puts(foo); + puts(foo ^= 9); + puts(foo); + puts(foo <<= 3); + puts(foo); + puts(foo >>= 2); + puts(foo); +} +#lang tcl +op_1_8 +} -output "2\n2\n-1\n-1\n-4\n-4\n2\n2\n3\n3\n11\n11\n8\n8\n1\n1\n8\n8\n2\n2\n" + +test op-1.9 {compound assignment operators, array lvalues} -body { +#lang L --line=1 +void op_1_9() { + int foo[4] = {0,0,0,0}; + + puts(foo[2] += 2); + puts(foo[2]); + puts(foo[2] -= 3); + puts(foo[2]); + puts(foo[2] *= 4); + puts(foo[2]); + puts(foo[2] /= -2); + puts(foo[2]); + foo[2] = 17; + puts(foo[2] %= 7); + puts(foo[2]); + puts(foo[2] |= 9); + puts(foo[2]); + puts(foo[2] &= 8); + puts(foo[2]); + puts(foo[2] ^= 9); + puts(foo[2]); + puts(foo[2] <<= 3); + puts(foo[2]); + puts(foo[2] >>= 2); + puts(foo[2]); + puts(foo); +} +#lang tcl +op_1_9 +} -output "2\n2\n-1\n-1\n-4\n-4\n2\n2\n3\n3\n11\n11\n8\n8\n1\n1\n8\n8\n2\n2\n0 0 2 0\n" + +test op-1.10 {short-circuit conditionals} -body { +#lang L --line=1 +void op_1_10() +{ + /* + * Ensure that conditionals of type string are tested properly + * in the short-circuited operators (i.e., tested for defined). + */ + + int i = 0, j; + string s; + + if (s && ++i) j = 1; + unless (i == 0) puts("bad 1"); + + if (s || ++i) j = 1; + unless (i == 1) puts("bad 2"); +} +#lang tcl +op_1_10 +} -output {} + +test op-1.11 {comma operator} -body { +#lang L --line=1 -nowarn +int op_1_11_f(int a, int b, int c) { return (b); } +string op_1_11_s(string a, string b, string c, string d) +{ + return ((string)concat(a,b,c,d)); +} +void op_1_11() +{ + /* + * Check precedence and associativity of comma operator. + * Should be the lowest and left associative, and not get + * confused with comma as an arg seperator. Also check that + * the value of a,b is b. + */ + + int i; + int j = 2, k = 0; // declares j & k; is not a comma op + int l = (1,2), m = (1,2,3,4,5); + string s; + + unless ((j == 2) && (k == 0)) puts("bad d1"); + unless (l == 2) puts("bad d2"); + unless (m == 5) puts("bad d3"); + + i = 1,2; + unless (i == 1) puts("bad 1"); + unless ((i = 1,2) == 2) puts("bad 2"); + unless (op_1_11_f(1, 2, 3) == 2) puts("bad 3"); + unless (op_1_11_f(1, (2,3), 4) == 3) puts("bad 4"); + unless (op_1_11_s("a", "b", kw:"d") eq "a b -kw d") puts("bad 5"); + unless (op_1_11_s("a", kw:"b", "c") eq "a -kw b c") puts("bad 6"); + unless (op_1_11_s(kw:"a", "b", "c") eq "-kw a b c") puts("bad 7"); + unless (op_1_11_s("a", ("b","c"), kw: "d") eq "a c -kw d") { + puts("bad 8"); + } + + i = (1,2,3); + unless (i == 3) puts("bad 10"); + i = (1,2,3,4); + unless (i == 4) puts("bad 11"); + i = (1,2),(3,4); + unless (i == 2) puts("bad 12"); + i = ((1,2),(3,4)); + unless (i == 4) puts("bad 13"); + + /* + * Check that the type of a,b is the type of b. + */ + i = ("s", 11); + unless (i == 11) puts("bad t1"); + s = (1, "s"); + unless (s eq "s") puts("bad t2"); + + /* + * For loops should just automatically get the use of comma op. + */ + i = j = -1; + for (i=0,j=10; i < 10; ++i,j+=10) ; + unless ((i == 10) && (j == 110)) puts("bad f1"); +} +#lang tcl +op_1_11 +} -output {} + +test op-1.12 {test string concat operator} -body { +#lang L --line=1 +void op_1_12() +{ + string a, b, c; + string as[]; + string hs{string}; + widget w; + poly p; + struct { + string a, b, c; + } st; + + unless ("a" . "b" eq "ab") puts("bad 1.1"); + unless ("ab" . "cd" eq "abcd") puts("bad 1.2"); + unless ("ab" . "cd" . "ef" eq "abcdef") puts("bad 1.3"); + unless ("ab" . "cd" . "ef" . "gh" eq "abcdefgh") puts("bad 1.4"); + unless ("" . "a" eq "a") puts("bad 1.5"); + unless ("a" . "" eq "a") puts("bad 1.6"); + unless ("" . "a" . "" eq "a") puts("bad 1.7"); + unless ("" . "" . """" . "a" . "" eq "a") puts("bad 1.8"); + unless ("" . "" eq "") puts("bad 1.9"); + unless ("" . "" . "" eq "") puts("bad 1.10"); + + a = "a"; + b = "b"; + c = "c"; + unless (a . b . c eq "abc") puts("bad 2.1"); + + p = "a"; + unless (p . "b" eq "ab") puts("bad 3.1"); + + /* Test precedence. "." should be lower than [], {}, and -> */ + + as[0] = "a"; + as[1] = "b"; + as[2] = "c"; + unless (as[0] . as[1] . as[2] eq "abc") puts("bad 10.1"); + hs{"a"} = "a"; + hs{"b"} = "b"; + hs{"c"} = "c"; + unless (hs{"a"} . hs{"b"} . hs{"c"} eq "abc") puts("bad 10.2"); + st.a = "a"; + st.b = "b"; + st.c = "c"; + unless (st.a . st.b . st.c eq "abc") puts("bad 10.3"); + + /* Check varying whitespace around the "." */ + + unless ("a" . "b" eq "ab") puts("bad 20.1"); + unless ("a" . "b" eq "ab") puts("bad 20.2"); + unless ("a" . "b" eq "ab") puts("bad 20.3"); + unless ("a" . "b" eq "ab") puts("bad 20.4"); // tab + unless ("a" . "b" eq "ab") puts("bad 20.5"); // tab + unless ("a" . + "b" eq "ab") puts("bad 20.6"); + unless ("a" + . "b" eq "ab") puts("bad 20.7"); + unless ("a" . + "b" . + "c" eq "abc") puts("bad 20.8"); + + /* Check .= */ + + a = "a"; + a .= "bcd"; + unless (a eq "abcd") puts("bad 30.1"); + b = "e"; + unless ((a.=b) eq "abcde") puts("bad 30.2"); + + as[0] = "0"; + as[0] .= "123"; + unless (as[0] eq "0123") puts("bad 31.1"); + + a = "0234"; + a[0] .= "1"; + unless (a eq "01234") puts("bad 32.1"); + + /* String and widget should both work. */ + + a = "a"; + w = "w"; + unless ((a . w) eq "aw") puts("bad 33.1"); + unless ((w . a) eq "wa") puts("bad 33.2"); + unless ((w . w) eq "ww") puts("bad 33.3"); + + a .= w; + unless (a eq "aw") puts("bad 34.1"); + a = "a"; + w .= a; + unless (w eq "wa") puts("bad 34.2"); + w = "w"; + w .= w; + unless (w eq "ww") puts("bad 34.3"); + + w = "abc"; + unless (w =~ /b/) puts("bad 35.1"); + w =~ s/ab/x/; + unless (w eq "xc") puts("bad 35.2"); +} +op_1_12(); +} -output {} + +test op-1.13 {test string concat type errors} -body { +#lang L --line=1 +void op_1_13() +{ + int i, j; + string s; + float f; + int h{string}; + + i . j; + i . f; + h{"bad"} . i; + i . "s"; + "s" . f; + h{"bad"} . "s"; + + i .= "s"; + i .= j; + s .= i; +} +} -returnCodes {error} -match regexp -result {.*8: L Error: expected type string.* +.*9: L Error: expected type string.* +.*10: L Error: expected type string.* +.*11: L Error: expected type string.* +.*12: L Error: expected type string.* +.*13: L Error: expected type string.* +.*15: L Error: expected type string.* +.*16: L Error: expected type string.* +.*17: L Error: assignment of incompatible types +} + +test op-1.14 {test "." and "->" as struct selection operators} -body { +#lang L --line=1 +struct op14 { + int i, j; + struct { + int k; + } s; +}; +void op_1_14_ref(struct op14 &st) +{ + st->i = 7; + st->s.k = 8; +} +void op_1_14_val(struct op14 st) +{ + st.i = 8; + st.s.k = 9; +} +void op_1_14() +{ + struct op14 st = { 5, 6, {7} }; + + unless (st.i == 5) puts("bad 1.1"); + unless (st.j == 6) puts("bad 1.2"); + + op_1_14_ref(&st); + unless (st.i == 7) puts("bad 2.1"); + unless (st.s.k == 8) puts("bad 2.2"); + + op_1_14_val(st); + unless (st.i == 7) puts("bad 3.1"); + unless (st.s.k == 8) puts("bad 3.2"); +} +op_1_14(); +} -output {} + +test op-1.15 {check "." and "->" usage errors} -body { +#lang L --line=1 +struct op15 { + int i, j; + struct { + int k; + } s; +}; +void op_1_15_ref(struct op14 &st) +{ + st.i = 7; // err + st->s->k = 8; // the ->k part is an err +} +void op_1_15_val(struct op14 st) +{ + st->i = 8; // err +} +void op_1_15() +{ + struct op14 st; + + st->i = st.j; // st->i is an err +} +} -returnCodes {error} -match regexp -result {.*9: L Error: \. illegal on call-by-reference parms; use -> instead +.*10: L Error: -> illegal except on call-by-reference parms; use \. instead +.*14: L Error: -> illegal except on call-by-reference parms; use \. instead +.*20: L Error: -> illegal except on call-by-reference parms; use \. instead +} + +test op-1.16 {check ? : operator} -body { +#lang L --line=1 +string op_1_16_f(...args) { return (join("", args)); } +void op_1_16() +{ + int i; + float f; + string s; + + /* Check spacing variations. */ + + s = "bad"; + 0 ? puts("bad 1.1") : (s = "good"); + unless (s eq "good") puts("bad 1.2"); + + s = "bad"; + 0? puts("bad 2.1") : (s = "good"); + unless (s eq "good") puts("bad 2.2"); + + s = "bad"; + 0?puts("bad 3.1") : (s = "good"); + unless (s eq "good") puts("bad 3.2"); + + s = "bad"; + 0?puts("bad 4.1"): (s = "good"); + unless (s eq "good") puts("bad 4.2"); + + s = "bad"; + 0?puts("bad 5.1"):(s = "good"); + unless (s eq "good") puts("bad 5.2"); + + s = "bad"; + 1 ? (s = "good") : puts("bad 6.1"); + unless (s eq "good") puts("bad 6.2"); + + /* Check that id: parses properly. */ + + i = 0; + unless ((1?i:1) == 0) puts("bad 6.3"); + + /* Exactly one of the expressions must ever be executed. */ + + i = 0; + 0 ? ++i : ++i; + unless (i == 1) puts("bad 7.1"); + i = 0; + 1 ? ++i : ++i; + unless (i == 1) puts("bad 7.2"); + + /* Check value. */ + + s = 0 ? "bad" : "good"; + unless (s eq "good") puts("bad 10.1"); + + s = 1 ? "good" : "bad"; + unless (s eq "good") puts("bad 11.1"); + + /* + * Check typing. If either expr is a float and the other is compatible + * with that, we get a float. If either is a poly, we get a poly. + */ + + f = 0 ? 0 : 3.14; + unless (f == 3.14) puts("bad 12.1"); + f = 1 ? 6.28 : 0; + unless (f == 6.28) puts("bad 12.2"); + f = 1 ? 1.11 : 0.0; + unless (f == 1.11) puts("bad 12.3"); + f = 1 ? 12 : -1; + unless (f == 12) puts("bad 12.4"); + + s = "bad"; + s = 0 ? "bad" : (poly)13; + unless (s eq "13") puts("bad 12.5"); + s = "bad"; + s = 1 ? (poly)13 : "bad"; + unless (s eq "13") puts("bad 12.6"); + + /* + * Check precedence -- ? : should be between = and || in the + * precedence hierarchy. + */ + i = 1 ? 1 || puts("bad 20.1") : 1 || puts("bad 20.2"); + + /* Should have no confusion with the opt: argument syntax. */ + s = op_1_16_f(o1: 0 ? "bad": "good", o2: "3"); + unless (s eq "-o1good-o23") puts("bad 20.3"); + + /* + * This checks that the run-time stack is kept balanced when + * the value of the ternary expression is ignored (if it's + * not, we'll probably crash). + */ + for (i = 0; i < 10000; ++i) { + 0 ? 1 : 2; + (0 ? 1 : 2) , (0 ? 1 : 2); + } + + /* Try some nested ?: */ + i = 0 ? 1 ? 11:12 : 13; + unless(i == 13) puts("bad 30.1"); + i = 1 ? 1 ? 11:12 : 13; + unless(i == 11) puts("bad 30.2"); + i = 1 ? 0 ? 11:12 : 13; + unless(i == 12) puts("bad 30.3"); +} +op_1_16(); +} -output {} + +test op-1.17 {check type errors in ? : operator} -body { +#lang L --line=1 +void op_1_17() +{ + int i; + float f; + string s; + + s = 0 ? 1 : 2; + i = 0 ? "a" : "b"; + f = 0 ? "a" : "b"; + + /* The type of these ?: is float. */ + i = 0 ? f : i; + i = 0 ? i : f; + i = 0 ? f : f; + + /* These have exprs with incompatible types. */ + s = 0 ? 1 : "2"; + s = 0 ? "1" : 2; +} +} -returnCodes {error} -match regexp -result {.*7: L Error: assignment of incompatible types +.*8: L Error: assignment of incompatible types +.*9: L Error: assignment of incompatible types +.*12: L Error: assignment of incompatible types +.*13: L Error: assignment of incompatible types +.*14: L Error: assignment of incompatible types +.*17: L Error: incompatible types in \? : expressions +.*18: L Error: incompatible types in \? : expressions +} + +test cast-1.0 { Casts to integer and float } -body { +#lang L --line=1 +void cast_1_0() { + printf("%d\n", (int)1.9); + printf("%f\n", (float)5); + (int)1.9; + (float)5; +} +#lang tcl +cast_1_0 +} -output "1\n5.000000\n" + +test cast-1.1 {invalid casts from string to int or float} -body { +#lang L --line=1 +void cast_1_1() +{ + if (defined((int)"asdf")) puts("bad 1"); + if (defined((float)"asdf")) puts("bad 2"); +} +cast_1_1(); +} -output {} + +test cast-1.3 { Cast to string } -body { +#lang L --line=1 +void cast_1_3() +{ + string s; + widget w = "w"; + poly p = "p"; + int a[] = { 1, 2 }; + int h{string} = { "a"=>1, "b"=>2 }; + struct { int i,j; } st = { 5, 6 }; + + /* This checks not only cast functionality but also type checking. */ + + s = (string)1; + unless (s eq "1") puts("bad 1"); + + s = (string)3.14159; + unless (s =~ /3.14159/) puts("bad 2"); + + s = (string)"ok"; + unless (s eq "ok") puts("bad 3"); + + s = (string)w; + unless (s eq "w") puts("bad 4"); + + s = (string)a; + unless (s eq "1 2") puts("bad 5"); + + s = (string)h; + unless (s eq "a 1 b 2") puts("bad 6"); + + s = (string)st; + unless (s eq "5 6") puts("bad 7"); + + s = (string)p; + unless (s eq "p") puts("bad 8"); +} +#lang tcl +cast_1_3 +} -output {} + +test cast-1.4 { Invalid cast from function } -body { +#lang L --line=1 +void cast_1_4() +{ + int i; + float f; + string s; + widget w; + int h{string}; + + i = (int)cast_1_4; + f = (float)cast_1_4; + s = (string)cast_1_4; + s = (tcl)cast_1_4; + w = (widget)cast_1_4; + h = (hash)cast_1_4; +} +#lang tcl +cast_1_4 +} -returnCodes {error} -match regexp -result {.*9: L Error: type function illegal +.*10: L Error: type function illegal +.*11: L Error: type function illegal +.*12: L Error: type function illegal +.*13: L Error: type function illegal +.*14: L Error: type function illegal +} + +test cast-1.5 {cast to hash} -body { +#lang L --line=1 +void cast_1_5() +{ + int n = 0; + string k; + string a[] = { "k1","v1", "k2","v2", "k3","v3" }; + poly h{poly}; + + h = (hash)a; + unless (h{"k1"} eq "v1") puts("bad 1"); + unless (h{"k2"} eq "v2") puts("bad 2"); + unless (h{"k3"} eq "v3") puts("bad 3"); + foreach (k in h) ++n; + unless (n == 3) puts("bad 4"); +} +#lang tcl +cast_1_5 +} -output {} + +test cast-1.6 {cast to various structured types} -body { +#lang L --line=1 +struct s { + int i; + string s; + struct { + string h{int}; + int i; + } st; +}; +void cast_1_6() +{ + struct s st; + int a[], i, n; + string h{int}; + + /* Cast a string to a struct s. */ + st = (struct s)"1 str { { 1 one 2 two } 33 }"; + unless ((st.i == 1) && (st.s eq "str")) puts("bad 1"); + unless ((st.st.h{1} eq "one") && (st.st.h{2} eq "two")) puts("bad 2"); + unless (st.st.i == 33) puts("bad 3"); + + /* Same as above except casting from a composite constant. */ + st = (struct s) { + 1, + "str", + { + { 1=>"one", 2=>"two" }, + 33 + } + }; + unless ((st.i == 1) && (st.s eq "str")) puts("bad 4"); + unless ((st.st.h{1} eq "one") && (st.st.h{2} eq "two")) puts("bad 5"); + unless (st.st.i == 33) puts("bad 6"); + + /* Cast a string to a struct s but spell out the entire struct type. */ + st = (struct { int i; string s; struct { string h{int}; int i; } st; }) + "1 str { { 1 one 2 two } 33 }"; + unless ((st.i == 1) && (st.s eq "str")) puts("bad 7"); + unless ((st.st.h{1} eq "one") && (st.st.h{2} eq "two")) puts("bad 8"); + unless (st.st.i == 33) puts("bad 9"); + + /* Same as above except casting from a composite constant. */ + st = (struct { int i; string s; struct { string h{int}; int i; } st; }) + { + 1, + "str", + { + { 1=>"one", 2=>"two" }, + 33 + } + }; + unless ((st.i == 1) && (st.s eq "str")) puts("bad 10"); + unless ((st.st.h{1} eq "one") && (st.st.h{2} eq "two")) puts("bad 11"); + unless (st.st.i == 33) puts("bad 12"); + + a = (int[])"1 2 3"; + n = 0; + foreach (i in a) { + unless (i == (n+1)) puts("bad 10"); + ++n; + } + if (n != 3) puts("bad 11"); + + h = (string{int})"1 one 2 two 3 three"; + unless ((h{1} eq "one") && (h{2} eq "two") && (h{3} eq "three")) { + puts("bad 20"); + } + n = 0; + foreach (i in h) ++n; + unless (n == 3) puts("bad 21"); +} +#lang tcl +cast_1_6 +} -output {} + +test cast-1.7 {cast an lvalue} -body { +#lang L --line=1 +typedef struct { + string type; + poly val; +} c17_Xml; +void cast_1_7() +{ + int i; + float f; + c17_Xml x; + + /* + * These used to be various bugs with casts. There were + * problems with casting an l-value. + */ + + (int)i = 123; + unless(i == 123) puts("bad 1.1"); + ++(int)i; + unless(i == 124) puts("bad 1.2"); + + (float)f = 1.1; + unless (f == 1.1) puts("bad 2.1"); + + x.type = "dict"; + ((string{string})(x.val)){"key"} = "val"; + unless (x.type eq "dict") puts("bad 3.1"); + unless ((tcl)x eq "dict {key val}") puts("bad 3.2"); + + x.type = "type"; + x.val = {}; + ((string{string})(x.val)){"key"} = "val"; + unless (x.type eq "type") puts("bad 4.1"); + unless ((tcl)x eq "type {key val}") puts("bad 4.2"); + + x.type = "integer"; + x.val = 0; + ++(int)x.val; + unless (x.type eq "integer") puts("bad 5.1"); + unless (x.val == 1) puts("bad 5.2"); + unless ((tcl)x eq "integer 1") puts("bad 5.3"); +} +cast_1_7(); +} -output {} + +test array-1.0 { Single-dimensional array creation and indexing } -body { +#lang L --line=1 +void array_1_0() { + int array[3]; + + array[0] = 1; + array[1] = 2; + array[2] = 3; + puts(array[2]); +} +#lang tcl +array_1_0 +} -output "3\n" + +test array-1.1 { Multi-dimensional array creation and indexing } -body { +#lang L --line=1 +void array_1_1() { + int array[4][3][2]; + + puts(array); + array[0][0][0] = 1; + array[1][1][1] = 2; + array[2][2][0] = 3; + array[3][0][1] = 4; + puts(array); +} +#lang tcl +array_1_1 +} -output " +1 {{} {{} 2}} {{} {} 3} {{{} 4}}\n" + + +test array-1.2 {increment and decrement on array elements} -body { +#lang L --line=1 +void array_1_2() { + int foo[5] = {0,0,0,0,0}; + + foo[3] = 0; + for (foo[3]=0; foo[3]<5; foo[3]++); + puts(foo); + + puts("pre:"); + puts(foo[3]); + ++foo[3]; + puts(foo[3]); + puts(++foo[3]); + --foo[3]; + puts(foo[3]); + puts(--foo[3]); + + puts("post:"); + puts(foo[3]); + foo[3]++; + puts(foo[3]); + puts(foo[3]++); + puts(foo[3]); + foo[3]--; + puts(foo[3]); + puts(foo[3]--); + puts(foo[3]); + puts(foo); +} +#lang tcl +array_1_2 +} -output "0 0 0 5 0\npre:\n5\n6\n7\n6\n5\npost:\n5\n6\n6\n7\n6\n6\n5\n0 0 0 5 0\n" + +test array-1.3 {1d arrays with no length auto-extend by one at a time} -body { +#lang L --line=1 +void array_1_3() { + int foo[]; + + foo[0] = 4; + foo[1] = 5; + foo[2] = 6; + puts(foo); +} +#lang tcl +array_1_3 +} -output "4 5 6\n" + +test array-1.4 {extend arrays using push and pop} -body { +#lang L --line=1 +void array_1_4() { + int foo[]; + + push(&foo, 1); + push(&foo, 2); + push(&foo, 3); + puts(foo); + puts(pop(&foo)); + puts(foo); + puts(pop(&foo)); + puts(foo); + puts(pop(&foo)); + puts(foo); + puts(pop(&foo)); + puts(foo); +} +#lang tcl +array_1_4 +} -output "1 2 3\n3\n1 2\n2\n1\n1\n\n\n\n" + +test strindex-1 {string indexing} -body { +#lang L --line=1 +void strindex_1() +{ + int i; + string s, s2; + struct { + string s; + } st; + string sa[]; + string sh{string}; + widget w; + + s = "abcd"; + s[0] = "x"; + unless (s eq "xbcd") puts("bad 1.1"); + s[1] = "y"; + unless (s eq "xycd") puts("bad 1.2"); + s[2] = "z"; + unless (s eq "xyzd") puts("bad 1.3"); + s[3] = "q"; + unless (s eq "xyzq") puts("bad 1.4"); + s[3] = ""; + unless (s eq "xyz") puts("bad 1.5"); + s[0] = ""; + unless (s eq "yz") puts("bad 1.6"); + s[0] = ""; + unless (s eq "z") puts("bad 1.7"); + s[0] = ""; + unless (s eq "") puts("bad 1.8"); + s = "abcd"; + if (defined(s[4])) puts("bad 1.9"); + + st.s = "abcd"; + st.s[0] = "x"; + unless (st.s eq "xbcd") puts("bad 2.1"); + st.s[1] = "y"; + unless (st.s eq "xycd") puts("bad 2.2"); + st.s[2] = "z"; + unless (st.s eq "xyzd") puts("bad 2.3"); + st.s[3] = "q"; + unless (st.s eq "xyzq") puts("bad 2.4"); + st.s[3] = ""; + unless (st.s eq "xyz") puts("bad 2.5"); + st.s[0] = ""; + unless (st.s eq "yz") puts("bad 2.6"); + st.s[0] = ""; + unless (st.s eq "z") puts("bad 2.7"); + st.s[0] = ""; + unless (st.s eq "") puts("bad 2.8"); + st.s = "abcd"; + if (defined(st.s[4])) puts("bad 2.9"); + + sa[0] = "abcd"; + sa[0][0] = "x"; + unless (sa[0] eq "xbcd") puts("bad 3.1"); + sa[0][1] = "y"; + unless (sa[0] eq "xycd") puts("bad 3.2"); + sa[0][2] = "z"; + unless (sa[0] eq "xyzd") puts("bad 3.3"); + sa[0][3] = "q"; + unless (sa[0] eq "xyzq") puts("bad 3.4"); + sa[0][3] = ""; + unless (sa[0] eq "xyz") puts("bad 3.5"); + sa[0][0] = ""; + unless (sa[0] eq "yz") puts("bad 3.6"); + sa[0][0] = ""; + unless (sa[0] eq "z") puts("bad 3.7"); + sa[0][0] = ""; + unless (sa[0] eq "") puts("bad 3.8"); + sa[0] = "abcd"; + if (defined(sa[0][4])) puts("bad 3.9"); + + sh{"zero"} = "abcd"; + sh{"zero"}[0] = "x"; + unless (sh{"zero"} eq "xbcd") puts("bad 4.1"); + sh{"zero"}[1] = "y"; + unless (sh{"zero"} eq "xycd") puts("bad 4.2"); + sh{"zero"}[2] = "z"; + unless (sh{"zero"} eq "xyzd") puts("bad 4.3"); + sh{"zero"}[3] = "q"; + unless (sh{"zero"} eq "xyzq") puts("bad 4.4"); + sh{"zero"}[3] = ""; + unless (sh{"zero"} eq "xyz") puts("bad 4.5"); + sh{"zero"}[0] = ""; + unless (sh{"zero"} eq "yz") puts("bad 4.6"); + sh{"zero"}[0] = ""; + unless (sh{"zero"} eq "z") puts("bad 4.7"); + sh{"zero"}[0] = ""; + unless (sh{"zero"} eq "") puts("bad 4.8"); + sh{"zero"} = "abcd"; + if (defined(sh{"zero"}[4])) puts("bad 4.9"); + + s = "abcd"; + s[1] =~ s/n/nochange/; + unless (s eq "abcd") puts("bad 5.1"); + s[0] =~ s/n/nochange/; + unless (s eq "abcd") puts("bad 5.2"); + s[3] =~ s/n/nochange/; + unless (s eq "abcd") puts("bad 5.3"); + s[0] =~ s/a/was-a/; + unless (s eq "was-abcd") puts("bad 5.4"); + s[5] =~ s/b/was-b/; + unless (s eq "was-awas-bcd") puts("bad 5.5"); + s[11] =~ s/d/was-d/; + unless (s eq "was-awas-bcwas-d") puts("bad 5.6"); + s[0] =~ s/w//; + unless (s eq "as-awas-bcwas-d") puts("bad 5.7"); + s[0] =~ s/a//; + unless (s eq "s-awas-bcwas-d") puts("bad 5.8"); + s[1] =~ s/-//; + unless (s eq "sawas-bcwas-d") puts("bad 5.9"); + s[12] =~ s/d//; + unless (s eq "sawas-bcwas-") puts("bad 5.10"); + + s = "0123456789"; + for (i = 0; i < 10; ++i) { + s[i] =~ s/${i}/${i+1}/; + } + unless (s eq "12345678910") puts("bad 6.1"); + + /* + * Ensure that an un-shared copy of the string is made. + */ + s = "xyzzy"; + s2 = s; // s2 and s now share the same Tcl_Obj + s[1] = "x"; + unless (s eq "xxzzy") puts("bad 7.1"); + unless (s2 eq "xyzzy") puts("bad 7.2"); + + /* Should work with widgets too. */ + w = "wid"; + unless ((w[0] eq "w") && (w[END] eq "d")) puts("bad 8.1"); +} +strindex_1(); +} -output {} + +test strindex-2 {string indexing errors 1} -body { +#lang L --line=1 +void strindex_2() +{ + string s = "bad"; + s[-1] = "x"; // run-time error +} +strindex_2(); +} -returnCodes error -result {negative string index illegal} + +test strindex-3 {string indexing errors 2} -body { +#lang L --line=1 +void strindex_3() +{ + string s = "bad"; + puts (s[-1]); // run-time error +} +strindex_3(); +} -returnCodes error -result {negative string index illegal} + +test strindex-4 {string indexing errors 3} -body { +#lang L --line=1 +void strindex_4() +{ + string s = "bad"; + s[-1] =~ s/b/bad/; // run-time error +} +strindex_4(); +} -returnCodes error -result {negative string index illegal} + +test strindex-5 {string indexing index using comma expression} -body { +#lang L --line=1 +void strindex_5() +{ + /* + * This checks an obscure case to ensure that a string index + * whose value is discarded -- the first expression in a comma + * expression -- is compiled properly. + */ + + string s = "abcde"; + + /* The value of "fgh"[0] is discarded in the "s" index expression. */ + unless (s[ "fgh"[0], 2 ] eq "c") puts("bad 1"); +} +strindex_5(); +} -output {} + +test strindex-6 {writing to a string index beyond end of string} -body { +#lang L --line=1 +void strindex_6() +{ + string s = "good"; + s[END+2] = "bad"; // run-time error +} +strindex_6(); +} -returnCodes error -result {index is more than one past end of string} + +test strindex-7 {multi-index string indexing} -body { +#lang L --line=1 +void strindex_7() +{ + string s = "value"; + + s[0][0] = "x"; + s[0][0][0] = "x"; +} +strindex_7(); +} -returnCodes error -match regexp -result {.*5: L Error: cannot index a string index +.*6: L Error: cannot index a string index +} + +test slice-1 {string slicing} -body { +#lang L --line=1 +string slice_1_f(string s) { return (s); } +void slice_1() +{ + int i, j; + string s; + widget w; + + s = ""; + unless (s[0..0] eq "") puts("bad 1.1"); + + s = "a"; + unless (s[0..0] eq "a") puts("bad 2.1"); + + s = "abcdefg"; + unless (s[0..0] eq "a") puts("bad 3.1"); + unless (s[0..1] eq "ab") puts("bad 3.2"); + unless (s[0..2] eq "abc") puts("bad 3.3"); + unless (s[0..3] eq "abcd") puts("bad 3.4"); + unless (s[0..4] eq "abcde") puts("bad 3.5"); + unless (s[1..1] eq "b") puts("bad 3.6"); + unless (s[1..2] eq "bc") puts("bad 3.7"); + unless (s[1..3] eq "bcd") puts("bad 3.8"); + unless (s[1..4] eq "bcde") puts("bad 3.9"); + unless (s[2..2] eq "c") puts("bad 3.10"); + unless (s[2..3] eq "cd") puts("bad 3.11"); + unless (s[2..4] eq "cde") puts("bad 3.12"); + unless (s[3..3] eq "d") puts("bad 3.13"); + unless (s[3..4] eq "de") puts("bad 3.14"); + unless (s[4..4] eq "e") puts("bad 3.15"); + unless (s[0..10] eq "abcdefg") puts("bad 3.20"); + unless (s[-1..0] eq "a") puts("bad 3.21"); + unless (s[-1..1] eq "ab") puts("bad 3.22"); + unless (s[-1..10] eq "abcdefg") puts("bad 3.23"); + unless (s[2..1] eq "") puts("bad 3.24"); + + s = "0123456789"; + unless (s[2..4][0..0] eq "2") puts("bad 4.1"); + unless (s[2..4][1..1] eq "3") puts("bad 4.2"); + unless (s[1..8][1..6][1..4][1..2] eq "45") puts("bad 4.3"); + + s = "0123456789"; + unless (slice_1_f(s)[2..4][0..0] eq "2") puts("bad 5.1"); + unless (slice_1_f(s)[2..4][1..1] eq "3") puts("bad 5.2"); + unless (slice_1_f(s)[1..8][1..6][1..4][1..2] eq "45") puts("bad 5.3"); + + s = "0123456789"; + i = 2; + j = 4; + unless (s[i..j] eq "234") puts("bad 6.1"); + unless (s[i-1..j] eq "1234") puts("bad 6.2"); + unless (s[i-1..j+1] eq "12345") puts("bad 6.3"); + + w = "0123456789"; + unless (s[2..4][0..0] eq "2") puts("bad 7.1"); + unless (s[2..4][1..1] eq "3") puts("bad 7.2"); + unless (s[1..8][1..6][1..4][1..2] eq "45") puts("bad 7.3"); +} +slice_1(); +} -output {} + +test slice-2 {array slicing} -body { +#lang L --line=1 +string slice_2_tostr(int a[]) +{ + int i; + string ret = ""; + + foreach (i in a) ret = sprintf("%s<%i>", ret, i); + return (ret); +} +void slice_2() +{ + int ai[]; + string s; + + ai = { 0, 1, 2, 3, 4 }; + unless (slice_2_tostr(ai[0..0]) eq "<0>") puts("bad 1.1"); + unless (slice_2_tostr(ai[0..1]) eq "<0><1>") puts("bad 1.2"); + unless (slice_2_tostr(ai[0..2]) eq "<0><1><2>") puts("bad 1.3"); + unless (slice_2_tostr(ai[0..3]) eq "<0><1><2><3>") puts("bad 1.4"); + unless (slice_2_tostr(ai[0..4]) eq "<0><1><2><3><4>") puts("bad 1.5"); + unless (slice_2_tostr(ai[1..1]) eq "<1>") puts("bad 1.6"); + unless (slice_2_tostr(ai[1..2]) eq "<1><2>") puts("bad 1.7"); + unless (slice_2_tostr(ai[1..3]) eq "<1><2><3>") puts("bad 1.8"); + unless (slice_2_tostr(ai[1..4]) eq "<1><2><3><4>") puts("bad 1.9"); + unless (slice_2_tostr(ai[2..2]) eq "<2>") puts("bad 1.10"); + unless (slice_2_tostr(ai[2..3]) eq "<2><3>") puts("bad 1.11"); + unless (slice_2_tostr(ai[2..4]) eq "<2><3><4>") puts("bad 1.12"); + unless (slice_2_tostr(ai[3..3]) eq "<3>") puts("bad 1.13"); + unless (slice_2_tostr(ai[3..4]) eq "<3><4>") puts("bad 1.14"); + unless (slice_2_tostr(ai[4..4]) eq "<4>") puts("bad 1.15"); + + s = slice_2_tostr(ai[0..3][0..2]); + unless (s eq "<0><1><2>") puts("bad 2.1"); + s = slice_2_tostr(ai[0..3][0..2][0..1]); + unless (s eq "<0><1>") puts("bad 2.2"); + s = slice_2_tostr(ai[0..3][0..2][0..1][0..0]); + unless (s eq "<0>") puts("bad 2.3"); + + s = slice_2_tostr(ai[1..3][0..2]); + unless (s eq "<1><2><3>") puts("bad 3.1"); + s = slice_2_tostr(ai[1..3][0..1]); + unless (s eq "<1><2>") puts("bad 3.2"); + s = slice_2_tostr(ai[1..3][0..2][0..2][0..2][0..2]); + unless (s eq "<1><2><3>") puts("bad 3.3"); + + /* Check expressions as slice indices. */ + s = slice_2_tostr(ai[1-1..2+1][0*10..2]); + unless (s eq "<0><1><2>") puts("bad 4.1"); + s = slice_2_tostr(ai[1-1..ai[2..2][0]+1][0*10..ai[2]]); + unless (s eq "<0><1><2>") puts("bad 4.2"); + + /* Check slices of lists. */ + s = slice_2_tostr({0,1,2,3,4}[1..3]); + unless (s eq "<1><2><3>") puts("bad 5.1"); +} +slice_2(); +} -output {} + +test slice-2.1 {array slicing 2} -body { +#lang L --line=1 +void slice_2_1() +{ + /* + * Althgouh probably not recommended style, these should work. + */ + + struct s1 { + int i1, i2, i3, i4; + } st1; + struct s2 { + int i1, i2; + } st2; + + st2 = (struct s2){1,2,3,4}[1..2]; + unless ((st2.i1 == 2) && (st2.i2 == 3)) puts("bad 1"); + + st1 = { 5, 6, 7, 8 }; + st2 = (struct s2) ((int[])st1)[1..2]; + unless ((st2.i1 == 6) && (st2.i2 == 7)) puts("bad 2"); +} +slice_2_1(); +} -output {} + +test slice-3 {array slice errors} -body { +#lang L --line=1 +void slice_3() +{ + int i; + float f; + struct { + int i, j; + } st; + int h{int}; + + i = i[0..1]; + f = f[0..1]; + i = st[0..1]; + i = h[0..1]; +} +} -returnCodes error -match regexp -result {.*10: L Error: illegal type for slice +.*11: L Error: illegal type for slice +.*12: L Error: illegal type for slice +.*13: L Error: illegal type for slice +} + +test slice-4 {array slice index errors} -body { +#lang L --line=1 +void slice_4() +{ + int a[], i; + float f; + + i = a[0.0..1]; + i = a[0..1.0]; + i = a[0.0..1.0]; + i = a[f..1]; + i = a[0..f]; + i = a[f..f]; + i = a[a..a]; + + a[0..1] = { 0, 1 }; // invalid l-value +} +} -returnCodes error -match regexp -result {.*6: L Error: first slice index not an int +.*7: L Error: second slice index not an int +.*8: L Error: first slice index not an int +.*8: L Error: second slice index not an int +.*9: L Error: first slice index not an int +.*10: L Error: second slice index not an int +.*11: L Error: first slice index not an int +.*11: L Error: second slice index not an int +.*12: L Error: first slice index not an int +.*12: L Error: second slice index not an int +.*14: L Error: invalid l-value in assignment +} + +test end-1 {test END keyword for string indices} -body { +#lang L --line=1 +int end_1_f(int end) { + unless ("abc"[END] eq "c") puts("bad f.1"); + return (end); +} +void end_1() +{ + int e1, e2, e3; + string s, s1, s2, s3; + string as[]; + + /* Ensure END works and can be used in a full-blown expression. */ + s = "abcde"; + as[0] = "123"; + as[1] = "456"; + as[2] = "789"; + unless (s[END] eq "e") puts("bad 1.1"); + unless (s[END-1] eq "d") puts("bad 1.2"); + unless (s[END-2] eq "c") puts("bad 1.3"); + unless (s[END/2+2] eq "e") puts("bad 1.4"); + unless (s[end_1_f(END)/2+2] eq "e") puts("bad 1.5"); + unless (s[END-END+END-END+END*0+END] eq "e") puts("bad 1.6"); + unless ("xyz123"[END] eq "3") puts("bad 1.7"); + + /* + * These check END for something that is represented on the + * run-time stack as an L deep-ptr (as[0]). + */ + unless (as[0][END] eq "3") puts("bad 1.8"); + unless (as[1][END] eq "6") puts("bad 1.9"); + unless (as[2][END] eq "9") puts("bad 1.10"); + + /* Grab the value of END and verify it. */ + e1 = -1; + s = "abcde"; + unless (s[0,e1=END] eq "e") puts("bad 2.1"); + unless (e1 == 4) puts("bad 2.2"); + e1 = -1; + unless (s[e1=END,0] eq "a") puts("bad 2.3"); + unless (e1 == 4) puts("bad 2.4"); + + /* Check nested ENDs. */ + e1 = e2 = -1; + s1 = "abcde"[ s2="fgh"[e2=END], e1=END ]; + unless ((s1 eq "e") && (s2 eq "h")) puts("bad 3.1"); + unless ((e1 == 4) && (e2 == 2)) puts("bad 3.2"); + e1 = e2 = -1; + s1 = "abcde"[ s2="fgh"[ s3="pqrstuvwxyz"[e3=END], e2=END ], e1=END ]; + unless ((s1 eq "e") && (s2 eq "h") && (s3 eq "z")) puts("bad 3.3"); + unless ((e1 == 4) && (e2 == 2) && (e3 == 10)) puts("bad 3.4"); +} +end_1(); +} -output {} + +test end-2 {test END keyword for arrays} -body { +#lang L --line=1 +int end_2_f(int end) { + unless ({7,8,9}[END] == 9) puts("bad f.1"); + return (end); +} +int[] end_2_foo(int x) { return ({x,x+1,x+2}); } +void end_2() +{ + int e1, e2, e3, i1, i2, i3; + int a[], aa[][]; + + /* Ensure END works and can be used in a full-blown expression. */ + a = {1,2,3}; + unless (a[END] == 3) puts("bad 1.1"); + unless (a[END-1] == 2) puts("bad 1.2"); + unless (a[END-2] == 1) puts("bad 1.3"); + unless (a[END/2] == 2) puts("bad 1.4"); + unless (a[END/2+END/2] == 3) puts("bad 1.5"); + unless (a[END-END-END-END+END+END] == 1) puts("bad 1.6"); + unless (a[end_1_f(END)/2+1] == 3) puts("bad 1.7"); + unless ({1,2,3}[END] == 3) puts("bad 1.8"); + unless ({1,2,3}[END-1] == 2) puts("bad 1.9"); + unless ({1,2,3}[END-2] == 1) puts("bad 1.10"); + + /* + * These check END for something that is represented on the + * run-time stack as an L deep-ptr (aa[0]). + */ + aa[0] = {4,5,6}; + aa[1] = {7,8,9}; + aa[2] = {10,11,12}; + unless (aa[0][END] == 6) puts("bad 2.1"); + unless (aa[1][END] == 9) puts("bad 2.2"); + unless (aa[2][END] == 12) puts("bad 2.3"); + + /* Grab the value of END and verify it. */ + e1 = -1; + a = {1,2,3}; + unless (a[0,e1=END] == 3) puts("bad 3.1"); + unless (e1 == 2) puts("bad 3.2"); + e1 = -1; + unless (a[e1=END,0] == 1) puts("bad 3.3"); + unless (e1 == 2) puts("bad 3.4"); + e1 = -1; + if (defined({}[e1=END])) puts("bad 3.5"); + unless (e1 == -1) puts("bad 3.6"); + + /* Check nested ENDs. */ + e1 = e2 = e3 = -1; + i1 = {1,2,3}[ i2={4,5,6,7}[e2=END], e1=END ]; + unless ((i1 == 3) && (i2 == 7)) puts("bad 4.1"); + unless ((e1 == 2) && (e2 == 3)) puts("bad 4.2"); + e1 = e2 = e3 = -1; + i1 = {1,2,3}[ i2={4,5,6,7}[ i3={8,9}[e3=END], e2=END ], e1=END ]; + unless ((i1 == 3) && (i2 == 7) && (i3 == 9)) puts("bad 4.3"); + unless ((e1 == 2) && (e2 == 3) && (e3 == 1)) puts("bad 4.4"); + + /* Some multiple ENDs. */ + aa = { {1,2,3}, {4,5,6}, {7,8,9}, {10,11,12} }; + e1 = e2 = -1; + unless (aa[e1=END][e2=END] == 12) puts("bad 5.1"); + unless ((e1 == 3) && (e2 == 2)) puts("bad 5.2"); + + /* Check a[f(END)[b..c]] */ + a = { 1,2,3 }; + e1 = -1; + a[e1=end_2_foo(END+0)[0..1][0]]; + unless (e1 == 2) puts("bad 7.1"); +} +end_2(); +} -output {} + +test end-3 {test END usage for string append} -body { +#lang L --line=1 +void end_3() +{ + int i; + string s; + string atoz="abcdefghijklmnopqrstuvwxyz"; + + s = ""; + for (i = 0; i < 26; ++i) { + s[END+1] = atoz[i]; + } + for (i = 0; i < 26; ++i) { + unless (s[i] eq atoz[i]) printf("bad 1.1 i=%d", i); + } + if (defined(s[i])) puts("bad 1.2"); + unless (s eq "abcdefghijklmnopqrstuvwxyz") puts("bad 1.3"); +} +end_3(); +} -output {} + +test end-4 {test END usage for array append} -body { +#lang L --line=1 +void end_4() +{ + int e1, e2, i; + int a[], aa[][]; + + a = {}; + for (i = 0; i < 100; ++i) { + a[END+1] = i; + } + for (i = 0; i < 100; ++i) { + unless (a[i] == i) printf("bad 1.1 i=%d\n", i); + } + if (defined(a[i])) puts("bad 1.2"); + + aa = {}; + e1 = e2 = -2; + aa[(e1=END)+1][(e2=END)+1] = 100; + unless ((e1 == -1) && (e2 == -1)) puts("bad 2.1"); + unless (aa[e1=END][e2=END] == 100) puts("bad 2.2"); + unless ((e1 == 0) && (e2 == 0)) puts("bad 2.3"); + + aa = {}; + for (i = 0; i < 10; ++i) { + aa[END+1][END+1] = i; + aa[END][END+1] = 10*i; + } + for (i = 0; i < 10; ++i) { + unless (aa[i][0] == i) puts("bad 3.1"); + unless (aa[i][1] == 10*i) puts("bad 3.2"); + if (defined(aa[i][2])) puts("bad 3.3"); + } + if (defined(aa[i][0])) puts("bad 3.4"); +} +end_4(); +} -output {} + +test end-5 {test END with recursion} -body { +#lang L --line=1 +int end_5_f(int lim, int n) +{ + int a[], e, i; + + /* Put n things into a[]. */ + for (i = 0; i < n; ++i) a[END+1] = i; + + if (n < lim) { + /* e should get END+1; i.e., the # of things in a[] */ + a[e = (END+end_5_f(lim,n+1)+END)/2 + 1]; + unless (e == n) printf("bad n=%d, e=%d\n", n, e); + } + return (0); +} +void end_5() +{ + /* + * This test makes sure we can have lots of different ENDs all + * stacked up at once. + */ + end_5_f(100, 0); +} +end_5(); +} -output {} + +test end-6 {test END errors} -body { +#lang L --line=1 +int END; // err -- cannot declare global w/name "END" +void END() {} // err -- cannot declare function w/name "END" +void end_6() +{ + int END, i; // err -- cannot declare variable w/name "END" + string h{int}; + + i = END; // err -- cannot use END outside of an array or string index + h{END}; // err -- cannot use END in a hash index +} +} -returnCodes error -match regexp -result {.*1: L Error: cannot use END.* +.*2: L Error: cannot use END.* +.*5: L Error: cannot use END.* +.*8: L Error: END illegal.* +.*9: L Error: END illegal.* +} + +test end-7 {test END in string slices} -body { +#lang L --line=1 +void end_7() +{ + string s; + + s = "123456789"; + unless (s[0..END] eq "123456789") puts("bad 1.0"); + unless (s[0..END] eq s) puts("bad 1.1"); + unless (s[1..END] eq "23456789") puts("bad 1.2"); + unless (s[2..END] eq "3456789") puts("bad 1.3"); + unless (s[2..END-1] eq "345678") puts("bad 1.4"); + unless (s[2..END-2] eq "34567") puts("bad 1.5"); + unless (s[END-1..END] eq "89") puts("bad 1.6"); + unless (s[END-1..END-1] eq "8") puts("bad 1.7"); +} +end_7(); +} -output {} + +test end-8 {test END in array slices} -body { +#lang L --line=1 +void end_8() +{ + string a[]; + + a = { "1", "2", "3", "4", "5", "6" }; + unless (join(" ", a[0..END]) eq "1 2 3 4 5 6") puts("bad 1.1"); + unless (join(" ", a[1..END]) eq "2 3 4 5 6") puts("bad 1.2"); + unless (join(" ", a[2..END]) eq "3 4 5 6") puts("bad 1.3"); + unless (join(" ", a[2..END-1]) eq "3 4 5") puts("bad 1.4"); + unless (join(" ", a[2..END-2]) eq "3 4") puts("bad 1.5"); + unless (join(" ", a[END-1..END]) eq "5 6") puts("bad 1.6"); + unless (join(" ", a[END-1..END-1]) eq "5") puts("bad 1.7"); +} +end_8(); +} -output {} + +test end-10 {check END ignored in comma expression} -body { +#lang L --line=1 +void end_10() +{ + int i; + int a[] = {1,2,3}; + + /* + * This tests that an ignored END does not leave anything on + * the run-time stack (which would case a crash). + */ + for (i = 0; i < 100; ++i) a[END,0]; +} +end_10(); +} -output {} + +test end-11 {check deeply nested ENDs} -body { +#lang L +void end_11() +{ + /* + * Test that 40 ENDs can stack up. + */ + + int a[] = { 1, 0, 0 }; + int i; + + i = a[END-1 + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END-1 + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END-1 + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END-1 + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END-1 + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END-1 + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END-1 + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END-1 + a[END-1 + a[END-1 + a[END-1 + + a[END]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]; + unless (i == 0) puts("bad"); +} +end_11(); +} -output {} + +test end-12 {check END in various contexts} -body { +#lang L +int end_12f(int a, int b) +{ + unless (a == b) { + puts("bad ${a} ${b}"); + } + return (a); +} +void end_12() +{ + int a[] = { 1, 2, 3 }; + int i; + struct { + string h{string}[]; + } st; + + // END in an arg list + a[end_12f(END,2)]; + a[end_12f(2,END)]; + a[end_12f(END+0,2)]; + a[end_12f(2,0+END)]; + + // END is an id, array index + i = a[END]; + unless (i == 3) puts("bad 1"); + + // END is an id, array slice + a[0..(i=END)]; + unless (i == 2) puts("bad 2.1"); + a[(i=END)..END]; + unless (i == 2) puts("bad 2.2"); + + // END in a unary op + i = a[+END]; + unless (i == 3) puts("bad 3"); + + // END in a binary op + a[i=END+END]; + unless (i == 4) puts("bad 4"); + + // END in a trinary op + i = 0; + a[END==2 ? (i=END) : (i=0)]; + unless (i == 2) puts("bad 5"); + + // A regression test for a bug that used to crash the compiler + // when it looked for END in an index expression that has a cast. + push(&st.h{(string)0}, "x"); + push(&st.h{(string)0}, "y"); + push(&st.h{(string)0}, "z"); + unless (st.h{"0"} == {"x","y","z"}) puts("bad 6"); +} +end_12(); +} -output {} + +test loop-1.0 {while loops} -body { +#lang L --line=1 +void loop_1_0() { + int i = 0; + while (i++ < 5) puts (i); + while (i) { + int j = i--; + puts(j); + } +} +#lang tcl +loop_1_0 +} -output "1\n2\n3\n4\n5\n6\n5\n4\n3\n2\n1\n" +test loop-1.1 {for loops} -body { +#lang L --line=1 +void loop_1_1() { + int i; + for (i=1; i<7; i++) { + puts(i); + } + puts("-*-"); + for ( ; i; i--) { + puts(i); + } +} +#lang tcl +loop_1_1 +} -output "1\n2\n3\n4\n5\n6\n-*-\n7\n6\n5\n4\n3\n2\n1\n" + +test loop-1.2 {do loops} -body { +#lang L --line=1 +void loop_1_2() +{ + int i; + + /* Do loops must iterate at least once. */ + i = 0; + do { + ++i; + } while (0); + unless (i == 1) puts("bad 1"); + + i = 0; + do { + ++i; + puts(i); + } while (i < 4); +} +#lang tcl +loop_1_2 +} -output "1\n2\n3\n4\n" + +test loop-1.2.0 {simple foreach loops} -body { +#lang L --line=1 +struct sl120 { + int i; + int j; + string s; +}; +void +loop_1_2_0() +{ + int k, vi; + string vs; + float vf; + hash h0 = { }; + hash h1 = { 0=>1 }; + hash h2 = { 0=>1, 1=>2 }; + hash h3 = { 0=>1, 1=>2, 2=>3 }; + int ai0[]; + int ai1[1] = { 11 }; + int ai2[2] = { 22, 23 }; + int ai3[3] = { 33, 34, 35 }; + string as0[0]; + string as1[1] = { "a" }; + string as2[2] = { "b", "c" }; + string as3[3] = { "d", "e", "f" }; + float af0[0]; + float af1[1] = { 1.1 }; + float af2[2] = { 2.1, 2.2 }; + float af3[3] = { 3.1, 3.2, 3.3 }; + struct sl120 vc; + struct sl120 ac[3]; + + printf("start\n"); + foreach (k in h0) { + printf("h0 has %d\n", k); + } + foreach (k in h1) { + printf("h1 has %d\n", k); + } + foreach (k in h2) { + printf("h2 has %d\n", k); + } + foreach (k in h3) { + printf("h3 has %d\n", k); + } + foreach (k=>vi in h0) { + printf("h0 has %d=>%d\n", k, vi); + } + foreach (k=>vi in h1) { + printf("h1 has %d=>%d\n", k, vi); + } + foreach (k=>vi in h2) { + printf("h2 has %d=>%d\n", k, vi); + } + foreach (k=>vi in h3) { + printf("h3 has %d=>%d\n", k, vi); + } + foreach (vi in ai0) { + printf("ai0 has %d\n", vi); + } + foreach (vi in ai1) { + printf("ai1 has %d\n", vi); + } + foreach (vi in ai2) { + printf("ai2 has %d\n", vi); + } + foreach (vi in ai3) { + printf("ai3 has %d\n", vi); + } + foreach (vs in as0) { + printf("as0 has %s\n", vs); + } + foreach (vs in as1) { + printf("as1 has %s\n", vs); + } + foreach (vs in as2) { + printf("as2 has %s\n", vs); + } + foreach (vs in as3) { + printf("as3 has %s\n", vs); + } + foreach (vf in af0) { + printf("af0 has %1.1f\n", vf); + } + foreach (vf in af1) { + printf("af1 has %1.1f\n", vf); + } + foreach (vf in af2) { + printf("af2 has %1.1f\n", vf); + } + foreach (vf in af3) { + printf("af3 has %1.1f\n", vf); + } + foreach (vf in ai0) { + printf("ai0 has %1.1f\n", vf); + } + foreach (vf in ai1) { + printf("ai1 has %1.1f\n", vf); + } + foreach (vf in ai2) { + printf("ai2 has %1.1f\n", vf); + } + foreach (vf in ai3) { + printf("ai3 has %1.1f\n", vf); + } + ac[0].i = 1; + ac[0].j = 2; + ac[0].s = "a"; + ac[1].i = 11; + ac[1].j = 22; + ac[1].s = "aa"; + ac[2].i = 111; + ac[2].j = 222; + ac[2].s = "aaa"; + foreach (vc in ac) { + printf("ac has %d,%d,%s\n", vc.i, vc.j, vc.s); + } + printf("end\n"); +} +#lang tcl +loop_1_2_0 +} -output "start +h1 has 0 +h2 has 0 +h2 has 1 +h3 has 0 +h3 has 1 +h3 has 2 +h1 has 0=>1 +h2 has 0=>1 +h2 has 1=>2 +h3 has 0=>1 +h3 has 1=>2 +h3 has 2=>3 +ai1 has 11 +ai2 has 22 +ai2 has 23 +ai3 has 33 +ai3 has 34 +ai3 has 35 +as1 has a +as2 has b +as2 has c +as3 has d +as3 has e +as3 has f +af1 has 1.1 +af2 has 2.1 +af2 has 2.2 +af3 has 3.1 +af3 has 3.2 +af3 has 3.3 +ai1 has 11.0 +ai2 has 22.0 +ai2 has 23.0 +ai3 has 33.0 +ai3 has 34.0 +ai3 has 35.0 +ac has 1,2,a +ac has 11,22,aa +ac has 111,222,aaa +end +" + +test loop-1.2.1 {foreach loops over arrays of arrays} -body { +#lang L --line=1 +void +loop_121_fill2(int d1, int d2, int &a[][]) +{ + int i, j; + + for (i = 0; i < d1; ++i) { + for (j = 0; j < d2; ++j) { + a[i][j] = i*10 + j; + } + } +} + +void +loop_121_fill3(int d1, int d2, int d3, int &a[][][]) +{ + int i, j, k; + + for (i = 0; i < d1; ++i) { + for (j = 0; j < d2; ++j) { + for (k = 0; k < d3; ++k) { + a[i][j][k] = i*100 + j*10 + k; + } + } + } +} + +void +loop_1_2_1() +{ + int vi; + int ai[3]; + int aii[4][3]; + int aiii[5][4][3]; + + loop_121_fill2(4, 3, &aii); + loop_121_fill3(5, 4, 3, &aiii); + + printf("test 1\n"); + foreach (ai in aii) { + foreach (vi in ai) { + printf("aii has %d\n", vi); + } + } + + printf("test 2\n"); + foreach (aii in aiii) { + foreach (ai in aii) { + foreach (vi in ai) { + printf("aiii has %d\n", vi); + } + } + } + + printf("end\n"); +} +loop_1_2_1(); +} -output "test 1 +aii has 0 +aii has 1 +aii has 2 +aii has 10 +aii has 11 +aii has 12 +aii has 20 +aii has 21 +aii has 22 +aii has 30 +aii has 31 +aii has 32 +test 2 +aiii has 0 +aiii has 1 +aiii has 2 +aiii has 10 +aiii has 11 +aiii has 12 +aiii has 20 +aiii has 21 +aiii has 22 +aiii has 30 +aiii has 31 +aiii has 32 +aiii has 100 +aiii has 101 +aiii has 102 +aiii has 110 +aiii has 111 +aiii has 112 +aiii has 120 +aiii has 121 +aiii has 122 +aiii has 130 +aiii has 131 +aiii has 132 +aiii has 200 +aiii has 201 +aiii has 202 +aiii has 210 +aiii has 211 +aiii has 212 +aiii has 220 +aiii has 221 +aiii has 222 +aiii has 230 +aiii has 231 +aiii has 232 +aiii has 300 +aiii has 301 +aiii has 302 +aiii has 310 +aiii has 311 +aiii has 312 +aiii has 320 +aiii has 321 +aiii has 322 +aiii has 330 +aiii has 331 +aiii has 332 +aiii has 400 +aiii has 401 +aiii has 402 +aiii has 410 +aiii has 411 +aiii has 412 +aiii has 420 +aiii has 421 +aiii has 422 +aiii has 430 +aiii has 431 +aiii has 432 +end +" + +test loop-1.2.2 {foreach with int variable lists} -body { +#lang L --line=1 +void +loop_1_2_2() +{ + int i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12; + int a[12] = { 1,2,3,4,5,6,7,8,9,10,11,12 }; + + printf("test 1\n"); + foreach (i1 in a) { + printf("a has %d\n", i1); + } + printf("test 2\n"); + foreach (i1,i2 in a) { + printf("a has %d,%d\n", i1, i2); + } + printf("test 3\n"); + foreach (i1,i2,i3 in a) { + printf("a has %d,%d,%d\n", i1, i2, i3); + } + printf("test 4\n"); + foreach (i1,i2,i3,i4 in a) { + printf("a has %d,%d,%d,%d\n", i1, i2, i3, i4); + } + printf("test 5\n"); + foreach (i1,i2,i3,i4,i5,i6 in a) { + printf("a has %d,%d,%d,%d,%d,%d\n", i1, i2, i3, i4, i5, i6); + } + printf("test 6\n"); + foreach (i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12 in a) { + printf("a has %d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d,%d\n", + i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12); + } + printf("end\n"); +} +loop_1_2_2(); +} -output "test 1 +a has 1 +a has 2 +a has 3 +a has 4 +a has 5 +a has 6 +a has 7 +a has 8 +a has 9 +a has 10 +a has 11 +a has 12 +test 2 +a has 1,2 +a has 3,4 +a has 5,6 +a has 7,8 +a has 9,10 +a has 11,12 +test 3 +a has 1,2,3 +a has 4,5,6 +a has 7,8,9 +a has 10,11,12 +test 4 +a has 1,2,3,4 +a has 5,6,7,8 +a has 9,10,11,12 +test 5 +a has 1,2,3,4,5,6 +a has 7,8,9,10,11,12 +test 6 +a has 1,2,3,4,5,6,7,8,9,10,11,12 +end +" + +test loop-1.2.3 {foreach with string variable lists} -body { +#lang L --line=1 +void +loop_1_2_3() +{ + string s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14; + string a[12] = { "a","b","c","d","e","f","g","h","i","j","k","l" }; + + printf("test 1\n"); + foreach (s1 in a) { + printf("a has %s\n", s1); + } + printf("test 2\n"); + foreach (s1,s2 in a) { + printf("a has %s,%s\n", s1, s2); + } + printf("test 3\n"); + foreach (s1,s2,s3 in a) { + printf("a has %s,%s,%s\n", s1, s2, s3); + } + printf("test 4\n"); + foreach (s1,s2,s3,s4 in a) { + printf("a has %s,%s,%s,%s\n", s1, s2, s3, s4); + } + printf("test 5\n"); + foreach (s1,s2,s3,s4,s5,s6 in a) { + printf("a has %s,%s,%s,%s,%s,%s\n", s1, s2, s3, s4, s5, s6); + } + printf("test 6\n"); + foreach (s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12); + } + + /* + * The following tests have a number of loop variables that + * isn't divisible by the number of list elements. On the + * last iteration, the stragglers should get undef. + */ + + printf("test 7\n"); + foreach (s1,s2,s3,s4,s5 in a) { + printf("a has %s,%s,%s,%s,%s\n", s1, s2, s3, s4, s5); + if (s1 eq "k") { + unless (defined(s2)) puts("bad 1.1"); + if (defined(s3)) puts("bad 1.2"); + if (defined(s4)) puts("bad 1.3"); + if (defined(s5)) puts("bad 1.4"); + } + } + + printf("test 8\n"); + foreach (s1,s2,s3,s4,s5,s6,s7 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7); + if (s1 eq "h") { + unless (defined(s2)) puts("bad 2.1"); + unless (defined(s3)) puts("bad 2.2"); + unless (defined(s4)) puts("bad 2.3"); + unless (defined(s5)) puts("bad 2.4"); + if (defined(s6)) puts("bad 2.5"); + if (defined(s7)) puts("bad 2.6"); + } + } + + printf("test 9\n"); + foreach (s1,s2,s3,s4,s5,s6,s7,s8 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7, s8); + if (s1 eq "i") { + unless (defined(s2)) puts("bad 3.1"); + unless (defined(s3)) puts("bad 3.2"); + unless (defined(s4)) puts("bad 3.3"); + if (defined(s5)) puts("bad 3.4"); + if (defined(s6)) puts("bad 3.5"); + if (defined(s7)) puts("bad 3.6"); + if (defined(s8)) puts("bad 3.7"); + } + } + + printf("test 10\n"); + foreach (s1,s2,s3,s4,s5,s6,s7,s8,s9 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7, s8, s9); + if (s1 eq "j") { + unless (defined(s2)) puts("bad 4.1"); + unless (defined(s3)) puts("bad 4.2"); + if (defined(s4)) puts("bad 4.3"); + if (defined(s5)) puts("bad 4.4"); + if (defined(s6)) puts("bad 4.5"); + if (defined(s7)) puts("bad 4.6"); + if (defined(s8)) puts("bad 4.7"); + if (defined(s9)) puts("bad 4.8"); + } + } + + printf("test 11\n"); + foreach (s1,s2,s3,s4,s5,s6,s7,s8,s9,s10 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7, s8, s9, s10); + if (s1 eq "k") { + unless (defined(s2)) puts("bad 4.1"); + if (defined(s3)) puts("bad 4.2"); + if (defined(s4)) puts("bad 4.3"); + if (defined(s5)) puts("bad 4.4"); + if (defined(s6)) puts("bad 4.5"); + if (defined(s7)) puts("bad 4.6"); + if (defined(s8)) puts("bad 4.7"); + if (defined(s9)) puts("bad 4.8"); + if (defined(s10)) puts("bad 4.9"); + } + } + + printf("test 12\n"); + foreach (s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11); + if (s1 eq "l") { + if (defined(s2)) puts("bad 5.1"); + if (defined(s3)) puts("bad 5.2"); + if (defined(s4)) puts("bad 5.3"); + if (defined(s5)) puts("bad 5.4"); + if (defined(s6)) puts("bad 5.5"); + if (defined(s7)) puts("bad 5.6"); + if (defined(s8)) puts("bad 5.7"); + if (defined(s9)) puts("bad 5.8"); + if (defined(s10)) puts("bad 5.9"); + if (defined(s11)) puts("bad 5.10"); + } + } + + printf("test 13\n"); + foreach (s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13); + unless (defined(s2)) puts("bad 6.1"); + unless (defined(s3)) puts("bad 6.2"); + unless (defined(s4)) puts("bad 6.3"); + unless (defined(s5)) puts("bad 6.4"); + unless (defined(s6)) puts("bad 6.5"); + unless (defined(s7)) puts("bad 6.6"); + unless (defined(s8)) puts("bad 6.7"); + unless (defined(s9)) puts("bad 6.8"); + unless (defined(s10)) puts("bad 6.9"); + unless (defined(s11)) puts("bad 6.10"); + unless (defined(s12)) puts("bad 6.11"); + if (defined(s13)) puts("bad 6.12"); + } + + printf("test 14\n"); + foreach (s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14 in a) { + printf("a has %s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s,%s\n", + s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, + s14); + unless (defined(s2)) puts("bad 7.1"); + unless (defined(s3)) puts("bad 7.2"); + unless (defined(s4)) puts("bad 7.3"); + unless (defined(s5)) puts("bad 7.4"); + unless (defined(s6)) puts("bad 7.5"); + unless (defined(s7)) puts("bad 7.6"); + unless (defined(s8)) puts("bad 7.7"); + unless (defined(s9)) puts("bad 7.8"); + unless (defined(s10)) puts("bad 7.9"); + unless (defined(s11)) puts("bad 7.10"); + unless (defined(s12)) puts("bad 7.11"); + if (defined(s13)) puts("bad 7.12"); + if (defined(s14)) puts("bad 7.13"); + } + + printf("end\n"); +} +loop_1_2_3(); +} -output "test 1 +a has a +a has b +a has c +a has d +a has e +a has f +a has g +a has h +a has i +a has j +a has k +a has l +test 2 +a has a,b +a has c,d +a has e,f +a has g,h +a has i,j +a has k,l +test 3 +a has a,b,c +a has d,e,f +a has g,h,i +a has j,k,l +test 4 +a has a,b,c,d +a has e,f,g,h +a has i,j,k,l +test 5 +a has a,b,c,d,e,f +a has g,h,i,j,k,l +test 6 +a has a,b,c,d,e,f,g,h,i,j,k,l +test 7 +a has a,b,c,d,e +a has f,g,h,i,j +a has k,l,,, +test 8 +a has a,b,c,d,e,f,g +a has h,i,j,k,l,, +test 9 +a has a,b,c,d,e,f,g,h +a has i,j,k,l,,,, +test 10 +a has a,b,c,d,e,f,g,h,i +a has j,k,l,,,,,, +test 11 +a has a,b,c,d,e,f,g,h,i,j +a has k,l,,,,,,,, +test 12 +a has a,b,c,d,e,f,g,h,i,j,k +a has l,,,,,,,,,, +test 13 +a has a,b,c,d,e,f,g,h,i,j,k,l, +test 14 +a has a,b,c,d,e,f,g,h,i,j,k,l,, +end +" + +test loop-1.2.4 {foreach loops with large loop body (>127 bytes of bytecode)} -body { +#lang L --line=1 +void +loop_1_2_4() +{ + int i, k, v; + int a[3] = { 1,2,3 }; + hash h = { 1=>2, 2=>3, 3=>4 }; + + printf("start\n"); + foreach (i in a) { + /* Just do whatever to rack up bytecodes. */ + int x = 1, y = 1, z = 1; + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19) puts("bad 1.1"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199) puts("bad 1.2"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999) puts("bad 1.3"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999) puts("bad 1.4"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999) puts("bad 1.5"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999) puts("bad 1.6"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999999) puts("bad 1.7"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999999) puts("bad 1.8"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999999) puts("bad 1.9"); + x = y = z = 1; + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19) puts("bad 2.1"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199) puts("bad 2.2"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999) puts("bad 2.3"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999) puts("bad 2.4"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999) puts("bad 2.5"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999) puts("bad 2.6"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999999) puts("bad 2.7"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999999) puts("bad 2.8"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999999) puts("bad 2.9"); + printf("a has %d\n", i); + } + foreach (k=>v in h) { + /* Just do whatever to rack up bytecodes. */ + int x = 1, y = 1, z = 1; + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19) puts("bad 3.1"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199) puts("bad 3.2"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999) puts("bad 3.3"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999) puts("bad 3.4"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999) puts("bad 3.5"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999) puts("bad 3.6"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999999) puts("bad 3.7"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999999) puts("bad 3.8"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999999) puts("bad 3.9"); + x = y = z = 1; + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19) puts("bad 4.1"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199) puts("bad 4.2"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999) puts("bad 4.3"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999) puts("bad 4.4"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999) puts("bad 4.5"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999) puts("bad 4.6"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 19999999) puts("bad 4.7"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 199999999) puts("bad 4.8"); + x = x+y*z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y+z+x*y; + unless (x == 1999999999) puts("bad 4.9"); + printf("h has %d=>%d\n", k, v); + } + printf("end\n"); +} +loop_1_2_4(); +} -output "start +a has 1 +a has 2 +a has 3 +h has 1=>2 +h has 2=>3 +h has 3=>4 +end +" + +test loop-1.2.5 {check hash foreach type checking} -body { +#lang L --line=1 +void loop_1_2_5() +{ + int i1, i2; + string s1, s2; + string h{int}; + + foreach (s1=>s2 in h) ; + foreach (s1=>i2 in h) ; + foreach (i1=>i2 in h) ; +} +#lang tcl +} -returnCodes error -match regexp -result {.*7: L Error: loop index key type incompatible.* +.*8: L Error: loop index value type incompatible.* +.*8: L Error: loop index key type incompatible.* +.*9: L Error: loop index value type incompatible.* +} + +test loop-1.2.6 {test foreach over string} -body { +#lang L --line=1 +void loop_1_2_6() +{ + int i; + string a, b, c, d; + string as[]; + poly p; + + a = "x"; + foreach (a in "") puts("bad 1.1"); + if (defined(a)) puts("bad 1.2"); + + /* as[0] has the value undef */ + a = "x"; + if (defined(as[0])) puts("bad 2.0"); + foreach(a in as[0]) puts("bad 2.1"); + if (defined(a)) puts("bad 2.2"); + + i = 0; + foreach(a in "0123456789") { + unless (a eq (string)i++) printf("bad 2.1 i=%d\n", i); + } + i = 0; + foreach(p in "0123456789") { + unless (p eq (string)i++) printf("bad 2.2 i=%d\n", i); + } + i = 0; + foreach(a,b in "0123456789") { + unless (a eq (string)i++) printf("bad 3.1 i=%d\n", i); + unless (b eq (string)i++) printf("bad 3.2 i=%d\n", i); + } + i = 0; + foreach(a,b,c in "0123456789") { + unless (a eq (string)i++) printf("bad 4.1 i=%d\n", i); + if (i == 10) { + if (defined(b)) puts("bad 4.2 b undef"); + if (defined(c)) puts("bad 4.2 c undef"); + } else { + unless (b eq (string)i++) printf("bad 4.3 i=%d\n", i); + unless (c eq (string)i++) printf("bad 4.4 i=%d\n", i); + } + } + i = 0; + foreach(a,b,c,d in "0123456789") { + unless (a eq (string)i++) printf("bad 5.1 i=%d\n", i); + unless (b eq (string)i++) printf("bad 5.2 i=%d\n", i); + if (i == 10) { + if (defined(c)) puts("bad 5.2 b undef"); + if (defined(d)) puts("bad 5.2 c undef"); + } else { + unless (c eq (string)i++) printf("bad 5.3 i=%d\n", i); + unless (d eq (string)i++) printf("bad 5.4 i=%d\n", i); + } + } +} +loop_1_2_6(); +} -output {} + +test loop-1.2.7 {test foreach over string type errors} -body { +#lang L --line=1 +class loop_1_2_7_class {} +void loop_1_2_7() +{ + int i; + float f; + int a[]; + int h{int}; + loop_1_2_7_class o; + struct { int i,j; } st; + + foreach(i in "string") {} + foreach(f in "string") {} + foreach(h in "string") {} + foreach(a in "string") {} + foreach(o in "string") {} + foreach(st in "string") {} +} +} -returnCodes error -match regexp -result {.*11: L Error: loop index not of string type +.*12: L Error: loop index not of string type +.*13: L Error: loop index not of string type +.*14: L Error: loop index not of string type +.*15: L Error: loop index not of string type +.*16: L Error: loop index not of string type +} + +test loop-1.2.7.1 {test foreach over <> errors} -body { +#lang L --line=1 +void loop_1_2_7_1() +{ + int i; + string s; + FILE f; + + foreach(s in <>) {} + foreach(s in <f>) {} + foreach(s in <1>) {} + foreach(i in <s>) {} + foreach(s,i in <s>) {} + foreach(i,s in <s>) {} + foreach(s,i,s in <s>) {} +} +loop_1_2_7_1(); +} -returnCodes error -match regexp -result {.*7: L Error: this form is disallowed; did you mean while \(buf = <>\)\? +.*8: L Error: this form is disallowed; did you mean while \(buf = <F>\)\? +.*9: L Error: in foreach, arg to <> must be a string +.*10: L Error: loop index i not of string type +.*11: L Error: loop index i not of string type +.*12: L Error: loop index i not of string type +} + +test loop-1.2.8 {test foreach type errors} -body { +#lang L --line=1 -nowarn +void loop_1_2_8() +{ + int i; + float f; + string s; + poly p; + struct { int i,j; } st; + + foreach(s in p) ; + foreach(s in st) ; + foreach(s in {1}) ; + foreach(s in {1,2}) ; + foreach(s in {"s",1}) ; + foreach(s in {1,"s"}) ; + foreach(i,f in {1.0,2.0}); + foreach(f,i in {1.0,2.0}); + + /* This could be made to work, but at present it's a type error. */ + foreach(i,s in {1,"a"}); +} +} -returnCodes error -match regexp -result {.*9: L Error: foreach expression must be array, hash, or string +.*10: L Error: foreach expression must be array, hash, or string +.*11: L Error: loop index type incompatible with array element type +.*12: L Error: loop index type incompatible with array element type +.*13: L Error: loop index type incompatible with array element type +.*14: L Error: loop index type incompatible with array element type +.*15: L Error: loop index type incompatible with array element type +.*16: L Error: loop index type incompatible with array element type +.*19: L Error: loop index type incompatible with array element type +} + +test loop-1.2.9 {test foreach syntax errors} -body { +#lang L --line=1 +void loop_1_2_9() +{ + string k, v; + string h{string}; + + /* + * This test was added after un-reserving the keyword "in", + * used in foreach loops. In the grammar, "in" was replaced + * with an id. Verify that using anything other than "in" is + * a syntax error. + */ + + foreach (k=>v bad h) ; +} +} -returnCodes error -match glob -result {*13: L Error: syntax error* + foreach (k=>v bad h) ; + ^ +} + +test loop-1.2.10 {test foreach syntax errors} -body { +#lang L --line=1 +void loop_1_2_10() +{ + string k, v; + string h{string}; + + /* + * Second part of above test (we can test only one syntax + * error at a time). + */ + + foreach (k bad "xyz") ; +} +} -returnCodes error -match glob -result {*11: L Error: syntax error* + foreach (k bad "xyz") ; + ^ +} + +test loop-1.2.10.1 {test foreach usage errors} -body { +#lang L --line=1 -nowarn +void loop_1_2_10_1() +{ + string k, s, v; + string a[]; + + /* These are all errors. */ + + foreach (k=>v in a) {} + foreach (k=>v in s) {} +} +} -returnCodes error -match glob -result {*8: L Error: => illegal in foreach over arrays +*9: L Error: => illegal in foreach over strings +} + +test loop-1.2.11 {test that "in" is not reserved} -body { +#lang L --line=1 +void loop_1_2_11() +{ + /* + * Verify that "in" is no longer a reserved word. + */ + + int in = 123; + unless (in == 123) puts("bad"); +} +loop_1_2_11(); +} -output {} + +test loop-1.2.12 {check that loop counter is undef on foreach loop fall-through} -body { +#lang L --line=1 +void loop_1_2_12() +{ + int i; + string k, s, t, u, v; + string as[]; + string ah{string}; + + s = "abc"; + i = 0; + t = "xyz"; + unless (defined(t)) puts("bad 1.1"); + foreach (t in s) { ++i; } + unless (i == 3) puts("bad 1.2"); + if (defined(t)) puts("bad 1.3"); + + s = "abcd"; + i = 0; + t = u = "xyz"; + unless (defined(t) && defined(u)) puts("bad 2.1"); + foreach (t,u in s) { ++i; } + unless (i == 2) puts("bad 2.2"); + if (defined(t) || defined(u)) puts("bad 2.3"); + + as = { "1", "2", "3" }; + i = 0; + s = "xyz"; + unless (defined(s)) puts("bad 2.1"); + foreach (s in as) { ++i; } + unless (i == 3) puts("bad 3.2"); + if (defined(s)) puts("bad 3.3"); + + as = { "1", "2", "3", "4" }; + i = 0; + s = t = "xyz"; + unless (defined(s) && defined(t)) puts("bad 4.1"); + foreach (s,t in as) { ++i; } + unless (i == 2) puts("bad 4.2"); + if (defined(s) || defined(t)) puts("bad 4.3"); + + ah = { "k1"=>"1", "k2"=>"2", "k3"=>"3" }; + i = 0; + k = "xyz"; + unless (defined(k)) puts("bad 5.1"); + foreach (k in ah) { ++i; } + unless (i == 3) puts("bad 5.2"); + if (defined(k)) puts("bad 5.3"); + + i = 0; + k = "xyz"; + v = "qrs"; + unless (defined(k) && defined(v)) puts("bad 4.1"); + foreach (k=>v in ah) { ++i; } + unless (i == 3) puts("bad 4.2"); + if (defined(k) || defined(v)) puts("bad 4.3"); +} +loop_1_2_12(); +} -output {} + +test loop-1.2.13 {test foreach over a list type} -body { +#lang L --line=1 +private int equals(poly a[], poly b[]) +{ + unless (length(a) == length(b)) return (0); + while (defined(a[0])) { + unless (defined(a[0]) == defined(b[0])) return (0); + unless (a[0] == b[0]) return (0); + // shift + undef(a[0]); + undef(b[0]); + } + assert(!defined(b[0])); + return (1); +} + +void loop_1_2_13() +{ + int i, i2, i3, ai[]; + string s, s2, s3, as[]; + float f, f2, f3, af[]; + + /* First do a quick test of the equals() helper function. */ + ai = {1,2,3}; + unless (equals(ai, {1,2,3})) puts("bad 0.1"); + if (equals(ai, {1,2})) puts("bad 0.2"); + if (equals(ai, {1,2,3,4})) puts("bad 0.3"); + if (equals(ai, {1,3,2})) puts("bad 0.4"); + as = {"a","b","c"}; + unless (equals(as, {"a","b","c"})) puts("bad 0.5"); + if (equals(as, {"a","b"})) puts("bad 0.6"); + if (equals(as, {"a","b","c","d"})) puts("bad 0.7"); + if (equals(as, {"a","c","b"})) puts("bad 0.8"); + af = {1, 2.2, 3}; + unless (equals(af, {1,2.2,3})) puts("bad 0.9"); + if (equals(af, {1,2.2})) puts("bad 0.10"); + if (equals(af, {1,2.2,3,4})) puts("bad 0.11"); + if (equals(af, {1,3,2.2})) puts("bad 0.12"); + + undef(ai); + foreach (i in {1}) push(&ai, i); + unless (equals(ai, {1})) puts("bad 1.1"); + + undef(ai); + foreach (i in {1,2}) push(&ai, i); + unless (equals(ai, {1,2})) puts("bad 2.1"); + + undef(ai); + foreach (i in {1,2,3}) push(&ai, i); + unless (equals(ai, {1,2,3})) puts("bad 3.1"); + + undef(ai); + foreach (i,i2 in {1,2,3}) { + push(&ai, i); + if (defined(i2)) push(&ai, i2); + } + unless (equals(ai, {1,2,3})) puts("bad 4.1"); + + undef(ai); + foreach (i,i2,i3 in {1,2,3}) { + push(&ai, i); + push(&ai, i2); + push(&ai, i3); + } + unless (equals(ai, {1,2,3})) puts("bad 5.1"); + + undef(as); + foreach (s in {"a"}) push(&as, s); + unless (equals(as, {"a"})) puts("bad 10.1"); + + undef(as); + foreach (s in {"a","b"}) push(&as, s); + unless (equals(as, {"a","b"})) puts("bad 10.2"); + + undef(as); + foreach (s in {"a","b","c"}) push(&as, s); + unless (equals(as, {"a","b","c"})) puts("bad 10.3"); + + undef(as); + foreach (s,s2 in {"a","b","c"}) { + push(&as, s); + if (defined(s2)) push(&as, s2); + } + unless (equals(as, {"a","b","c"})) puts("bad 10.4"); + + undef(as); + foreach (s,s2,s3 in {"a","b","c"}) { + push(&as, s); + push(&as, s2); + push(&as, s3); + } + unless (equals(as, {"a","b","c"})) puts("bad 10.5"); + + undef(af); + foreach (f in {1}) push(&af, f); + unless (equals(af, {1})) puts("bad 20.1"); + + undef(af); + foreach (f in {1.1}) push(&af, f); + unless (equals(af, {1.1})) puts("bad 20.2"); + + undef(af); + foreach (f in {1.1,2}) push(&af, f); + unless (equals(af, {1.1,2})) puts("bad 20.3"); + + undef(af); + foreach (f in {1.1,2,3.3}) push(&af, f); + unless (equals(af, {1.1,2,3.3})) puts("bad 20.4"); + + undef(af); + foreach (f,f2 in {1.1,2,3.3}) { + push(&af, f); + if (defined(f2)) push(&af, f2); + } + unless (equals(af, {1.1,2,3.3})) puts("bad 20.5"); + + undef(af); + foreach (f,f2,f3 in {1.1,2,3.3}) { + push(&af, f); + push(&af, f2); + push(&af, f3); + } + unless (equals(af, {1.1,2,3.3})) puts("bad 20.6"); +} +loop_1_2_13(); +} -output {} + +test loop-1.2.14 {test empty condition in for statement} -body { +#lang L --line=1 +void loop_1_2_14() +{ + int i = 0; + + for (;; ++i) { + break; + } + unless (i == 0) puts("bad 1"); + + i = 0; + for (;;) { + ++i; + break; + } + unless (i == 1) puts("bad 2"); +} +loop_1_2_14(); +} -output {} + +test loop-1.2.15 {test foreach <string>} -body { +#lang L +string l1_2_15(string s) +{ + string t, ret = ""; + + foreach (t in <s>) ret .= "<${t?t:'undef'}>"; + if (t) puts("bad l1_2_15"); + return (ret); +} +string l1_2_15_2(string s) +{ + string t1, t2, ret = ""; + + foreach (t1,t2 in <s>) ret .= "<${t1?t1:'undef'}>[${t2?t2:'undef'}]"; + if (t1 || t2) puts("bad l1_2_15_2"); + return (ret); +} +string l1_2_15_3(string s) +{ + string t1, t2, t3, ret = ""; + + foreach (t1,t2,t3 in <s>) { + ret .= "<${t1?t1:'undef'}>[${t2?t2:'undef'}]{${t3?t3:'undef'}}"; + } + if (t1 || t2 || t3) puts("bad l1_2_15_3"); + return (ret); +} +void loop_1_2_15() +{ + string s, t; + + /* Check a stride of 1, \n line endings. */ + + unless (l1_2_15(undef) == "") puts("bad 1.1"); + unless (l1_2_15("") == "") puts("bad 1.2"); + + unless (l1_2_15("l1") == "<l1>") puts("bad 2.1"); + unless (l1_2_15("l1\n") == "<l1>") puts("bad 2.2"); + + unless (l1_2_15("l1\nl2") == "<l1><l2>") puts("bad 3.1"); + unless (l1_2_15("l1\nl2\n") == "<l1><l2>") puts("bad 3.2"); + + unless (l1_2_15("l1\nl2\nl3") == "<l1><l2><l3>") puts("bad 4.1"); + unless (l1_2_15("l1\nl2\nl3\n") == "<l1><l2><l3>") puts("bad 4.2"); + + /* Check a stride of 1, \r\n line endings. */ + + unless (l1_2_15("l1\r\n") == "<l1>") puts("bad 5.1"); + + unless (l1_2_15("l1\r\nl2") == "<l1><l2>") puts("bad 6.1"); + unless (l1_2_15("l1\r\nl2\r\n") == "<l1><l2>") puts("bad 6.2"); + + unless (l1_2_15("l1\r\nl2\r\nl3") == "<l1><l2><l3>") puts("bad 7.1"); + unless (l1_2_15("l1\r\nl2\r\nl3\r\n") == "<l1><l2><l3>") puts("bad 7.2"); + + /* Check a stride of 2, \n line endings. */ + + unless (l1_2_15_2(undef) == "") puts("bad 10.1"); + unless (l1_2_15_2("") == "") puts("bad 10.2"); + + unless (l1_2_15_2("l1") == "<l1>[undef]") puts("bad 11.1"); + unless (l1_2_15_2("l1\n") == "<l1>[undef]") puts("bad 11.2"); + + unless (l1_2_15_2("l1\nl2") == "<l1>[l2]") puts("bad 12.1"); + unless (l1_2_15_2("l1\nl2\n") == "<l1>[l2]") puts("bad 12.2"); + + unless (l1_2_15_2("l1\nl2\nl3") == "<l1>[l2]<l3>[undef]") { + puts("bad 13.1"); + } + unless (l1_2_15_2("l1\nl2\nl3\n") == "<l1>[l2]<l3>[undef]") { + puts("bad 13.2"); + } + + unless (l1_2_15_2("l1\nl2\nl3\nl4") == "<l1>[l2]<l3>[l4]") { + puts("bad 14.1"); + } + unless (l1_2_15_2("l1\nl2\nl3\nl4\n") == "<l1>[l2]<l3>[l4]") { + puts("bad 14.2"); + } + + /* Check a stride of 2, \r\n line endings. */ + + unless (l1_2_15_2("l1\r\n") == "<l1>[undef]") puts("bad 15.1"); + + unless (l1_2_15_2("l1\r\nl2") == "<l1>[l2]") puts("bad 16.1"); + unless (l1_2_15_2("l1\r\nl2\r\n") == "<l1>[l2]") puts("bad 16.2"); + + unless (l1_2_15_2("l1\r\nl2\r\nl3") == "<l1>[l2]<l3>[undef]") { + puts("bad 17.1"); + } + unless (l1_2_15_2("l1\r\nl2\r\nl3\r\n") == "<l1>[l2]<l3>[undef]") { + puts("bad 17.2"); + } + + unless (l1_2_15_2("l1\r\nl2\r\nl3\r\nl4") == "<l1>[l2]<l3>[l4]") { + puts("bad 18.1"); + } + unless (l1_2_15_2("l1\r\nl2\r\nl3\r\nl4\r\n") == "<l1>[l2]<l3>[l4]") { + puts("bad 18.2"); + } + + /* Check a stride of 3, \n line endings. */ + + unless (l1_2_15_3(undef) == "") puts("bad 20.1"); + unless (l1_2_15_3("") == "") puts("bad 20.2"); + + unless (l1_2_15_3("l1") == "<l1>[undef]{undef}") puts("bad 21.1"); + unless (l1_2_15_3("l1\n") == "<l1>[undef]{undef}") puts("bad 21.2"); + + unless (l1_2_15_3("l1\nl2") == "<l1>[l2]{undef}") puts("bad 22.1"); + unless (l1_2_15_3("l1\nl2\n") == "<l1>[l2]{undef}") puts("bad 22.2"); + + unless (l1_2_15_3("l1\nl2\nl3") == "<l1>[l2]{l3}") puts("bad 23.1"); + unless (l1_2_15_3("l1\nl2\nl3\n") == "<l1>[l2]{l3}") puts("bad 23.2"); + + unless (l1_2_15_3("l1\nl2\nl3\nl4") == "<l1>[l2]{l3}<l4>[undef]{undef}") { + puts("bad 24.1"); + } + unless (l1_2_15_3("l1\nl2\nl3\nl4\n") == "<l1>[l2]{l3}<l4>[undef]{undef}") { + puts("bad 24.2"); + } + + unless (l1_2_15_3("l1\nl2\nl3\nl4\nl5") == "<l1>[l2]{l3}<l4>[l5]{undef}") { + puts("bad 25.1"); + } + unless (l1_2_15_3("l1\nl2\nl3\nl4\nl5\n") == "<l1>[l2]{l3}<l4>[l5]{undef}") { + puts("bad 25.2"); + } + + unless (l1_2_15_3("l1\nl2\nl3\nl4\nl5\nl6") == "<l1>[l2]{l3}<l4>[l5]{l6}") { + puts("bad 26.1"); + } + unless (l1_2_15_3("l1\nl2\nl3\nl4\nl5\nl6\n") == "<l1>[l2]{l3}<l4>[l5]{l6}") { + puts("bad 26.2"); + } + + /* Check a stride of 3, \r\n line endings. */ + + unless (l1_2_15_3("l1\r\n") == "<l1>[undef]{undef}") puts("bad 27.1"); + + unless (l1_2_15_3("l1\r\nl2") == "<l1>[l2]{undef}") puts("bad 28.1"); + unless (l1_2_15_3("l1\r\nl2\r\n") == "<l1>[l2]{undef}") puts("bad 28.2"); + + unless (l1_2_15_3("l1\r\nl2\r\nl3") == "<l1>[l2]{l3}") { + puts("bad 29.1"); + } + unless (l1_2_15_3("l1\r\nl2\r\nl3\r\n") == "<l1>[l2]{l3}") { + puts("bad 29.2"); + } + + unless (l1_2_15_3("l1\r\nl2\r\nl3\r\nl4") == "<l1>[l2]{l3}<l4>[undef]{undef}") { + puts("bad 30.1"); + } + unless (l1_2_15_3("l1\r\nl2\r\nl3\r\nl4\r\n") == "<l1>[l2]{l3}<l4>[undef]{undef}") { + puts("bad 30.2"); + } + + unless (l1_2_15_3("l1\r\nl2\r\nl3\r\nl4\r\nl5") == "<l1>[l2]{l3}<l4>[l5]{undef}") { + puts("bad 31.1"); + } + unless (l1_2_15_3("l1\r\nl2\r\nl3\r\nl4\r\nl5\r\n") == "<l1>[l2]{l3}<l4>[l5]{undef}") { + puts("bad 31.2"); + } + + unless (l1_2_15_3("l1\r\nl2\r\nl3\r\nl4\r\nl5\r\nl6") == "<l1>[l2]{l3}<l4>[l5]{l6}") { + puts("bad 32.1"); + } + unless (l1_2_15_3("l1\r\nl2\r\nl3\r\nl4\r\nl5\r\nl6\r\n") == "<l1>[l2]{l3}<l4>[l5]{l6}") { + puts("bad 32.2"); + } + + /* Check break and continue from inside the foreach. */ + + t = ""; + foreach (s in <"l1\nl2\nl3\nl4\n">) { + t .= "b<${s}>"; + if (s == "l1") continue; + if (s == "l2") break; + t .= "a<${s}>"; + } + unless (t == "b<l1>b<l2>") puts("bad 50.1 ${t}"); + unless (s == "l2") puts("bad 50.2"); +} +loop_1_2_15(); +} -output {} + +test loop-1.2.15.1 {test foreach <string>} -body { +#lang L +void loop_1_2_15_1() +{ + string s = "1\n2\n\3\n4\n"; + string k, v; + + foreach (k => v in <s>) printf("%s,%s\n", k, v); +} +loop_1_2_15_1(); +} -returnCodes error -match regexp -result {.*: L Error: => illegal in foreach over strings} + +test loop-1.3 {continue statements} -body { +#lang L --line=1 +void loop_1_3_for_continue() +{ + int i; + + for (i = 0; i < 5; i++) { + if (i == 2) continue; + puts(i); + } +} + +void loop_1_3_foreach_continue() +{ + string k, l, v; + string as[] = { "1", "2", "3", "4", "5" }; + hash h; + + h{"a"} = "x"; + h{"b"} = "y"; + h{"c"} = "z"; + + printf("foreach test 1\n"); + foreach (k => v in h) { + if (k eq "b") continue; + printf("%s => %s\n", k, v); + } + + printf("foreach test 2\n"); + foreach (l in h) { + if (l eq "c") continue; + foreach (k => v in h) { + if (k eq "b") continue; + printf("%s: %s => %s\n", l, k, v); + } + } + + printf("foreach test 3\n"); + foreach (v in as) { + if ((v ge "2") && (v le "4")) continue; + printf("%s\n", v); + } + + printf("foreach test 4\n"); + foreach (l in "abcdefg") { + if ((l ge "d") && (l le "f")) continue; + printf("%s\n", l); + } +} + +void loop_1_3_do_while_continue() +{ + int i; + + printf("do while test\n"); + i = -1; + do { + ++i; + if ((i == 1) || (i == 2)) continue; + puts(i); + } while (i < 5); +} + +void loop_1_3_while_continue() +{ + int i; + + printf("while test\n"); + i = -1; + while (i < 5) { + ++i; + if ((i == 1) || (i == 2)) continue; + puts(i); + }; +} + +void loop_1_3() +{ + loop_1_3_for_continue(); + loop_1_3_foreach_continue(); + loop_1_3_do_while_continue(); + loop_1_3_while_continue(); +} +#lang tcl +loop_1_3 +} -output {0 +1 +3 +4 +foreach test 1 +a => x +c => z +foreach test 2 +a: a => x +a: c => z +b: a => x +b: c => z +foreach test 3 +1 +5 +foreach test 4 +a +b +c +g +do while test +0 +3 +4 +5 +while test +0 +3 +4 +5 +} + +test loop-1.4 {break statements} -body { +#lang L --line=1 +void loop_1_4_foreach_break() +{ + string k, l, v; + string as[] = { "1", "2", "3", "4", "5" }; + hash h; + + h{"a"} = "x"; + h{"b"} = "y"; + h{"c"} = "z"; + foreach (l in h) { + foreach (k => v in h) { + if (k eq "b") break; + } + } + printf("loops over, k is %s, v is %s\n", k, v); + + foreach (l in as) { + if (l eq "3") break; + } + printf("l is %s\n", l); + + foreach (l in "abcdefg") { + if (l eq "c") break; + } + printf("l is %s\n", l); +} + +void loop_1_4_for_break() +{ + int i; + + for (i = 0; i < 10; i++) { + puts(i); + if (i == 5) { + puts("attempting to break"); + break; + } + } + printf("at the end of the day, i is %d\n", i); +} + +void loop_1_4_do_while_break() +{ + int i; + + i = 0; + do { + ++i; + if (i == 3) break; + } while (i < 5); + printf("do while i = %d\n", i); +} + +void loop_1_4_while_break() +{ + int i; + + i = 0; + while (i < 5) { + ++i; + if (i == 3) break; + } + printf("while i = %d\n", i); +} + +void loop_1_4() +{ + loop_1_4_foreach_break(); + loop_1_4_for_break(); + loop_1_4_do_while_break(); + loop_1_4_while_break(); +} + +#lang tcl +loop_1_4 +} -output {loops over, k is b, v is y +l is 3 +l is c +0 +1 +2 +3 +4 +5 +attempting to break +at the end of the day, i is 5 +do while i = 3 +while i = 3 +} + +test loop-1.5 {continues in nested foreach loops} -body { +#lang L --line=1 +void +loop_1_5_fill3(int d1, int d2, int d3, int &a[][][]) +{ + int i, j, k; + + for (i = 0; i < d1; ++i) { + for (j = 0; j < d2; ++j) { + for (k = 0; k < d3; ++k) { + a[i][j][k] = (i+1)*100 + (j+1)*10 + k+1; + } + } + } +} + +void +loop_1_5() +{ + int d1, d2, vi; + int ai[3]; + int aii[3][3]; + int aiii[3][3][3]; + + loop_1_5_fill3(3, 3, 3, &aiii); + + printf("test 1\n"); + foreach (aii in aiii) { + foreach (ai in aii) { + foreach (vi in ai) { + // Omit all even numbers. + if ((vi%2) == 0) continue; + printf("aiii has %d\n", vi); + } + } + } + printf("test 2\n"); + d1 = d2 = 0; + foreach (aii in aiii) { + ++d1; + foreach (ai in aii) { + ++d2; + // Omit 11x. + if (d2 == 1) continue; + foreach (vi in ai) { + printf("aiii has %d\n", vi); + } + } + } + printf("test 3\n"); + d1 = d2 = 0; + foreach (aii in aiii) { + ++d1; + // Omit 1xx. + if (d1 == 1) continue; + foreach (ai in aii) { + ++d2; + foreach (vi in ai) { + printf("aiii has %d\n", vi); + } + } + } + printf("test 4\n"); + d1 = d2 = 0; + foreach (aii in aiii) { + ++d1; + // Omit 1xx. + if (d1 == 1) continue; + foreach (ai in aii) { + ++d2; + // Omit 21x. + if (d2 == 1) continue; + foreach (vi in ai) { + printf("aiii has %d\n", vi); + } + } + } + printf("test 5\n"); + d1 = d2 = 0; + foreach (aii in aiii) { + ++d1; + // Omit 1xx. + if (d1 == 1) continue; + foreach (ai in aii) { + ++d2; + // Omit 21x. + if (d2 == 1) continue; + foreach (vi in ai) { + // Omit 3xx. + if (vi >= 300) continue; + printf("aiii has %d\n", vi); + } + } + } + printf("end\n"); +} + +loop_1_5(); +} -output "test 1 +aiii has 111 +aiii has 113 +aiii has 121 +aiii has 123 +aiii has 131 +aiii has 133 +aiii has 211 +aiii has 213 +aiii has 221 +aiii has 223 +aiii has 231 +aiii has 233 +aiii has 311 +aiii has 313 +aiii has 321 +aiii has 323 +aiii has 331 +aiii has 333 +test 2 +aiii has 121 +aiii has 122 +aiii has 123 +aiii has 131 +aiii has 132 +aiii has 133 +aiii has 211 +aiii has 212 +aiii has 213 +aiii has 221 +aiii has 222 +aiii has 223 +aiii has 231 +aiii has 232 +aiii has 233 +aiii has 311 +aiii has 312 +aiii has 313 +aiii has 321 +aiii has 322 +aiii has 323 +aiii has 331 +aiii has 332 +aiii has 333 +test 3 +aiii has 211 +aiii has 212 +aiii has 213 +aiii has 221 +aiii has 222 +aiii has 223 +aiii has 231 +aiii has 232 +aiii has 233 +aiii has 311 +aiii has 312 +aiii has 313 +aiii has 321 +aiii has 322 +aiii has 323 +aiii has 331 +aiii has 332 +aiii has 333 +test 4 +aiii has 221 +aiii has 222 +aiii has 223 +aiii has 231 +aiii has 232 +aiii has 233 +aiii has 311 +aiii has 312 +aiii has 313 +aiii has 321 +aiii has 322 +aiii has 323 +aiii has 331 +aiii has 332 +aiii has 333 +test 5 +aiii has 221 +aiii has 222 +aiii has 223 +aiii has 231 +aiii has 232 +aiii has 233 +end +" + +test loop-1.6 {breaks in nested foreach loops} -body { +#lang L --line=1 +void +loop_1_6_fill3(int d1, int d2, int d3, int &a[][][]) +{ + int i, j, k; + + for (i = 0; i < d1; ++i) { + for (j = 0; j < d2; ++j) { + for (k = 0; k < d3; ++k) { + a[i][j][k] = (i+1)*100 + (j+1)*10 + k+1; + } + } + } +} + +void +loop_1_6() +{ + int d1, d2, vi; + int ai[3]; + int aii[3][3]; + int aiii[3][3][3]; + + loop_1_6_fill3(3, 3, 3, &aiii); + + printf("test 1\n"); + foreach (aii in aiii) { + foreach (ai in aii) { + foreach (vi in ai) { + // Should have no output. + break; + printf("aiii has %d\n", vi); + } + } + } + printf("test 2\n"); + d1 = d2 = 0; + foreach (aii in aiii) { + ++d1; + foreach (ai in aii) { + ++d2; + // Omit 13x. + if (d2 == 3) break; + foreach (vi in ai) { + printf("aiii has %d\n", vi); + } + } + } + printf("test 3\n"); + d1 = d2 = 0; + foreach (aii in aiii) { + ++d1; + // Omit [23]xx. + if (d1 == 2) break; + foreach (ai in aii) { + ++d2; + foreach (vi in ai) { + printf("aiii has %d\n", vi); + } + } + } + printf("end\n"); +} + +loop_1_6(); +} -output "test 1 +test 2 +aiii has 111 +aiii has 112 +aiii has 113 +aiii has 121 +aiii has 122 +aiii has 123 +aiii has 211 +aiii has 212 +aiii has 213 +aiii has 221 +aiii has 222 +aiii has 223 +aiii has 231 +aiii has 232 +aiii has 233 +aiii has 311 +aiii has 312 +aiii has 313 +aiii has 321 +aiii has 322 +aiii has 323 +aiii has 331 +aiii has 332 +aiii has 333 +test 3 +aiii has 111 +aiii has 112 +aiii has 113 +aiii has 121 +aiii has 122 +aiii has 123 +aiii has 131 +aiii has 132 +aiii has 133 +end +" + +test loop-1.6.1 {test break and continue errors} -body { +#lang L --line=1 +/* + * Try a break and continue in various (non-loop) constructs + * that open up a new scope in the compiler. All of these + * should be errors. + */ +void loop_1_6_1() +{ + break; + continue; + { + break; + continue; + } + if (1) { + break; + continue; + } else { + break; + continue; + } + switch (1) { + case 1: + continue; + } +} +break; +continue; +} -returnCodes error -match regexp -result {.*8: L Error: break allowed only inside switch and loop statements +.*9: L Error: continue allowed only inside loops +.*11: L Error: break allowed only inside switch and loop statements +.*12: L Error: continue allowed only inside loops +.*15: L Error: break allowed only inside switch and loop statements +.*16: L Error: continue allowed only inside loops +.*18: L Error: break allowed only inside switch and loop statements +.*19: L Error: continue allowed only inside loops +.*23: L Error: continue allowed only inside loops +.*26: L Error: break allowed only inside switch and loop statements +.*27: L Error: continue allowed only inside loops +} + +test loop-1.7 {test loop condition with regexp captures} -body { +#lang L --line=1 +void loop_1_7() +{ + /* + * This checks for an earlier compiler bug where the loop + * condition was sometimes compiled before the loop body, + * causing any regexp capture variable references to possibly + * become undeclared-variable references. + */ + + int it; + + it = 0; + while ("abc" =~ /(a)(b)/) { + ++it; + unless (($1 eq "a") && ($2 eq "b")) { + puts("bad 1.1"); + } + break; + } + unless (it == 1) puts("bad 1.2"); + + /* Use more captures than last time. */ + for (it = 0; "abcd" =~ /(a)(b)(c)(d)/; ) { + ++it; + unless (($1 eq "a") && ($2 eq "b") && ($3 eq "c") && + ($4 eq "d")) { + puts("bad 2.1"); + } + break; + } + unless (it == 1) puts("bad 2.2"); +} +loop_1_7(); +} -output {} + +test switch-1.1 {check switch statement, if-then-else code} -body { +#lang L --line=1 +/* + * This test exercises the case of non-constant case expressions in + * switch statements, for which the compiler generates if-then-else + * style code. Only one case value must be non-constant, which is why + * you see "0+zero" etc below. + */ +void switch_1_1() +{ + int a, b, c, d, i; + int zero = 0; + int ia[] = { 3, 1, 4, 1 }; + string m, mm, mvar, s, s1, s2, s3, s4, s5; + string sa[] = { "abc", "def", "ghi", "JkL" }; + widget w; + + /* Test empty switch statement. */ + i = 0; + switch (++i) {} + unless (i == 1) puts("bad 0.1"); + + /* Test string and regexp matching. */ + s = ""; + for (i = 0; i < length(sa); ++i) { + switch (sa[i]) { + case "abc": + unless (i == 0) puts("bad 1.1"); + s .= "a"; + break; + case /de/: + unless (i == 1) puts("bad 1.2"); + s .= "d"; + break; + case /a*c*f*g/: + unless (i == 2) puts("bad 1.3"); + s .= "g"; + break; + case /jkl/: + puts("bad 1.4"); + break; + case /jkl/i: + unless (i == 3) puts("bad 1.5"); + s .= "j"; + break; + case "bad": + puts("bad 1.6"); + break; + case /also bad/: + puts("bad 1.7"); + break; + } + } + unless (s eq "adgj") puts("bad 1.9"); + + /* Test matching on ints. */ + s = ""; + for (i = 0; i < length(ia); ++i) { + switch (ia[i]) { + case 0+zero: // for a non-constant case value + puts("bad 2.1"); + break; + case 1: + unless ((i == 1) || (i == 3)) puts("bad 2.2"); + s .= "1"; + break; + case 2: + puts("bad 2.3"); + break; + case 3: + unless (i == 0) puts("bad 2.4"); + s .= "3"; + break; + case 4: + unless (i == 2) puts("bad 2.5"); + s .= "4"; + break; + } + } + unless (s eq "3141") puts("bad 2.9"); + + /* Test checking for undef. */ + + s = undef; + i = 0; + switch (s) { + case undef: + ++i; + break; + default: + puts("bad 2.11"); + break; + } + unless (i == 1) puts("bad 2.12"); + + s = ""; + i = 0; + switch (s) { + case undef: + puts("bad 2.13"); + break; + default: + ++i; + break; + } + unless (i == 1) puts("bad 2.14"); + + s = s1 = undef; + i = 0; + switch (s) { + case s1: + puts("bad 2.15"); + break; + case undef: + ++i; + case "fall through to this one": + ++i; + break; + default: + puts("bad 2.16"); + break; + } + unless (i == 2) puts("bad 2.17"); + + s = s1 = undef; + i = 0; + switch (s) { + case undef: + ++i; + break; + case s1: + puts("bad 2.18"); + break; + default: + puts("bad 2.19"); + break; + } + unless (i == 1) puts("bad 2.20"); + + s = undef; + s1 = ""; + i = 0; + switch (s) { + case s1: + puts("bad 2.21"); + break; + case undef: + ++i; + break; + default: + puts("bad 2.22"); + break; + } + unless (i == 1) puts("bad 2.23"); + + /* Test case fall through. */ + s = ""; + switch (1) { + case 1+zero: + s .= "1"; + case 2: + s .= "2"; + break; + case 3: + s .= "3"; + } + unless (s eq "12") puts("bad 3.1"); + + /* Test multiple cases per leg. */ + s = ""; + for (i = 0; i < 6; ++i) { + switch (i) { + case 0+zero: + s .= "0"; + break; + case 1: + case 2: + s .= (string)i; + break; + case 3: + case 4: + case 5: + s .= (string)i; + break; + } + } + unless (s eq "012345") puts("bad 4.1"); + + /* Test default case in the end, beginning, and middle of the cases. */ + + s = ""; + switch (3) { + case 0+zero: + puts("bad 5.1"); + break; + default: + s .= "d"; + break; + } + unless (s eq "d") puts("bad 5.2"); + + s = ""; + switch (3) { + default: + s .= "d"; + break; + case 0+zero: + puts("bad 5.3"); + break; + } + unless (s eq "d") puts("bad 5.4"); + + s = ""; + switch (3) { + case 1+zero: + puts("bad 5.5"); + break; + default: + s .= "d"; + break; + case 0: + puts("bad 5.6"); + break; + } + unless (s eq "d") puts("bad 5.7"); + + /* Test falling thru to and from the default case. */ + + s = ""; + switch (3) { + case 3+zero: + s .= "3"; + default: + s .= "d"; + break; + } + unless (s eq "3d") puts("bad 6.1"); + + s = ""; + switch (3) { + default: + s .= "d"; + case 0+zero: + s .= "0"; + break; + } + unless (s eq "d0") puts("bad 6.2"); + + s = ""; + switch (3) { + case 0: + s .= "0"; + break; + default: + s .= "d"; + case 1+zero: + s .= "1"; + break; + } + unless (s eq "d1") puts("bad 6.3"); + + s = ""; + switch (3) { + default: + s .= "d"; + case 1+zero: + s .= "1"; + case 0: + s .= "0"; + } + unless (s eq "d10") puts("bad 6.4"); + + s = ""; + switch (3) { + case 1+zero: + s .= "1"; + default: + s .= "d"; + case 0: + s .= "0"; + } + unless (s eq "d0") puts("bad 6.5"); + + /* Test empty case bodies. */ + + s = ""; + for (i = 0; i < 4; ++i) { + switch (i) { + case 0+zero: + case 1: + case 3: + s .= (string)i; + break; + case 2: + default: + } + } + unless (s eq "013") puts("bad 7.2"); + + s = ""; + switch (2) { + case 2+zero: + default: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.3"); + + s = ""; + switch (0) { + case 2+zero: + default: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.4"); + + s = ""; + switch (2) { + default: + case 2+zero: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.5"); + + s = ""; + switch (0) { + default: + case 2+zero: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.6"); + + s = ""; + switch (2) { + case 2+zero: + default: + case 1: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.7"); + + s = ""; + switch (1) { + case 2+zero: + default: + case 1: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.8"); + + s = ""; + switch (0) { + case 2+zero: + default: + case 1: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.9"); + + /* Test various whitespace around regexp, and regexp variations. */ + s = ""; + m = "nn"; + mm = "oo"; + mvar = "pp"; + foreach (s1 in {"aa","bb","cc","dd","ee","ff","gg","hh","ii", + "jj","kk","ll","mm","nn","oo","pp"}) { + switch (s1) { + // the next line has a tab after the "case" + case /aa/: s .= "1"; break; + case m|bb|: s .= "2"; break; + case m|Cc|i: s .= "3"; break; + case m#dd#: s .= "4"; break; + case m#eE#i: s .= "5"; break; + case m)ff): s .= "6"; break; + case m)Gg)i: s .= "7"; break; + case m,hh,: s .= "8"; break; + case m,Ii,i: s .= "9"; break; + case m!jj!: s .= "a"; break; + case m!Kk!i: s .= "b"; break; + case m"ll": s .= "c"; break; + case m"Mm"i: s .= "d"; break; + // the next ones aren't regexps + case m: s .= "e"; break; // variable m + case mm: s .= "f"; break; // variable mm + case mvar: s .= "g"; break; // variable mvar + } + } + unless (s eq "123456789abcdefg") puts("bad 8.1"); + + /* Test interpolations in regexp's. */ + s = ""; + s1 = "ab"; + s2 = "ef"; + s3 = "g"; + s4 = "i"; + s5 = "jkl"; + for (i = 0; i < length(sa); ++i) { + switch (sa[i]) { + case /${s1}c/: + s .= "a"; + break; + case /d${s2}/: + s .= "d"; + break; + case /${s3}h${s4}/: + s .= "g"; + break; + case /${s5}/i: + s .= "j"; + break; + } + } + unless (s eq "adgj") puts("bad 9.1"); + + /* Test $1 $2 etc available in cases. */ + switch ("This is a test") { + case /(test)/: + unless ($1 eq "test") puts("bad 10.1"); + break; + } + switch ("This is a test") { + case /(a) (test)/: + unless ($1 eq "a") puts("bad 10.2"); + unless ($2 eq "test") puts("bad 10.3"); + break; + } + + /* Test labeled statements in cases. */ + + i = 0; + switch (1) { + case 1+zero: + lab1: if (i++) break; + goto lab1; + } + unless (i == 2) puts("bad 11.1"); + + i = 0; + switch (0) { + case 1+zero: + lab2: if (i++) break; + goto lab2; + default: + lab3: if (i++) break; + goto lab3; + } + unless (i == 2) puts("bad 11.2"); + + /* + * Test goto out of the switch to check that the run-time + * stack remains balanced. This used to crash due to a bug. + * However, it's difficult to see the regression as a crash in + * a release build. If we have the loop below iterate only a few + * times, the Tcl bytecode engine seems to happily scribble + * memory but on some platforms it is in a region where + * it does not cause a crash. I'm hesitant to have the loop + * iterate too many times since Larry already doesn't like how + * long the L tests take. But it can easily be seen in a Tcl + * debug build. + */ + + for (i = 1; i < 1000; ++i) { + switch (i) { + case i: + goto sw_1_1_next; + } + sw_1_1_next: + } + + /* + * Test id: at end of case expression. At one point this used + * to cause a syntax error. + */ + + i = 0; + switch (0) { + case i: + ++i; + break; + default: + puts("bad 12.1"); + break; + } + unless (i == 1) puts("bad 12.2"); + + i = 0; + switch (0) { + case 1+i-1-i: + ++i; + break; + default: + puts("bad 12.3"); + break; + } + unless (i == 1) puts("bad 12.4"); + + /* + * Test that the right comparison bytecode is generated + * (string vs numeric). + */ + i = 0; + switch ("0") { + case "00": + puts("bad 13.1"); + break; + case /0/: + default: + ++i; + break; + } + unless (i == 1) puts("bad 13.2"); + + /* + * Check that integer switch expressions and the case values + * are properly canonicalized. + */ + + s = ""; + for (i = 0; i <= 3; ++i) { + switch (i) { + case 0: + s .= "0"; + break; + case 0x1: + s .= "1"; + break; + case 0o2: + s .= "2"; + break; + case 000000003: + s .= "3"; + break; + case 99+0: + default: + puts("bad 13.3"); + break; + } + } + unless (s eq "0123") puts("bad 13.4"); + + s = ""; + for (i = 100000000000000000000; i <= 100000000000000000003; ++i) { + switch (i) { + case 100000000000000000000: + s .= "0"; + break; + case 0x56bc75e2d63100001: + s .= "1"; + break; + case 0o12657072742654304000002: + s .= "2"; + break; + case 0000000000000100000000000000000003: + s .= "3"; + break; + case 99+0: + default: + puts("bad 13.5"); + break; + } + } + unless (s eq "0123") puts("bad 13.6"); + + s = ""; + a = (poly)"100000000000000000000"; + b = (poly)"0x56bc75e2d63100001"; // this is a+1 + c = (poly)"0o12657072742654304000002"; // this is a+2 + d = (poly)"100000000000000000003"; // this is a+3 + for (i = 100000000000000000000; i <= 100000000000000000003; ++i) { + switch (i) { + case a: + s .= "0"; + break; + case b: + s .= "1"; + break; + case c: + s .= "2"; + break; + case d: + s .= "3"; + break; + default: + puts("bad 13.7"); + break; + } + } + unless (s eq "0123") puts("bad 13.8"); + + s = ""; + i = (poly)"0x1"; // don't use (int) since that canonicalizes + switch (i) { + case 1: + s .= "1"; + break; + case 99+0: + default: + puts("bad 13.9"); + break; + } + unless (s eq "1") puts("bad 13.10"); + + /* Test switching on a widget type. */ + + w = "2"; + s = ""; + switch (w) { + case "1": + puts("bad 14.1"); + break; + case /2/: + s .= "1"; + break; + default: + puts("bad 14.2"); + break; + } + unless (s eq "1") puts("bad 14.3"); +} +switch_1_1(); +} -output {} + +test switch-1.2 {check switch statement, jump-table code} -body { +#lang L --line=1 +/* + * This test exercises the case of constant case expressions in switch + * statements, for which the compiler generates a jump table. This is + * basically the above test edited to have only constant case values. + */ +void switch_1_2() +{ + int i; + int ia[] = { 3, 1, 4, 1 }; + string s; + string sa[] = { "abc", "def", "ghi", "JkL", "00" }; + widget w; + + /* Test string matching. */ + s = ""; + for (i = 0; i < length(sa); ++i) { + switch (sa[i]) { + case "abc": + unless (i == 0) puts("bad 1.1"); + s .= "a"; + break; + case "def": + unless (i == 1) puts("bad 1.2"); + s .= "d"; + break; + case "ghi": + unless (i == 2) puts("bad 1.3"); + s .= "g"; + break; + case "jkl": + puts("bad 1.4"); + break; + case "JkL": + unless (i == 3) puts("bad 1.5"); + s .= "j"; + break; + case "bad": + puts("bad 1.6"); + break; + case "also bad": + puts("bad 1.7"); + break; + case "0": // should not match "00" + puts("bad 1.8"); + break; + } + } + unless (s eq "adgj") {puts("bad 1.9"); puts(s); } + + /* + * Test matching on ints. The leading zeros check that the + * compiler isn't doing a pure string match. + */ + s = ""; + for (i = 0; i < length(ia); ++i) { + switch (ia[i]) { + case 0: + puts("bad 2.1"); + break; + case 01: + unless ((i == 1) || (i == 3)) puts("bad 2.2"); + s .= "1"; + break; + case 2: + puts("bad 2.3"); + break; + case 003: + unless (i == 0) puts("bad 2.4"); + s .= "3"; + break; + case 4: + unless (i == 2) puts("bad 2.5"); + s .= "4"; + break; + } + } + unless (s eq "3141") puts("bad 2.9"); + + /* Test case fall through. */ + s = ""; + switch (1) { + case 1: + s .= "1"; + case 2: + s .= "2"; + break; + case 3: + s .= "3"; + } + unless (s eq "12") puts("bad 3.1"); + + /* Test multiple cases per leg. */ + s = ""; + for (i = 0; i < 6; ++i) { + switch (i) { + case 0: + s .= "0"; + break; + case 1: + case 2: + s .= (string)i; + break; + case 3: + case 4: + case 5: + s .= (string)i; + break; + } + } + unless (s eq "012345") puts("bad 4.1"); + + /* Test default case in the end, beginning, and middle of the cases. */ + + s = ""; + switch (3) { + case 0: + puts("bad 5.1"); + break; + default: + s .= "d"; + break; + } + unless (s eq "d") puts("bad 5.2"); + + s = ""; + switch (3) { + default: + s .= "d"; + break; + case 0: + puts("bad 5.3"); + break; + } + unless (s eq "d") puts("bad 5.4"); + + s = ""; + switch (3) { + case 1: + puts("bad 5.5"); + break; + default: + s .= "d"; + break; + case 0: + puts("bad 5.6"); + break; + } + unless (s eq "d") puts("bad 5.7"); + + /* Test lone default clause. */ + s = ""; + switch (3) { + default: + s .= "d"; + } + unless (s eq "d") puts("bad 5.8"); + + /* Test falling thru to and from the default case. */ + + s = ""; + switch (3) { + case 3: + s .= "3"; + default: + s .= "d"; + break; + } + unless (s eq "3d") puts("bad 6.1"); + + s = ""; + switch (3) { + default: + s .= "d"; + case 0: + s .= "0"; + break; + } + unless (s eq "d0") puts("bad 6.2"); + + s = ""; + switch (3) { + case 0: + s .= "0"; + break; + default: + s .= "d"; + case 1: + s .= "1"; + break; + } + unless (s eq "d1") puts("bad 6.3"); + + s = ""; + switch (3) { + default: + s .= "d"; + case 1: + s .= "1"; + case 0: + s .= "0"; + } + unless (s eq "d10") puts("bad 6.4"); + + s = ""; + switch (3) { + case 1: + s .= "1"; + default: + s .= "d"; + case 0: + s .= "0"; + } + unless (s eq "d0") puts("bad 6.5"); + + /* Test empty case bodies. */ + + s = ""; + for (i = 0; i < 4; ++i) { + switch (i) { + case 0: + case 1: + case 3: + s .= (string)i; + break; + case 2: + default: + } + } + unless (s eq "013") puts("bad 7.2"); + + s = ""; + switch (2) { + case 2: + default: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.3"); + + s = ""; + switch (0) { + case 2: + default: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.4"); + + s = ""; + switch (2) { + default: + case 2: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.5"); + + s = ""; + switch (0) { + default: + case 2: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.6"); + + s = ""; + switch (2) { + case 2: + default: + case 1: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.7"); + + s = ""; + switch (1) { + case 2: + default: + case 1: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.8"); + + s = ""; + switch (0) { + case 2: + default: + case 1: + s .= "x"; + break; + } + unless (s eq "x") puts("bad 7.9"); + + /* Test labeled statements in cases. */ + + i = 0; + switch (1) { + case 1: + lab1: if (i++) break; + goto lab1; + } + unless (i == 2) puts("bad 11.1"); + + i = 0; + switch (0) { + case 1: + lab2: if (i++) break; + goto lab2; + default: + lab3: if (i++) break; + goto lab3; + } + unless (i == 2) puts("bad 11.2"); + + /* + * Test that the right comparison bytecode is generated + * (string vs numeric). + */ + + i = 0; + switch ("0") { + case "00": + puts("bad 13.1"); + break; + default: + ++i; + break; + } + unless (i == 1) puts("bad 13.2"); + + /* + * Check that integer switch expressions and the case values + * are properly canonicalized. + */ + + s = ""; + for (i = 0; i <= 3; ++i) { + switch (i) { + case 0: + s .= "0"; + break; + case 0x1: + s .= "1"; + break; + case 0o2: + s .= "2"; + break; + case 000000003: + s .= "3"; + break; + default: + puts("bad 13.3"); + break; + } + } + unless (s eq "0123") puts("bad 13.4"); + + s = ""; + for (i = 100000000000000000000; i <= 100000000000000000003; ++i) { + switch (i) { + case 100000000000000000000: + s .= "0"; + break; + case 0x56bc75e2d63100001: + s .= "1"; + break; + case 0o12657072742654304000002: + s .= "2"; + break; + case 0000000000000100000000000000000003: + s .= "3"; + break; + default: + puts("bad 13.5"); + break; + } + } + unless (s eq "0123") puts("bad 13.6"); + + s = ""; + i = (poly)"0x1"; // don't use (int) since that canonicalizes + switch (i) { + case 1: + s .= "1"; + break; + default: + puts("bad 13.7"); + break; + } + unless (s eq "1") puts("bad 13.8"); + + /* Test switching on a widget type. */ + + w = "2"; + s = ""; + switch (w) { + case "1": + puts("bad 14.1"); + break; + case "2": + s .= "1"; + break; + default: + puts("bad 14.2"); + break; + } + unless (s eq "1") puts("bad 14.3"); +} +switch_1_2(); +} -output {} + +test switch-2 {test multiple-default-clause error in switch stmt} -body { +#lang L --line=1 +void switch_2() +{ + switch (0) { + default: + break; + default: + break; + } + switch (0) { + default: + break; + default: + break; + default: + break; + } + switch (0) { + default: + default: + break; + } + switch (0) { + default: + default: + } + switch (0) { + default: + case 0: + break; + default: + } +} +} -returnCodes error -match regexp -result {.*6: L Error: multiple default cases in switch statement +.*12: L Error: multiple default cases in switch statement +.*14: L Error: multiple default cases in switch statement +.*19: L Error: multiple default cases in switch statement +.*24: L Error: multiple default cases in switch statement +.*30: L Error: multiple default cases in switch statement +} + +test switch-3.0 {test case m() function call} -setup { + makeFile { + /* + * Put this in its own file to avoid polluting + * the global name space with a function m(). + */ + string m(...args) + { + string ret = "", s; + + foreach (s in args) ret .= s; + return (ret); + } + void main() + { + string s, t; + + s = ""; + foreach (t in {"","abc","def","ghi"}) { + /* Here m() is a function call not a regexp. */ + switch (t) { + case m(): s .= "1"; break; + case m("abc"): s .= "2"; break; + case m("de","f"): s .= "3"; break; + case m("g","h","i"): s .= "4"; break; + } + } + unless (s == "1234") puts("bad 1: ${s}"); + } + } switch-3.0.l +} -body { +#lang L +void switch_3_0() +{ + int ret; + string tclsh = interpreter(); + string out, err; + + ret = system({tclsh, "switch-3.0.l"}, undef, &out, &err); + unless (ret == 0) puts("bad 1.1"); + if (out) puts("bad 1.2: ${out}"); + if (err) puts("bad 1.3: ${err}"); +} +switch_3_0(); +} -output {} + +test switch-3.1 {test type errors in switch stmt} -body { +#lang L --line=1 +void switch_3_1() +{ + switch (0) { + case /regexp/: // type err + } + switch ("string") { + case 0: // type err + } +} +} -returnCodes error -match regexp -result {.*4: L Error: case type incompatible with switch expression +.*7: L Error: case type incompatible with switch expression +} + +test switch-3.2 {test other errors in switch stmt} -body { +#lang L --line=1 +void switch_3_2() +{ + switch ("string") { + case /re/g: // bad regexp modifier + case /re/ig: // bad regexp modifier + } +} +} -returnCodes error -match regexp -result {.*4: L Error: illegal regular expression modifier +.*5: L Error: illegal regular expression modifier +} + +test switch-3.3 {test duplicate case values in switch stmt} -body { +#lang L --line=1 +void switch_3_3() +{ + switch ((poly)0) { + case 0: + case 0: + case 1: + case 1: + case 1: + case "s": + case "s": + } +} +} -returnCodes error -match regexp -result {.*5: L Error: duplicate case value +.*7: L Error: duplicate case value +.*8: L Error: duplicate case value +.*10: L Error: duplicate case value +} + +test switch-4 {test illegal types in switch stmt} -body { +#lang L --line=1 +void switch_4_v() {} +class switch_4_c {} +void switch_4() +{ + int arr[]; + string hsh{int}; + switch_4_c obj; + struct { int i,j; } st; + + /* These are all errors - only int, string, and poly are legal. */ + + /* constant case expressions */ + switch (0.0) { + case 0: + } + switch(arr) { + case 0: + } + switch(hsh) { + case 0: + } + switch(obj) { + case 0: + } + switch(st) { + case 0: + } + switch(switch_4_v()) { + case 0: + } + + /* non-constant case expressions */ + switch (0.0) { + case 1+2: + } + switch(arr) { + case 1+2: + } + switch(hsh) { + case 1+2: + } + switch(obj) { + case 1+2: + } + switch(st) { + case 1+2: + } + switch(switch_4_v()) { + case 1+2: + } +} +} -returnCodes error -match regexp -result {.*13: L Error: switch expression must be int or string +.*16: L Error: switch expression must be int or string +.*19: L Error: switch expression must be int or string +.*22: L Error: switch expression must be int or string +.*25: L Error: switch expression must be int or string +.*28: L Error: switch expression must be int or string +.*33: L Error: switch expression must be int or string +.*36: L Error: switch expression must be int or string +.*39: L Error: switch expression must be int or string +.*42: L Error: switch expression must be int or string +.*45: L Error: switch expression must be int or string +.*48: L Error: switch expression must be int or string +} + +test switch-5 {test break as a label in switch stmt} -body { +#lang L --line=1 +void switch_5() +{ + /* + * Check that break: is an error. This used to be allowed + * and was the source of a very hard-to-find bug. + */ + switch (1) { + case 1: + break: + case 2: + break; + } + + /* It's illegal anywhere, not just in a switch. */ + break: +} +switch_5(); +} -returnCodes error -match regexp -result {.*9: L Error: break is not a legal label +.*15: L Error: break is not a legal label +} + +test struct-1.0 {structs} -body { +#lang L --line=1 +struct struct_1_0_point { + int x, y; + string label; +}; + +void struct_1_0() { + struct struct_1_0_point p1, p2; + + p1.x = 1; + p1.y = 2; + p1.label = "this is a label"; + puts("p1 is:"); + puts(p1); + puts(format("p1.x is %d, p1.y is %d, and p1.label is %s", p1.x, p1.y, p1.label)); + p2 = p1; + p2.label = "this is another label"; + puts("p1 is:"); + puts(p1); + puts("p2 is:"); + puts(p2); +} +#lang tcl +struct_1_0 +} -output "p1 is: +1 2 {this is a label} +p1.x is 1, p1.y is 2, and p1.label is this is a label +p1 is: +1 2 {this is a label} +p2 is: +1 2 {this is another label} +" + +test struct-1.1 {struct allocation and arrays of structs} -body { +#lang L --line=1 +struct struct_1_1_point { + int x, y; + string label; +}; + +void struct_1_1() { + int i = 0; + struct struct_1_1_point s[10]; + + while(i < 10) { + s[i].y = i; + s[i].x = 42 + i; + s[i].label = format("%d cows", 10 - i); + i++; + } + for (i=0; i<10; i++) { + puts(s[i]); + } +} +#lang tcl +struct_1_1 +} -output "42 0 {10 cows} +43 1 {9 cows} +44 2 {8 cows} +45 3 {7 cows} +46 4 {6 cows} +47 5 {5 cows} +48 6 {4 cows} +49 7 {3 cows} +50 8 {2 cows} +51 9 {1 cows} +" + +test struct-1.2 {arrays of structs containing arrays} -body { +#lang L --line=1 +struct struct_1_2_point { + int x, y; + string label; + int z[4]; +}; + +void struct_1_2() { + int i = 0; + struct struct_1_2_point s[10]; + + while(i < 10) { + s[i].y = i; + s[i].x = 42 + i; + s[i].label = format("%d cows", 10 - i); + s[i].z[i%4] = i; + i++; + } + for (i=0; i<10; i++) { + puts(s[i]); + } +} +#lang tcl +struct_1_2 +} -output "42 0 {10 cows} 0 +43 1 {9 cows} {{} 1} +44 2 {8 cows} {{} {} 2} +45 3 {7 cows} {{} {} {} 3} +46 4 {6 cows} 4 +47 5 {5 cows} {{} 5} +48 6 {4 cows} {{} {} 6} +49 7 {3 cows} {{} {} {} 7} +50 8 {2 cows} 8 +51 9 {1 cows} {{} 9} +" + +test struct-1.3 {increment and decrement on struct fields} -body { +#lang L --line=1 +struct foo { + int i; +}; + +void struct_1_3() { + struct foo v; + + v.i = 0; + for (v.i=0; v.i<5; v.i++); + puts(v); + + puts("pre:"); + puts(v.i); + ++v.i; + puts(v.i); + puts(++v.i); + --v.i; + puts(v.i); + puts(--v.i); + + puts("post:"); + puts(v.i); + v.i++; + puts(v.i); + puts(v.i++); + puts(v.i); + v.i--; + puts(v.i); + puts(v.i--); + puts(v.i); +} +#lang tcl +struct_1_3 +} -output "5\npre:\n5\n6\n7\n6\n5\npost:\n5\n6\n6\n7\n6\n6\n5\n" + +test struct-1.4 {check struct type declarations} -body { +#lang L --line=1 +struct struct_1_4_1 { + int i; + int j; +}; +struct struct_1_4_2; +struct struct_1_4_3 { + int i; + int j; + struct struct_1_4_2 st; +}; +struct struct_1_4_2 { + string s; +}; +void struct_1_4() +{ + struct struct_1_4_1 st1 = { 2, 3 }; + struct struct_1_4_2 st2 = { "s2" }; + struct struct_1_4_3 st3 = { 4, 5, { "s3" } }; + /* This redeclaration hides the global one. */ + struct struct_1_4_2 { int k,l; } st4 = { 6, 7 }; + + unless ((st1.i == 2) && (st1.j == 3)) puts("bad 1"); + unless (st2.s eq "s2") puts("bad 2"); + unless ((st3.i == 4) && (st3.j == 5) && (st3.st.s eq "s3")) { + puts("bad 3"); + } + unless ((st4.k == 6) && (st4.l == 7)) puts("bad 4"); + + if (1) { + /* This redeclaration hides the global one in this scope. */ + struct struct_1_4_1 { string t,u; } st5 = { "t", "u" }; + unless ((st5.t eq "t") && (st5.u eq "u")) puts("bad 5"); + } + if (1) { + /* This should reference the global one. */ + struct struct_1_4_1 st6 = { 8, 9 }; + unless ((st6.i == 8) && (st6.j == 9)) puts("bad 7"); + } +} +#lang tcl +struct_1_4 +} -output {} + +test struct-1.5 {check multiple struct type declarations} -body { +#lang L --line=1 +struct struct_1_5_1 { int i,j; }; +struct struct_1_5_1 { int i,j; }; +struct struct_1_5_2 { int i,j; }; +void struct_1_5_1() +{ + struct struct_1_5_2 { string s; } st1; + struct struct_1_5_2 { string s; } st2; +} +} -returnCodes error -match regexp -result {.*2: L Error: multiple declaration of struct struct_1_5_1.*7: L Error: multiple declaration of struct struct_1_5_2 +} + +test struct-1.6 {check struct member errors} -body { +#lang L --line=1 +void struct_1_6() +{ + struct struct_1_6 { string s; } st; + st.x = 1; // err -- x is not a member +} +} -returnCodes error -match regexp -result {.*4: L Error: struct field x not found +} + +test hash-1.0 {basic hashtable support} -body { +#lang L --line=1 +void hash_1_0() { + hash foo; + foo{"key"} = "value"; + puts(foo{"key"}); +} +#lang tcl +hash_1_0 +} -output "value\n" + +test hash-1.1 {array of hashtables} -body { +#lang L --line=1 +void hash_1_1() { + hash foo[10]; + foo[5]{"key"} = "value"; + foo[4]{"key"} = ""; + puts(foo[5]{"key"}); + puts(foo[4]{"key"}); +} +#lang tcl +hash_1_1 +} -output "value\n\n" + +test hash-1.2 {increment and decrement on hash elements} -body { +#lang L --line=1 -poly +void hash_1_2() { + hash foo; + + foo{"three"} = 0; + for (foo{"three"}=0; foo{"three"}<5; foo{"three"}++); + puts(foo); + + puts("pre:"); + puts(foo{"three"}); + ++foo{"three"}; + puts(foo{"three"}); + puts(++foo{"three"}); + --foo{"three"}; + puts(foo{"three"}); + puts(--foo{"three"}); + + puts("post:"); + puts(foo{"three"}); + foo{"three"}++; + puts(foo{"three"}); + puts(foo{"three"}++); + puts(foo{"three"}); + foo{"three"}--; + puts(foo{"three"}); + puts(foo{"three"}--); + puts(foo{"three"}); + puts(foo); +} +#lang tcl +hash_1_2 +} -output "three 5\npre:\n5\n6\n7\n6\n5\npost:\n5\n6\n6\n7\n6\n6\n5\nthree 5\n" + +# test hash-1.3 removed + +test hash-1.4 {basic hash element types} -body { +#lang L --line=1 +struct sh14 { + int x; + int y; +}; +void +hash_1_4() +{ + int ki, vi; + string ks, vs; + float kf, vf; + poly kp, vp; + struct sh14 vst; + int ihi{int}; + int ihs{string}; + int ihf{float}; + int ihp{poly}; + string shi{int}; + string shs{string}; + string shf{float}; + string shp{poly}; + float fhi{int}; + float fhs{string}; + float fhf{float}; + float fhp{poly}; + poly phi{int}; + poly phs{string}; + poly phf{float}; + poly php{poly}; + struct sh14 sthi{int}; + struct sh14 sths{string}; + struct sh14 sthf{float}; + struct sh14 sthp{poly}; + + printf("start\n"); + + ihi{0} = 100; + ihi{1} = 101; + ihi{2} = 102; + foreach (ki=>vi in ihi) { + printf("ihi has %d=>%d\n", ki, vi); + } + + ihs{"zero"} = 100; + ihs{"one"} = 101; + ihs{"two"} = 102; + foreach (ks=>vi in ihs) { + printf("ihs has %s=>%d\n", ks, vi); + } + + ihf{1.1} = 100; + ihf{2.2} = 101; + ihf{3.3} = 102; + foreach (kf=>vi in ihf) { + printf("ihf has %3.1f=>%d\n", kf, vi); + } + + ihp{0} = 100; + ihp{"two"} = 101; + ihp{3.3} = 102; + foreach (kp=>vi in ihp) { + printf("ihp has %s=>%d\n", kp, vi); + } + + shi{0} = "zero"; + shi{1} = "one"; + shi{2} = "two"; + foreach (ki=>vs in shi) { + printf("shi has %d=>%s\n", ki, vs); + } + + shs{"zero"} = "zero0"; + shs{"one"} = "one1"; + shs{"two"} = "two2"; + foreach (ks=>vs in shs) { + printf("shs has %s=>%s\n", ks, vs); + } + + shf{1.1} = "one.one"; + shf{2.2} = "two.two"; + shf{3.3} = "three.three"; + foreach (kf=>vs in shf) { + printf("shf has %3.1f=>%s\n", kf, vs); + } + + shp{0} = "zero"; + shp{1.1} = "one.one"; + shp{"two"} = "two2"; + foreach (kp=>vs in shp) { + printf("shp has %s=>%s\n", kp, vs); + } + + fhi{0} = 1.1; + fhi{1} = 2.2; + fhi{2} = 3.3; + foreach (ki=>vf in fhi) { + printf("fhi has %d=>%3.1f\n", ki, vf); + } + + fhs{"zero"} = 1.1; + fhs{"one"} = 2.2; + fhs{"two"} = 3.3; + foreach (ks=>vf in fhs) { + printf("fhs has %s=>%3.1f\n", ks, vf); + } + + fhf{1.1} = 11.1; + fhf{2.2} = 22.2; + fhf{3.3} = 33.3; + foreach (kf=>vf in fhf) { + printf("fhf has %3.1f=>%3.1f\n", kf, vf); + } + + fhp{0} = 1.1; + fhp{1.1} = 2.2; + fhp{"two"} = 3.3; + foreach (kp=>vf in fhp) { + printf("fhp has %s=>%3.1f\n", kp, vf); + } + + phi{0} = 1; + phi{1} = "two"; + phi{2} = 3.3; + foreach (ki=>vp in phi) { + printf("phi has %d=>%s\n", ki, vp); + } + + phs{"zero"} = 1; + phs{"one"} = "two"; + phs{"two"} = 3.3; + foreach (ks=>vp in phs) { + printf("phs has %s=>%s\n", ks, vp); + } + + phf{1.1} = 1; + phf{2.2} = "two"; + phf{3.3} = 33.33; + foreach (kf=>vp in phf) { + printf("phf has %3.1f=>%s\n", kf, vp); + } + + php{"one"} = 1; + php{1.1} = "two"; + php{2} = 3.3; + foreach (kp=>vp in php) { + printf("php has %s=>%s\n", kp, vp); + } + + sthi{0}.x = 100; + sthi{0}.y = 101; + sthi{1}.x = 200; + sthi{1}.y = 201; + sthi{2}.x = 300; + sthi{2}.y = 301; + foreach (ki=>vst in sthi) { + printf("sthi has %d=>(%d,%d)\n", ki, vst.x, vst.y); + } + + sths{"zero"}.x = 100; + sths{"zero"}.y = 101; + sths{"one"}.x = 200; + sths{"one"}.y = 201; + sths{"two"}.x = 300; + sths{"two"}.y = 301; + foreach (ks=>vst in sths) { + printf("sths has %s=>(%d,%d)\n", ks, vst.x, vst.y); + } + + sthf{1.1}.x = 100; + sthf{1.1}.y = 101; + sthf{2.2}.x = 200; + sthf{2.2}.y = 201; + sthf{3.3}.x = 300; + sthf{3.3}.y = 301; + foreach (kf=>vst in sthf) { + printf("sthf has %3.1f=>(%d,%d)\n", kf, vst.x, vst.y); + } + + sthp{0}.x = 100; + sthp{0}.y = 101; + sthp{1.1}.x = 200; + sthp{1.1}.y = 201; + sthp{"two"}.x = 300; + sthp{"two"}.y = 301; + foreach (kp=>vst in sthp) { + printf("sthp has %s=>(%d,%d)\n", kp, vst.x, vst.y); + } + + printf("end\n"); +} +#lang tcl +hash_1_4 +} -output "start +ihi has 0=>100 +ihi has 1=>101 +ihi has 2=>102 +ihs has zero=>100 +ihs has one=>101 +ihs has two=>102 +ihf has 1.1=>100 +ihf has 2.2=>101 +ihf has 3.3=>102 +ihp has 0=>100 +ihp has two=>101 +ihp has 3.3=>102 +shi has 0=>zero +shi has 1=>one +shi has 2=>two +shs has zero=>zero0 +shs has one=>one1 +shs has two=>two2 +shf has 1.1=>one.one +shf has 2.2=>two.two +shf has 3.3=>three.three +shp has 0=>zero +shp has 1.1=>one.one +shp has two=>two2 +fhi has 0=>1.1 +fhi has 1=>2.2 +fhi has 2=>3.3 +fhs has zero=>1.1 +fhs has one=>2.2 +fhs has two=>3.3 +fhf has 1.1=>11.1 +fhf has 2.2=>22.2 +fhf has 3.3=>33.3 +fhp has 0=>1.1 +fhp has 1.1=>2.2 +fhp has two=>3.3 +phi has 0=>1 +phi has 1=>two +phi has 2=>3.3 +phs has zero=>1 +phs has one=>two +phs has two=>3.3 +phf has 1.1=>1 +phf has 2.2=>two +phf has 3.3=>33.33 +php has one=>1 +php has 1.1=>two +php has 2=>3.3 +sthi has 0=>(100,101) +sthi has 1=>(200,201) +sthi has 2=>(300,301) +sths has zero=>(100,101) +sths has one=>(200,201) +sths has two=>(300,301) +sthf has 1.1=>(100,101) +sthf has 2.2=>(200,201) +sthf has 3.3=>(300,301) +sthp has 0=>(100,101) +sthp has 1.1=>(200,201) +sthp has two=>(300,301) +end +" + +test hash-1.5 {hashes of hashes and arrays} -body { +#lang L --line=1 +void +hash_1_5() +{ + int k1, k2; + string vs; + string hai[3]{int}; + string hia{int}[3]; + string hii{int}{int}; + string hi{int}; + + printf("start\n"); + + // Array of hashes. + hai[0]{1} = "01"; + hai[0]{6} = "06"; + hai[0]{5} = "05"; + hai[1]{2} = "12"; + hai[1]{3} = "13"; + hai[1]{0} = "10"; + hai[2]{0} = "20"; + hai[2]{1} = "21"; + hai[2]{2} = "22"; + foreach (hi in hai) { + foreach (k1 in sort(keys(hi))) { + printf("hai has %d=>%s\n", k1, hi{k1}); + } + } + + // Hash of arrays. + hia{1}[0] = "10"; + hia{1}[1] = "11"; + hia{1}[2] = "12"; + hia{0}[0] = "00"; + hia{0}[1] = "01"; + hia{0}[2] = "02"; + hia{2}[0] = "20"; + hia{2}[1] = "21"; + hia{2}[2] = "22"; + foreach (k1 in sort(keys(hia))) { + foreach (vs in hia{k1}) { + printf("hia{%d} has %s\n", k1, vs); + } + } + + // Hash of hashes. + hii{0}{2} = "02"; + hii{1}{0} = "10"; + hii{0}{0} = "00"; + hii{2}{1} = "21"; + hii{1}{2} = "12"; + hii{1}{1} = "11"; + hii{0}{1} = "01"; + hii{2}{0} = "20"; + hii{2}{2} = "22"; + foreach (k1 in sort(keys(hii))) { + foreach (k2 in sort(keys(hii{k1}))) { + printf("hii{%d}{%d} has %s\n", k1, k2, hii{k1}{k2}); + } + } + + printf("end\n"); +} +#lang tcl +hash_1_5 +} -output "start +hai has 1=>01 +hai has 5=>05 +hai has 6=>06 +hai has 0=>10 +hai has 2=>12 +hai has 3=>13 +hai has 0=>20 +hai has 1=>21 +hai has 2=>22 +hia{0} has 00 +hia{0} has 01 +hia{0} has 02 +hia{1} has 10 +hia{1} has 11 +hia{1} has 12 +hia{2} has 20 +hia{2} has 21 +hia{2} has 22 +hii{0}{0} has 00 +hii{0}{1} has 01 +hii{0}{2} has 02 +hii{1}{0} has 10 +hii{1}{1} has 11 +hii{1}{2} has 12 +hii{2}{0} has 20 +hii{2}{1} has 21 +hii{2}{2} has 22 +end +" + +test deep-1.1 {deep dive 1} -body { +#lang L --line=1 +struct xy { + string x; + string y; +}; +struct sd11 { + string a; + string b; + struct xy h{int}; +}; + +void +deep_1_1() +{ + int k1, k2; + struct sd11 s; + struct xy xy; + struct sd11 h{int}; + + printf("start\n"); + + /* + * Test a hash that has a struct that has another hash. + */ + + h{0}.a = "h{0}.a"; + h{0}.b = "h{0}.b"; + h{0}.h{0}.x = "h{0}.h{0}.x"; + h{0}.h{0}.y = "h{0}.h{0}.y"; + h{1}.a = "h{1}.a"; + h{1}.b = "h{1}.b"; + h{1}.h{0}.x = "h{1}.h{0}.x"; + h{1}.h{0}.y = "h{1}.h{0}.y"; + h{1}.h{2}.x = "h{1}.h{2}.x"; + h{1}.h{2}.y = "h{1}.h{2}.y"; + + foreach (k1=>s in h) { + printf("h{%d}.a = %s\n", k1, s.a); + printf("h{%d}.b = %s\n", k1, s.b); + foreach (k2=>xy in s.h) { + printf("h{%d}.h{%d}.x = %s\n", k1, k2, xy.x); + printf("h{%d}.h{%d}.y = %s\n", k1, k2, xy.y); + } + } + + printf("end\n"); +} +#lang tcl +deep_1_1 +} -output "start +h{0}.a = h{0}.a +h{0}.b = h{0}.b +h{0}.h{0}.x = h{0}.h{0}.x +h{0}.h{0}.y = h{0}.h{0}.y +h{1}.a = h{1}.a +h{1}.b = h{1}.b +h{1}.h{0}.x = h{1}.h{0}.x +h{1}.h{0}.y = h{1}.h{0}.y +h{1}.h{2}.x = h{1}.h{2}.x +h{1}.h{2}.y = h{1}.h{2}.y +end +" + +test deep-1.2 {deep dive with consecutive hash indices} -body { +#lang L --line=1 +void +deep_1_2() +{ + int k1, k2, k3, k4; + string v; + string h{int}; + string hh{int}{int}; + string hhh{int}{int}{int}; + string hhhh{int}{int}{int}{int}; + + printf("start\n"); + + /* + * Test various cases with consecutive hash indices. + */ + + hh{0}{0} = "00"; + hh{0}{1} = "01"; + hh{1}{0} = "10"; + foreach (k1=>h in hh) { + foreach (k2=>v in h) { + unless (hh{k1}{k2} eq h{k2}) { + printf("bad 1\n"); + } + printf("hh{%d}{%d} has %s\n", k1, k2, hh{k1}{k2}); + } + } + + hhh{0}{0}{0} = "000"; + hhh{0}{0}{1} = "001"; + hhh{0}{1}{0} = "010"; + hhh{1}{0}{0} = "100"; + foreach (k1=>hh in hhh) { + foreach (k2=>h in hh) { + foreach (k3=>v in h) { + unless (hhh{k1}{k2}{k3} eq hh{k2}{k3}) { + printf("bad 2\n"); + } + unless (hh{k2}{k3} eq h{k3}) { + printf("bad 3\n"); + } + printf("hhh{%d}{%d}{%d} has %s\n", k1, k2, k3, + hhh{k1}{k2}{k3}); + } + } + } + + hhhh{0}{0}{0}{0} = "0000"; + hhhh{0}{0}{0}{1} = "0001"; + hhhh{0}{0}{1}{0} = "0010"; + hhhh{0}{1}{0}{0} = "0100"; + hhhh{1}{0}{0}{0} = "1000"; + foreach (k1=>hhh in hhhh) { + foreach (k2=>hh in hhh) { + foreach (k3=>h in hh) { + foreach (k4=>v in h) { + unless (hhhh{k1}{k2}{k3}{k4} eq + hhh{k2}{k3}{k4}) { + printf("bad 4\n"); + } + unless (hhh{k2}{k3}{k4} eq hh{k3}{k4}) { + printf("bad 5\n"); + } + unless (hh{k3}{k4} eq h{k4}) { + printf("bad 6\n"); + } + printf("hhhh{%d}{%d}{%d}{%d} has %s\n", + k1, k2, k3, k4, + hhhh{k1}{k2}{k3}{k4}); + } + } + } + } + + printf("end\n"); +} +#lang tcl +deep_1_2 +} -output "start +hh{0}{0} has 00 +hh{0}{1} has 01 +hh{1}{0} has 10 +hhh{0}{0}{0} has 000 +hhh{0}{0}{1} has 001 +hhh{0}{1}{0} has 010 +hhh{1}{0}{0} has 100 +hhhh{0}{0}{0}{0} has 0000 +hhhh{0}{0}{0}{1} has 0001 +hhhh{0}{0}{1}{0} has 0010 +hhhh{0}{1}{0}{0} has 0100 +hhhh{1}{0}{0}{0} has 1000 +end +" + +test deep-1.3 {deep dive with consecutive array indices} -body { +#lang L --line=1 +void +deep_1_3() +{ + string v; + string a[3]; + string aa[2][2]; + string aaa[2][2][2]; + string aaaa[2][2][2][2]; + + printf("start\n"); + + /* + * Test various cases with consecutive array indices. + */ + + a[0] = "0"; + a[1] = "1"; + a[2] = "2"; + foreach (v in a) { + printf("a has '%s'\n", v); + } + + aa[0][0] = "00"; + aa[0][1] = "01"; + aa[0][2] = "02"; + aa[1][0] = "10"; + foreach (a in aa) { + foreach (v in a) { + printf("aa has '%s'\n", v); + } + } + + aaa[0][0][0] = "000"; + aaa[0][0][1] = "001"; + aaa[0][1][0] = "010"; + aaa[0][1][1] = "011"; + aaa[1][0][0] = "100"; + foreach (aa in aaa) { + foreach (a in aa) { + foreach (v in a) { + printf("aaa has '%s'\n", v); + } + } + } + + aaaa[0][0][0][0] = "0000"; + aaaa[0][0][0][1] = "0001"; + aaaa[0][0][1][0] = "0010"; + aaaa[0][1][0][0] = "0100"; + aaaa[1][0][0][0] = "1000"; + foreach (aaa in aaaa) { + foreach (aa in aaa) { + foreach (a in aa) { + foreach (v in a) { + printf("aaaa has '%s'\n", v); + } + } + } + } + + printf("end\n"); +} +#lang tcl +deep_1_3 +} -output "start +a has '0' +a has '1' +a has '2' +aa has '00' +aa has '01' +aa has '02' +aa has '10' +aaa has '000' +aaa has '001' +aaa has '010' +aaa has '011' +aaa has '100' +aaaa has '0000' +aaaa has '0001' +aaaa has '0010' +aaaa has '0100' +aaaa has '1000' +end +" + +test deep-1.4 {deep dive with alternating hash and array indices} -body { +#lang L --line=1 +void +deep_1_4() +{ + /* + * Note that, because of the array auto-extend semantics, if + * you write to a[i] but there are values before index i not + * yet written, those get automatically set to an undefined + * value, which the foreach's will iterate through. When used + * as a string, the undefined value shows up as "". (Tcl + * doesn't let you use it as an integer, which is why the + * hashes are string hashes in these tests.) + */ + + int i, j, ki, k1, k2; + string vs; + string a[3]; + string aa[3][3]; + string h{int}; + string hh{int}{int}; + string ah[3]{int}; + string ha{int}[3]; + string aah[3][3]{int}; + string aha[3]{int}[3]; + string ahh[3]{int}{int}; + string haa{int}[3][3]; + string hah{int}[3]{int}; + string hha{int}{int}[3]; + + printf("start\n"); + + ah[0]{0} = "ah[0]{0}"; + ah[2]{0} = "ah[2]{0}"; + ah[2]{1} = "ah[2]{1}"; + i = 0; + foreach (h in ah) { + foreach (ki=>vs in h) { + unless (ah[i]{ki} eq vs) printf("bad 1\n"); + printf("ah[%d]{%d} = '%s'\n", i, ki, vs); + } + ++i; + } + + ha{0}[0] = "ha{0}[0]"; + ha{0}[1] = "ha{0}[1]"; + ha{1}[1] = "ha{1}[1]"; + foreach (ki=>a in ha) { + i = 0; + foreach (vs in a) { + unless (ha{ki}[i] eq vs) printf("bad 2\n"); + printf("ha{%d}[%d] = '%s'\n", ki, i, vs); + ++i; + } + } + + aah[0][0]{0} = "aah[0][0]{0}"; + aah[0][1]{1} = "aah[0][1]{1}"; + aah[1][0]{2} = "aah[1][0]{2}"; + aah[1][0]{3} = "aah[1][0]{3}"; + i = 0; + foreach (ah in aah) { + j = 0; + foreach (h in ah) { + foreach (ki=>vs in h) { + unless (aah[i][j]{ki} eq vs) printf("bad 3\n"); + unless (ah[j]{ki} eq vs) printf("bad 4\n"); + unless (h{ki} eq vs) printf("bad 5\n"); + printf("aah[%d][%d]{%d} = '%s'\n", i, j, ki, + aah[i][j]{ki}); + } + ++j; + } + ++i; + } + + aha[0]{0}[0] = "aha[0]{0}[0]"; + aha[0]{1}[1] = "aha[0]{1}[1]"; + aha[1]{2}[0] = "aha[1]{2}[0]"; + aha[0]{3}[2] = "aha[0]{3}[2]"; + i = 0; + foreach (ha in aha) { + foreach (ki=>a in ha) { + j = 0; + foreach (vs in a) { + unless (aha[i]{ki}[j] eq vs) printf("bad 6\n"); + unless (ha{ki}[j] eq vs) printf("bad 7\n"); + unless (a[j] eq vs) printf("bad 7\n"); + printf("aha[%d]{%d}[%d] = '%s'\n", i, ki, j, + aha[i]{ki}[j]); + ++j; + } + } + ++i; + } + + ahh[0]{0}{1} = "ahh[0]{0}{1}"; + ahh[0]{2}{3} = "ahh[0]{2}{3}"; + ahh[1]{4}{5} = "ahh[1]{4}{5}"; + ahh[2]{6}{7} = "ahh[2]{6}{7}"; + i = 0; + foreach (hh in ahh) { + foreach (k1=>h in hh) { + foreach (k2=>vs in h) { + unless (ahh[i]{k1}{k2} eq vs) printf("bad 7\n"); + unless (hh{k1}{k2} eq vs) printf("bad 8\n"); + unless (h{k2} eq vs) printf("bad 9\n"); + printf("ahh[%d]{%d}{%d} = '%s'\n", i, k1, k2, + ahh[i]{k1}{k2}); + } + } + ++i; + } + + haa{0}[0][0] = "haa{0}[0][0]"; + haa{0}[1][0] = "haa{0}[1][0]"; + haa{1}[0][0] = "haa{1}[0][0]"; + haa{2}[0][1] = "haa{2}[0][1]"; + foreach (ki=>aa in haa) { + i = 0; + foreach (a in aa) { + j = 0; + foreach (vs in a) { + unless (haa{ki}[i][j] eq vs) printf("bad 10\n"); + unless (aa[i][j] eq vs) printf("bad 11\n"); + unless (a[j] eq vs) printf("bad 12\n"); + printf("haa{%d}[%d][%d] = '%s'\n", ki, i, j, + haa{ki}[i][j]); + ++j; + } + ++i; + } + } + + hha{0}{1}[0] = "hha{0}{1}[0]"; + hha{2}{3}[0] = "hha{2}{3}[0]"; + hha{4}{5}[1] = "hha{4}{5}[1]"; + hha{6}{7}[2] = "hha{6}{7}[2]"; + foreach (k1=>ha in hha) { + foreach (k2=>a in ha) { + i = 0; + foreach (vs in a) { + unless (hha{k1}{k2}[i] eq vs) printf("bad13\n"); + unless (ha{k2}[i] eq vs) printf("bad 14n"); + unless (a[i] eq vs) printf("bad 15\n"); + printf("hha{%d}{%d}[%d] = '%s'\n", k1, k2, i, + hha{k1}{k2}[i]); + ++i; + } + } + } + + hah{0}[0]{0} = "hah{0}[0]{0}"; + hah{1}[0]{2} = "hah{1}[0]{2}"; + hah{3}[1]{4} = "hah{3}[1]{4}"; + hah{5}[2]{6} = "hah{5}[2]{6}"; + foreach (k1=>ah in hah) { + i = 0; + foreach (h in ah) { + foreach (k2=>vs in h) { + unless (hah{k1}[i]{k2} eq vs) printf("bad16\n"); + unless (ah[i]{k2} eq vs) printf("bad 17\n"); + unless (h{k2} eq vs) printf("bad 18\n"); + printf("hah{%d}[%d]{%d} = '%s'\n", k1, i, k2, + hah{k1}[i]{k2}); + } + ++i; + } + } + + printf("end\n"); +} + +#lang tcl +deep_1_4 +} -output {start +ah[0]{0} = 'ah[0]{0}' +ah[2]{0} = 'ah[2]{0}' +ah[2]{1} = 'ah[2]{1}' +ha{0}[0] = 'ha{0}[0]' +ha{0}[1] = 'ha{0}[1]' +ha{1}[0] = '' +ha{1}[1] = 'ha{1}[1]' +aah[0][0]{0} = 'aah[0][0]{0}' +aah[0][1]{1} = 'aah[0][1]{1}' +aah[1][0]{2} = 'aah[1][0]{2}' +aah[1][0]{3} = 'aah[1][0]{3}' +aha[0]{0}[0] = 'aha[0]{0}[0]' +aha[0]{1}[0] = '' +aha[0]{1}[1] = 'aha[0]{1}[1]' +aha[0]{3}[0] = '' +aha[0]{3}[1] = '' +aha[0]{3}[2] = 'aha[0]{3}[2]' +aha[1]{2}[0] = 'aha[1]{2}[0]' +ahh[0]{0}{1} = 'ahh[0]{0}{1}' +ahh[0]{2}{3} = 'ahh[0]{2}{3}' +ahh[1]{4}{5} = 'ahh[1]{4}{5}' +ahh[2]{6}{7} = 'ahh[2]{6}{7}' +haa{0}[0][0] = 'haa{0}[0][0]' +haa{0}[1][0] = 'haa{0}[1][0]' +haa{1}[0][0] = 'haa{1}[0][0]' +haa{2}[0][0] = '' +haa{2}[0][1] = 'haa{2}[0][1]' +hha{0}{1}[0] = 'hha{0}{1}[0]' +hha{2}{3}[0] = 'hha{2}{3}[0]' +hha{4}{5}[0] = '' +hha{4}{5}[1] = 'hha{4}{5}[1]' +hha{6}{7}[0] = '' +hha{6}{7}[1] = '' +hha{6}{7}[2] = 'hha{6}{7}[2]' +hah{0}[0]{0} = 'hah{0}[0]{0}' +hah{1}[0]{2} = 'hah{1}[0]{2}' +hah{3}[1]{4} = 'hah{3}[1]{4}' +hah{5}[2]{6} = 'hah{5}[2]{6}' +end +} + +test deep-2.1 {deep dive array auto-extend} -body { +#lang L --line=1 +void +deep_2_1() +{ + int i, j; + int a1[]; + int a2[]; + int aa1[][]; + int aa2[][]; + + /* + * Test that arrays auto-extend properly. + */ + + a1[0] = 0; + a1[1] = 1; + a1[2] = 2; + unless ((a1[0] == 0) && (a1[1] == 1) && (a1[2] == 2)) { + puts("a1 bad 1"); + } + if (defined(a1[3])) puts("a1 bad 2"); + + a2[1] = 1; + a2[3] = 3; + a2[6] = 6; + a2[10] = 10; + unless ((a2[1] == 1) && (a2[3] == 3) && (a2[6] == 6) && (a2[10] == 10)) { + puts("a2 bad 1"); + } + if (defined(a2[0])) puts("a2 bad 2"); + if (defined(a2[2])) puts("a2 bad 3"); + if (defined(a2[4])) puts("a2 bad 4"); + if (defined(a2[5])) puts("a2 bad 5"); + if (defined(a2[7])) puts("a2 bad 6"); + if (defined(a2[8])) puts("a2 bad 7"); + if (defined(a2[9])) puts("a2 bad 8"); + if (defined(a2[11])) puts("a2 bad 9"); + + /* Now check that the pad elements can be written and used. */ + a2[0] = 0; + a2[2] = 2; + a2[4] = 4; + a2[5] = 5; + unless ((a2[0] == 0) && (a2[2] == 2)) puts("a2 bad 10"); + unless ((a2[4] == 4) && (a2[5] == 5)) puts("a2 bad 11"); + if (defined(a2[7])) puts("a2 bad 12"); + if (defined(a2[8])) puts("a2 bad 13"); + if (defined(a2[9])) puts("a2 bad 14"); + if (defined(a2[11])) puts("a2 bad 15"); + + aa1[0][0] = 100; + aa1[0][1] = 101; + aa1[0][2] = 102; + aa1[1][0] = 110; + aa1[1][1] = 111; + aa1[2][0] = 120; + unless ((aa1[0][0] == 100) && (aa1[0][1] == 101) && (aa1[0][2] == 102) && + (aa1[1][0] == 110) && (aa1[1][1] == 111) && (aa1[2][0] == 120)) { + puts("aa1 bad 1"); + } + if (defined(aa1[0][3])) puts("aa1 bad 2"); + if (defined(aa1[1][3])) puts("aa1 bad 3"); + if (defined(aa1[2][1])) puts("aa1 bad 4"); + + aa2[1][1] = 111; + aa2[3][3] = 133; + aa2[6][6] = 166; + aa2[10][10] = 1010; + unless ((aa2[1][1] == 111) && (aa2[3][3] == 133) && (aa2[6][6] == 166) && + (aa2[10][10] == 1010)) { + puts("aa2 bad 2"); + } + for (i = 0; i <= 10; ++i) { + for (j = 0; j <= i; ++j) { + if ((i == 1) && (j == 1)) continue; + if ((i == 3) && (j == 3)) continue; + if ((i == 6) && (j == 6)) continue; + if ((i == 10) && (j == 10)) continue; + if (defined(aa2[i][j])) printf("aa2[%d][%d] defined\n", + i, j); + } + } +} +#lang tcl +deep_2_1 +} -output "" + +test deep-2.2 {check that a negative array index is an error} -body { +#lang L --line=1 +void +deep_2_2() +{ + int a[3]; + a[-1] = 0; +} +#lang tcl +deep_2_2 +} -returnCodes error -match regexp -result {cannot write to negative array index} + +test deep-2.3 {check deep-dive element create/read} -body { +#lang L --line=1 +void +deep_2_3() +{ + /* + * This checks that an op= works on an undefined deep-dive + * element. A string substitute is the only one we can test; + * because undef isn't a valid integer, ++a[0] would cause a + * run-time error that you can't use "" in a + operation. + */ + + string a[]; + string h{string}; + + h{"undefined"} =~ s//ShouldWork/; + unless (h{"undefined"} eq "ShouldWork") puts("bad 1"); + + a[0] =~ s//ShouldWork/; + unless (a[0] eq "ShouldWork") puts("bad 2"); +} +#lang tcl +deep_2_3 +} -output {} + +test deep-3.1 {check reading an undefined array index} -body { +#lang L --line=1 +void +deep_3_1() +{ + int i; + int a[] = {}; + + /* + * Reading an array element with an undefined index should + * cause a run-time error. + */ + a[i]; +} +deep_3_1(); +} -returnCodes error -match glob -result {cannot read from undefined array index} + +test deep-3.2 {check writing an undefined array index} -body { +#lang L --line=1 +void +deep_3_2() +{ + int i; + int a[] = {}; + + /* + * Writing an array element with an undefined index should + * cause a run-time error. + */ + a[i] = 0; // run-time error +} +deep_3_2(); +} -returnCodes error -match glob -result {cannot write to undefined array index} + +test deep-3.2.2 {check reading an undefined hash index} -body { +#lang L +void +deep_3_2_2() +{ + string idx; + string h{string} = {}; + + /* + * Reading a hash element with an undefined index should + * cause a run-time error. + */ + h{idx}; +} +deep_3_2_2(); +} -returnCodes error -match glob -result {cannot read from undefined hash index} + +test deep-3.2.2.1 {check back-door reading undefined hash index} -setup { + makeFile { + string s; + string deep_3_2_2h{string}; + + deep_3_2_2h{s}; + puts("worked"); + } deep-3.2.2.1.l +} -body { +#lang L --line=1 +void deep_3_2_2_1() +{ + /* + * Test the back door BK_L_ALLOW_UNDEF_HASH_INDEX=YES which + * allows using an undef hash index. Do this in its own tclsh + * instance since the env variable is read only at the first + * undef hash index. + */ + int ret; + string err, out, tclsh = interpreter(); + + putenv("BK_L_ALLOW_UNDEF_HASH_INDEX=YES"); + ret = system({tclsh, "deep-3.2.2.1.l"}, undef, &out, &err); + if (ret) puts("bad 1"); + unless (out == "worked\n") puts("bad 2"); + putenv("BK_L_ALLOW_UNDEF_HASH_INDEX="); +} +deep_3_2_2_1(); +} -output {} + +test deep-3.2.3 {check writing an undefined hash index} -body { +#lang L +void +deep_3_2_3() +{ + string idx; + string h{string} = {}; + + /* + * Writing a hash element with an undefined index should + * cause a run-time error. + */ + h{idx} = "bad"; +} +deep_3_2_3(); +} -returnCodes error -match glob -result {cannot write to undefined hash index} + +test deep-3.2.3.1 {check back-door writing undefined array index} -setup { + makeFile { + string s; + string deep_3_2_3h{string}; + + deep_3_2_3h{s} = "should be ok now"; + puts("worked"); + } deep-3.2.3.1.l +} -body { +#lang L --line=1 +void deep_3_2_3_1() +{ + /* + * Test the back door BK_L_ALLOW_UNDEF_HASH_INDEX=YES which + * allows using an undef hash index. Do this in its own tclsh + * instance since the env variable is read only at the first + * undef hash index. + */ + int ret; + string err, out, tclsh = interpreter(); + + putenv("BK_L_ALLOW_UNDEF_HASH_INDEX=YES"); + ret = system({tclsh, "deep-3.2.3.1.l"}, undef, &out, &err); + if (ret) puts("bad 1"); + unless (out == "worked\n") puts("bad 2"); + putenv("BK_L_ALLOW_UNDEF_HASH_INDEX="); +} +deep_3_2_3_1(); +} -output {} + +test deep-3.3 {check reading an undefined string index} -body { +#lang L --line=1 +void +deep_3_3() +{ + int i; + string s = ""; + + /* + * Reading a string element with an undefined index should + * cause a run-time error. + */ + s[i]; +} +deep_3_3(); +} -returnCodes error -match glob -result {cannot read from undefined string index} + +test deep-3.3.1 {check writing an undefined string index} -body { +#lang L +void +deep_3_3_1() +{ + int i; + string s; + + /* + * Writing a string element with an undefined index should + * cause a run-time error. + */ + s[i] = "bad"; +} +deep_3_3_1(); +} -returnCodes error -match glob -result {cannot write to undefined string index} + +test deep-3.4 {check writing an undefined array index} -body { +#lang L --line=1 +void +deep_3_4() +{ + int i; + string s = ""; + + /* + * Writing a string element with an undefined index is + * illegal. + */ + + s[i] = "bad"; // run-time error +} +deep_3_4(); +} -returnCodes error -match regexp -result {cannot write to undefined string index} + +test deep-3.5 {check compile-time undefined array and hash indices} -body { +#lang L --line=1 +void deep_3_5() +{ + int ia[]; + string sa[], sh{string}; + + /* These should all be compile-time errors. */ + + ia[undef]; + sa[undef]; + ia[undef] = 1; + sa[undef] = "bad"; + sh{undef}; + sh{undef} = "bad"; +} +deep_3_5(); +} -returnCodes error -match regexp -result {.*8: L Error: cannot use undef as an array/string index +.*9: L Error: cannot use undef as an array/string index +.*10: L Error: cannot use undef as an array/string index +.*11: L Error: cannot use undef as an array/string index +.*12: L Error: cannot use undef as a hash index +.*13: L Error: cannot use undef as a hash index +} + +test deep-4.0 {check hash and array indexing of a poly} -body { +#lang L --line=1 +void deep_4_0() +{ + poly p; + + p = {}; + p{"key1"} = "val"; + p{"key2"} = 123; + unless(p{"key1"} eq "val") puts("bad 1.1"); + unless(p{"key2"} == 123) puts("bad 1.2"); + + p = {}; + p[0] = "val"; + p[1] = 123; + unless(p[0] eq "val") puts("bad 2.1"); + unless(p[1] == 123) puts("bad 2.2"); +} +deep_4_0(); +} -output {} + +test deep-5.1 {check deep-dive object sharing} -body { +#lang L --line=1 +typedef struct block { + string line; +} block; + +void deep_5_1() +{ + block b, v1, v2; + string h{string}, h2{string}, h3{string}; + string a1[][], a2[][]; + + /* + * Having the rhs be a string concat creates an object with a + * refCount of 1. + */ + b.line = "LINE1" . "1"; + v1 = b; + + /* + * Now change b.line. v1's copy should not change. + */ + b.line = "LINE2"; + v2 = b; + + unless (v1.line eq "LINE11") puts("v1 bad: ${v1}"); + unless (v2.line eq "LINE2") puts("v2 bad: ${v2}"); + + /* + * Do it again but with a list of a list (2d array in this case). + * Having the rhs be a string concat creates an object with a + * refCount of 1. + */ + + a1 = { { "old" . "val" } }; + a2 = a1; + a1[0][0] = "newval"; + unless (a1[0][0] == "newval") puts("a1[][] bad 1"); + unless (a2[0][0] == "oldval") puts("a2[][] bad 2"); + + a1 = { { } }; + a2 = a1; + a1[0][0] = "newval"; + unless (a1[0][0] == "newval") puts("a1[][] bad 3"); + if (a2[0][0]) puts("a2[][] bad 4"); + + /* Try the same thing with hashes. */ + + h{"idx"} = "LINE1" . "1"; + h2 = h; + + h{"idx"} = "LINE2"; + h3 = h; + + unless (h2{"idx"} eq "LINE11") puts("h2 bad: ${h2}"); + unless (h3{"idx"} eq "LINE2") puts("h3 bad: ${h3}"); +} +deep_5_1(); +} -output {} + +test regexp-1.0 {regular expression support} -body { +#lang L --line=1 +void regexp_1_0() { + string s = "string"; + puts(s =~ /ring/); + puts(s =~ /bob/); + puts(s !~ /ring/); + puts(s !~ /bob/); +} +#lang tcl +regexp_1_0 +} -output "1\n0\n0\n1\n" + +test regexp-1.1 {magic submatch variables ($1, $2, ...)} -body { +#lang L --line=1 +void regexp_1_1() { + string s = "Go not to the elves for counsel, for they will say both yes and no."; + + if (s =~ /((Go).*(elves)).*/) { + puts($0); + puts($1); + puts($2); + puts($3); + } +} +#lang tcl +regexp_1_1 +} -output "Go not to the elves for counsel, for they will say both yes and no. +Go not to the elves\nGo\nelves\n" + + +test regexp-1.2 {magic submatch variables with interpolation} -body { +#lang L --line=1 +void regexp_1_2() { + string s = "Go not to the elves for counsel, for they will say both yes and no."; + string interp = "elves"; + + if (s =~ /((Go).*(${interp})).*/) { + puts($0); + puts($1); + puts($2); + puts($3); + } +} +#lang tcl +regexp_1_2 +} -output "Go not to the elves for counsel, for they will say both yes and no. +Go not to the elves\nGo\nelves\n" + +test regexp-1.3 {regexp substitution} -body { +#lang L --line=1 -poly +void regexp_1_3() { + string s = "string"; + string s1[] = {"a", "b", "coochie"}; + hash h[2]; + + puts(s =~ m/ring/); + puts(s =~ m|bob|); + puts("--------"); + puts(s =~ s/ring/ling/); + puts(s); + puts("--------"); + puts(s1[2] =~ s/c/f/); + puts(s1); + puts("--------"); + h[0]{"a"} = "string"; + h[1]{"m"} = "not a string"; + puts(h); + h[1]{"m"} =~ s/not a/probably a/; + puts(h); +} +#lang tcl +regexp_1_3 +} -output "1\n0\n--------\n1\nstling\n--------\n1\na b foochie\n--------\n{a string} {m {not a string}}\n{a string} {m {probably a string}}\n" + +test regexp-1.4 {regexp modifiers i and g} -body { +#lang L --line=1 -poly +void regexp_1_4() { + string foo = "aaa"; + foo =~ s/a/b/; + puts(foo); + foo =~ s/a/b/g; + puts(foo); + foo =~ s/B/a/; + puts(foo); + foo =~ s/B/a/i; + puts(foo); + foo =~ s/B/a/ig; + puts(foo); + if (foo =~ /A/) { + puts("busted"); + } + if (foo =~ /A/i) { + puts("works"); + } +} +#lang tcl +regexp_1_4 +} -output "baa\nbbb\nbbb\nabb\naaa\nworks\n" + +test regexp-1.5 {regexp quoting} -body { +#lang L --line=1 +void +regexp_1_5() +{ + string r, s; + + s = "a b c d"; + s =~ s/\s//; + unless (s eq "ab c d") puts("bad 1"); + + s = "a b c d"; + s =~ s/\s+//g; + unless (s eq "abcd") puts("bad 2"); + + r = "\\s+"; + s = "a b c d"; + s =~ s/${r}//g; + unless (s eq "abcd") puts("bad 3"); + + r = "\\s+"; + s = "a b c d"; + s =~ s/\${r}//g; + unless (s eq "a b c d") puts("bad 4"); + + s = "$a$b"; + s =~ s/\$//g; // should match a dollar sign + unless (s eq "ab") puts("bad 5"); + + r = "\\s+"; + s = '${r} ${r}'; + s =~ s/\${r}//g; // should match '${r}' literally + unless (s eq " ") puts("bad 6"); + + s = "(in parens)"; + s =~ s/\(//; + unless (s eq "in parens)") puts("bad 7"); + s =~ s/(in)//; + unless (s eq " parens)") puts("bad 8"); + + /* + * Check escapes in the substitution part: + * & \0 \1 ... \9 get substituted with the re matches + * \a \e \f \n \r \t get expanded to control chars + * \x for anything else gets expanded to "x" + * $0-$9 are synonyms for \0-\9 + */ + + /* Check &, \0, and $0. */ + s = "abc"; + s =~ s/b/x&y/; + unless (s eq "axbyc") puts("bad 9.1"); + s = "abc"; + s =~ s/b/x\0y/; + unless (s eq "axbyc") puts("bad 9.2"); + s = "abc"; + s =~ s/b/x$0y/; + unless (s eq "axbyc") puts("bad 9.2.1"); + + /* Check \1 through \9. */ + s = "123456789abc"; + s =~ s/123456789a(b)c/123456789c\1a/; + unless (s eq "123456789cba") puts("bad 9.3"); + s = "123456789abc"; + s =~ s/12345678(9)a(b)c/123456789c\2a/; + unless (s eq "123456789cba") puts("bad 9.4"); + s = "123456789abc"; + s =~ s/1234567(8)(9)a(b)c/123456789c\3a/; + unless (s eq "123456789cba") puts("bad 9.5"); + s = "123456789abc"; + s =~ s/123456(7)(8)(9)a(b)c/123456789c\4a/; + unless (s eq "123456789cba") puts("bad 9.6"); + s = "123456789abc"; + s =~ s/12345(6)(7)(8)(9)a(b)c/123456789c\5a/; + unless (s eq "123456789cba") puts("bad 9.7"); + s = "123456789abc"; + s =~ s/1234(5)(6)(7)(8)(9)a(b)c/123456789c\6a/; + unless (s eq "123456789cba") puts("bad 9.8"); + s = "123456789abc"; + s =~ s/123(4)(5)(6)(7)(8)(9)a(b)c/123456789c\7a/; + unless (s eq "123456789cba") puts("bad 9.9"); + s = "123456789abc"; + s =~ s/12(3)(4)(5)(6)(7)(8)(9)a(b)c/123456789c\8a/; + unless (s eq "123456789cba") puts("bad 9.10"); + s = "123456789abc"; + s =~ s/1(2)(3)(4)(5)(6)(7)(8)(9)a(b)c/123456789c\9a/; + unless (s eq "123456789cba") puts("bad 9.11"); + + /* Check $1 through $9. */ + s = "123456789abc"; + s =~ s/123456789a(b)c/123456789c$1a/; + unless (s eq "123456789cba") puts("bad 9.12"); + s = "123456789abc"; + s =~ s/12345678(9)a(b)c/123456789c$2a/; + unless (s eq "123456789cba") puts("bad 9.13"); + s = "123456789abc"; + s =~ s/1234567(8)(9)a(b)c/123456789c$3a/; + unless (s eq "123456789cba") puts("bad 9.14"); + s = "123456789abc"; + s =~ s/123456(7)(8)(9)a(b)c/123456789c$4a/; + unless (s eq "123456789cba") puts("bad 9.15"); + s = "123456789abc"; + s =~ s/12345(6)(7)(8)(9)a(b)c/123456789c$5a/; + unless (s eq "123456789cba") puts("bad 9.16"); + s = "123456789abc"; + s =~ s/1234(5)(6)(7)(8)(9)a(b)c/123456789c$6a/; + unless (s eq "123456789cba") puts("bad 9.17"); + s = "123456789abc"; + s =~ s/123(4)(5)(6)(7)(8)(9)a(b)c/123456789c$7a/; + unless (s eq "123456789cba") puts("bad 9.18"); + s = "123456789abc"; + s =~ s/12(3)(4)(5)(6)(7)(8)(9)a(b)c/123456789c$8a/; + unless (s eq "123456789cba") puts("bad 9.19"); + s = "123456789abc"; + s =~ s/1(2)(3)(4)(5)(6)(7)(8)(9)a(b)c/123456789c$9a/; + unless (s eq "123456789cba") puts("bad 9.19.1"); + + /* Make sure $a still works, where a != [0-9]. */ + s = "123456789abc"; + s =~ s/1(2)(3)(4)(5)(6)(7)(8)(9)a(b)c/123456789c$aa/; + unless (s eq "123456789c$aa") puts("bad 9.19.2"); + + /* Check \a \e \f \n \r \t. */ + s = "a\nb\n\nc\n\nd\n"; + s =~ s/\n\n/\n/g; + unless (s eq "a\nb\nc\nd\n") puts("bad 9.20"); + + /* Check \x for x being anything else. */ + s = "abc"; + s =~ s/b/a\bc/; + unless (s eq "aabcc") puts("bad 9.30"); + s = "abc"; + s =~ s/b/a\&c/; + unless (s eq "aa&cc") puts("bad 9.31"); + + /* + * Re-do the above checks but put the escapes in an + * interpolated part of the substituted string. This checks + * that they are properly processed at run time. + */ + + /* Check & and \0. */ + s = "abc"; + r = "x&y"; + s =~ s/b/${r}/; + unless (s eq "axbyc") puts("bad 10.1"); + s = "abc"; + r = "x\\0y"; + s =~ s/b/${r}/; + unless (s eq "axbyc") puts("bad 10.2"); + + /* Check \1 through \9. */ + s = "123456789abc"; + r = "123456789c\\1a"; + s =~ s/123456789a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.3"); + s = "123456789abc"; + r = "123456789c\\2a"; + s =~ s/12345678(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.4"); + s = "123456789abc"; + r = "123456789c\\3a"; + s =~ s/1234567(8)(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.5"); + s = "123456789abc"; + r = "123456789c\\4a"; + s =~ s/123456(7)(8)(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.6"); + s = "123456789abc"; + r = "123456789c\\5a"; + s =~ s/12345(6)(7)(8)(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.7"); + s = "123456789abc"; + r = "123456789c\\6a"; + s =~ s/1234(5)(6)(7)(8)(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.8"); + s = "123456789abc"; + r = "123456789c\\7a"; + s =~ s/123(4)(5)(6)(7)(8)(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.9"); + s = "123456789abc"; + r = "123456789c\\8a"; + s =~ s/12(3)(4)(5)(6)(7)(8)(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.10"); + s = "123456789abc"; + r = "123456789c\\9a"; + s =~ s/1(2)(3)(4)(5)(6)(7)(8)(9)a(b)c/${r}/; + unless (s eq "123456789cba") puts("bad 10.11"); + + /* Check \a \e \f \n \r \t. */ + s = "a\nb\n\nc\n\nd\n"; + r = "\\n"; + s =~ s/\n\n/${r}/g; + unless (s eq "a\nb\nc\nd\n") puts("bad 10.20"); + + /* Check \x for x being anything else. */ + s = "abc"; + r = "a\\bc"; + s =~ s/b/${r}/; + unless (s eq "aabcc") puts("bad 10.30"); + s = "abc"; + r = "a\\&c"; + s =~ s/b/${r}/; + unless (s eq "aa&cc") puts("bad 10.31"); +} +#lang tcl +regexp_1_5 +} -output "" + +test regexp-1.6 {regexp capture variables in interpolated regexp} -body { +#lang L --line=1 +void regexp_1_6() +{ + string r1 = "(1)"; + string r2 = "(1)(2)(3)(4)(5)(6)(7)(8)(9)"; + + unless ("x1y" =~ /x${r1}y/) puts("bad 1.1"); + unless ($0 eq "x1y") puts("bad 1.2"); + unless ($1 eq "1") puts("bad 1.3"); + + unless ("x123456789y" =~ /x${r2}y/) puts("bad 2.1"); + unless ($0 eq "x123456789y") puts("bad 2.2"); + unless ($1 eq "1") puts("bad 2.3"); + unless ($2 eq "2") puts("bad 2.4"); + unless ($3 eq "3") puts("bad 2.5"); + unless ($4 eq "4") puts("bad 2.6"); + unless ($5 eq "5") puts("bad 2.7"); + unless ($6 eq "6") puts("bad 2.8"); + unless ($7 eq "7") puts("bad 2.9"); + unless ($8 eq "8") puts("bad 2.10"); + unless ($9 eq "9") puts("bad 2.11"); +} +regexp_1_6(); +} -output {} + +test regexp-1.7 {check number of regexp capture variables available} -body { +#lang L --line=1 +void regexp_1_7() +{ + /* + * This is more of a performance check. Ensure that in a + * regexp with no interpolations that no unneeded capture + * variables are allocated. + */ + + puts($1); // error -- no regexp seen yet, so $1 is not yet declared + + "x" =~ /(x)/; // declares $1 + puts($2); // error + + "x" =~ /(x)(y)/; // declares $1 and $2 + puts($3); // error +} +} -returnCodes error -match regexp -result {.*9: L Error: undeclared variable: \$1 +.*12: L Error: undeclared variable: \$2 +.*15: L Error: undeclared variable: \$3 +} + +test regexp-1.8 {check matching of different regexp kinds} -body { +#lang L --line=1 +/* + * The compiler generates four different kinds of code for regexp + * matching. This test checks each kind: + * re is a string constant - INST_STR_EQ + * re is a glob (/l modifier) - INST_STR_MATCH + * re has no captures - INST_REGEXP + * re has captures - ::regexp cmd + */ +int regexp_1_8_streq() { return("abc" =~ /^abc$/); } +int regexp_1_8_strmatch() { return("abc" =~ /abc/l); } +int regexp_1_8_simple_re() { return("abc" =~ /a*bc/); } +int regexp_1_8_complex_re() { return("abc" =~ /a*(b)c/); } +int regexp_1_8_complex_re2() { return("abc" =~ /^${""}abc$/); } +int regexp_1_8_complex_re3() { return("abc" =~ /^abc${""}$/); } +int regexp_1_8_complex_re4() { return("abc" =~ /^ab${""}c$/); } +void regexp_1_8() +{ + string dis; + + unless (regexp_1_8_streq()) puts("bad 1.1"); + unless (regexp_1_8_strmatch()) puts("bad 1.2"); + unless (regexp_1_8_simple_re()) puts("bad 1.3"); + unless (regexp_1_8_complex_re()) puts("bad 1.4"); + unless (regexp_1_8_complex_re2()) puts("bad 1.5"); + unless (regexp_1_8_complex_re3()) puts("bad 1.6"); + unless (regexp_1_8_complex_re4()) puts("bad 1.7"); + + /* + * Check the disassembly of the regexp matches to verify that + * they are compiled as expected. + */ + dis = ::tcl::unsupported::disassemble("proc", "regexp_1_8_streq"); + unless (dis =~ /streq/) puts("bad 2.1"); + dis = ::tcl::unsupported::disassemble("proc", "regexp_1_8_strmatch"); + unless (dis =~ /strmatch/) puts("bad 2.2"); + dis = ::tcl::unsupported::disassemble("proc", "regexp_1_8_simple_re"); + unless (dis =~ / regexp/) puts("bad 2.3"); + dis = ::tcl::unsupported::disassemble("proc", "regexp_1_8_complex_re"); + unless (dis =~ /::regexp/) puts("bad 2.4"); + dis = ::tcl::unsupported::disassemble("proc", "regexp_1_8_complex_re2"); + unless (dis =~ /::regexp/) puts("bad 2.5"); + dis = ::tcl::unsupported::disassemble("proc", "regexp_1_8_complex_re3"); + unless (dis =~ /::regexp/) puts("bad 2.6"); + dis = ::tcl::unsupported::disassemble("proc", "regexp_1_8_complex_re4"); + unless (dis =~ /::regexp/) puts("bad 2.7"); +} +regexp_1_8(); +} -output {} + +test regexp-1.9 {check alternate regexp syntax} -body { +#lang L +void regexp_1_9() +{ + string s; + + unless ("Hello World" =~ m!World!) puts("bad 1.1"); + unless ("Hello World" =~ m!world!i) puts("bad 1.2"); + + unless ("Hello World" =~ m,World,) puts("bad 1.3"); + unless ("Hello World" =~ m,world,i) puts("bad 1.4"); + + unless ("Hello World" =~ m/World/) puts("bad 1.5"); + unless ("Hello World" =~ m/world/i) puts("bad 1.6"); + + unless ("/usr/bin/perl" =~ m"/perl") puts("bad 1.7"); + unless ("/usr/bin/perl" =~ m"/Perl"i) puts("bad 1.8"); + + /* + * The following delims are special cases and must be matched + * as shown. Using the start delim as the end delim is an + * error here, unlike all the other allowable delims. This is + * for Perl compatibility. + */ + + unless ("Hello World" =~ m{World}) puts("bad 2.1"); + unless ("Hello World" =~ m{world}i) puts("bad 2.2"); + + /* Test alternate syntax like s{regexp}{replace}. */ + + s = "xyzzy"; + s =~ s{xy}{zz}; + unless (s == "zzzzy") puts("bad 3.1"); + + s = "xyzzy"; + s =~ s{XY}{zz}i; + unless (s == "zzzzy") puts("bad 3.2"); + + s = "xyzzy"; + s =~ s{xy}/zz/; + unless (s == "zzzzy") puts("bad 3.3"); + + s = "xyzzy"; + s =~ s{XY}/zz/i; + unless (s == "zzzzy") puts("bad 3.4"); +} +regexp_1_9(); +} -output {} + +test regexp-1.10 {test alternate regexp lexical and syntax errors} -setup { + # This is a pain to test because tcltest cannot handle + # the unbalanced {} () that we need in the L code. + # Make the .l file using makeFile so we can quote those + # characters and keep tcltest happy. + makeFile " + void main() + { + string s; + + /* + * This tests when the regexp start delim is different + * than the end delim. The following are all errors, + * because the start delim is not escaped inside the + * regexp even though it is illegal to use it as + * the end delim. This rule comes from Perl. + */ + s =~ m\{\{\}; + s =~ s\{\{\}\{\}; + + /* + * Put this one last since it causes a syntax error. + * Although s{regexp}{replace} is legal, + * s/regexp//replace/ is not. + */ + s =~ s/regexp//replace/; + } + " regexp-1.10.l +} -body { +#lang L +void regexp_1_10() +{ + int ret; + string tclsh = interpreter(); + string out, err[]; + + ret = system({tclsh, "regexp-1.10.l"}, undef, &out, &err); + unless (ret == 1) puts("bad 1.1"); + if (out) puts("bad 1.2: ${out}"); + unless (err[0] =~ /:13: L Error: regexp delimiter must be quoted/) { + puts("bad 1.3: ${err[0]}"); + } + unless (err[1] =~ /:14: L Error: regexp delimiter must be quoted/) { + puts("bad 1.4: ${err[1]}"); + } + unless (err[2] =~ /:21: L Error: syntax error/) { + puts("bad 1.5: ${err[2]}"); + } +} +regexp_1_10(); +} -output {} + +test regexp-1.11 {test regexp submatch captures with subst operator} -body { +#lang L --line=1 +void regexp_1_11() +{ + string s; + + /* + * A single substitution. + */ + s = "abcd"; + s =~ s/a(b)(c)d/a\2\1d/; + unless (s == "acbd") puts("bad 1.1 '${s}'"); + unless ($0 == "abcd") puts("bad 1.2"); + unless ($1 == "b") puts("bad 1.3"); + unless ($2 == "c") puts("bad 1.4"); + + /* + * Multiple substitutions. $0-$9 should reflect the last match. + */ + s = "abc1abc22abc333"; + s =~ s/a(b)(c)(\d+)/\3\2\1/g; + unless (s == "1cb22cb333cb") puts("bad 2.1 '${s}'"); + unless ($0 == "abc333") puts("bad 2.2"); + unless ($1 == "b") puts("bad 2.3"); + unless ($2 == "c") puts("bad 2.4"); + unless ($3 == "333") puts("bad 2.5"); +} +regexp_1_11(); +} -output {} + +test regexp-1.12 {check newline matching of . in regexp} -body { +#lang L --line=1 +void regexp_1_12() +{ + /* + * "." in a regexp should not match embedded newlines. + */ + + string s1 = "a\nb"; + string s2 = "a\n\nb"; + + /* + * These used to compile to INST_STR_MATCH bytecodes. + */ + + // s1 & s2 are Tcl_Obj's with no type yet + if (s1 =~ /a.b/) puts("bad 1.1"); + if (s2 =~ /a.*b/) puts("bad 1.2"); + + // make them type bytearray + s1 = Binary_format("a*", s1); + s2 = Binary_format("a*", s2); + if (s1 =~ /a.b/) puts("bad 1.3"); + if (s2 =~ /a.*b/) puts("bad 1.4"); + + // make them type string + s1 = sprintf("%s", s1); + s2 = sprintf("%s", s2); + if (s1 =~ /a.b/) puts("bad 1.5"); + if (s2 =~ /a.*b/) puts("bad 1.6"); + + /* + * These compile to INST_REGEXP bytecodes. + */ + + if (s1 =~ /a.bc?/) puts("bad 2.1"); + if (s2 =~ /a.*bc?/) puts("bad 2.2"); + + /* + * These compile to calls to the ::regexp cmd. + */ + + if (s1 =~ /a.(b)/) puts("bad 3.1"); + if (s2 =~ /a.*(b)/) puts("bad 3.2"); +} +regexp_1_12(); +} -output {} + +test regexp-2 {test globs} -body { +#lang L --line=1 +void regexp_2() +{ + unless ("x" =~ /?/l) puts("bad 1.1"); + unless ("xy" =~ /??/l) puts("bad 1.2"); + unless ("xy" =~ /*y/l) puts("bad 1.3"); /* this comment is for emacs */ + unless ("xy" =~ /[x-z]y/l) puts("bad 1.4"); +} +regexp_2(); +} -output {} + +test reference-1.1 {L references} -body { +#lang L --line=1 +private int ref_11_g_private; +int ref_11_g_public; +struct reference_1_1_point { + int x, y; +}; +private void setvar(int &var, int val) +{ + var = val; +} +class ref_11_cls { + public int cpub; + instance { + public int cinst; + } + constructor ref_11_cls_new() + { + setvar(&cpub, 123); + unless (cpub == 123) puts("bad c.1"); + setvar(&cinst, 456); + unless (cinst == 456) puts("bad c.2"); + } +} +void reference_1_1() +{ + int local; + ref_11_cls o; + struct reference_1_1_point a = { 0, 0 }; + + unless ((a.x == 0) && (a.y == 0)) puts("bad 1.1"); + reference_1_1_tweak(&a); + unless ((a.x == 2) && (a.y == 0)) puts("bad 1.2"); + + setvar(&local, 222); + unless (local == 222) puts("bad 2.1"); + + o = ref_11_cls_new(); + unless (ref_11_cls->cpub == 123) puts("bad 3.1"); + unless (o->cinst == 456) puts("bad 3.2"); + + setvar(&ref_11_cls->cpub, 234); + unless (ref_11_cls->cpub == 234) puts("bad 3.3"); + + setvar(&o->cinst, 567); + unless (o->cinst == 567) puts("bad 3.4"); + + setvar(&ref_11_g_public, 1100); + unless (ref_11_g_public == 1100) puts("bad 4.1"); + + setvar(&ref_11_g_private, 1200); + unless (ref_11_g_private == 1200) puts("bad 4.2"); +} +void reference_1_1_tweak(struct reference_1_1_point &foo) +{ + foo->x = 2; +} +reference_1_1(); +} -output {} + +test reference-1.2 {test deep-dive arguments (copy in/out)} -body { +#lang L --line=1 +void r12set(string &s, string v) { s = v; } +void reference_1_2() +{ + string a[]; + string aa[][]; + string aaa[][][]; + string h{string}; + string hh{string}{string}; + string hhh{string}{string}{string}; + struct { + string s; + string a[]; + string h{string}; + } st; + + r12set(&a[0], "zero"); + unless (a[0] eq "zero") puts("bad 1.1"); + r12set(&a[1], "one"); + unless ((a[0] eq "zero") && (a[1] eq "one")) puts("bad 1.2"); + r12set(&a[0], "is1"); + unless ((a[0] eq "is1") && (a[1] eq "one")) puts("bad 1.3"); + + r12set(&aa[1][2], "12"); + unless (aa[1][2] eq "12") puts("bad 2.1"); + + r12set(&aaa[3][2][1], "321"); + unless (aaa[3][2][1] eq "321") puts("bad 3.1"); + + r12set(&h{"zero"}, "is0"); + unless (h{"zero"} eq "is0") puts("bad 10.1"); + + r12set(&hh{"zero1"}{"zero2"}, "is00"); + unless (hh{"zero1"}{"zero2"} eq "is00") puts("bad 11.1"); + + r12set(&hhh{"zero3"}{"zero2"}{"zero1"}, "is000"); + unless (hhh{"zero3"}{"zero2"}{"zero1"} eq "is000") puts("bad 12.1"); + + r12set(&st.s, "iss"); + unless (st.s eq "iss") puts("bad 20.1"); + + r12set(&st.a[3], "a-3"); + unless (st.a[3] eq "a-3") puts("bad 21.1"); + + r12set(&st.h{"two"}, "h-2"); + unless (st.h{"two"} eq "h-2") puts("bad 22.1"); +} +reference_1_2(); +} -output {} + +test reference-1.2.1 {test deep-dive copy in/out with built-in compiler functions} -body { +#lang L --line=1 +void reference_1_2_1() +{ + string cmd, s[]; + STATUS st[]; + FILE f; + int pid, ret; + + /* + * These tests pass array or hash elements as reference + * parameters. The compiler implements these as + * copy-in/copy-out parameters and these used to not work + * with compiler built-ins. + */ + + // check system(): out/err/STATUS args + cmd = <<'END' + perl -e 'print "test32"; print STDERR "yes1"; exit(0);' + END; + ret = system(cmd, undef, &s[0], &s[1], &st[0]); + unless (ret == 0) puts("bad 1.1"); + unless (s[0] == "test32") puts("bad 1.2"); + unless (s[1] == "yes1") puts("bad 1.3"); + unless (st[0].argv[0] == "perl") puts("bad 1.4"); + + // check read(): buf arg + unless (Fprintf("ref-1-2-1.txt", "654321") == 0) puts("bad 2.1"); + unless (f = fopen("ref-1-2-1.txt", "r")) puts("bad 2.2"); + unless (read(f, &s[0]) == 6) puts("bad 2.3"); + unless (s[0] == "654321") pust("bad 2.4"); + fclose(f); + unlink("ref-1-2-1.txt"); + + // check spawn(): when the STATUS arg gets set + cmd = "not-perl -e 'exit(123);'"; + pid = spawn(cmd, undef, undef, undef, &st[0]); + if (defined(pid)) puts("bad 3.1"); + unless (st[0].argv == {"not-perl","-e","exit(123);"}) puts("bad 3.3"); + + // check waitpid(): STATUS arg + cmd = "perl -e 'exit(123);'"; + pid = spawn(cmd); + unless (defined(pid)) puts("bad 4.1"); + unless (waitpid(pid, &st[0], 0) == pid) puts("bad 4.2"); + unless (st[0].argv == {"perl","-e","exit(123);"}) puts("bad 4.3"); +} +reference_1_2_1(); +} -output {} + +test reference-1.3 {test copy in/out semantics} -body { +#lang L --line=1 +string g_ref13[]; +void r13(string &s, string v) +{ + s = v; + g_ref13 = { "ch-one", "ch-two", "ch-three" }; +} +void reference_1_3() +{ + g_ref13 = { "one", "two" }; + r13(&g_ref13[0], "new-one"); + unless (join("|", g_ref13) eq "new-one|ch-two|ch-three") puts("bad 1.1"); +} +reference_1_3(); +} -output {} + +test reference-1.4 {test multiple reference arguments} -body { +#lang L --line=1 +void reference_1_4_foo1(string &s1, string &s2) +{ + s1 = s2; +} +void reference_1_4_foo2(string &s1, string s2) +{ + s1 = s2; + s2 = "bad"; +} +void reference_1_4_foo3(string &s1, string s2, string &s3) +{ + s1 = sprintf("%s%s", s2, s3); + s2 = "bad"; +} +void reference_1_4_foo4(string &s1, string s2, string &s3) +{ + s1 = sprintf("%s%s", s2, s3); + s3 = s2; + s2 = "bad"; +} +void reference_1_4_foo5(string &s1, string &s2, string &s3) +{ + s1 = sprintf("%s%s", s2, s3); + s2 = s3; + s3 = "x"; +} +void reference_1_4_foo6(string &s1, string s2, string &s3, string s4) +{ + s1 = sprintf("%s%s", s2, s3); + s3 = sprintf("%s%s", s3, s4); + s2 = s4 = "bad"; +} +void reference_1_4_foo7(string s1, string &s2, string s3, string s4, string &s5) +{ + s2 = sprintf("%s%s%s", s1, s2, s3); + s5 = sprintf("%s%s%s", s3, s4, s5); + s1 = s3 = s4 = "bad"; +} +void reference_1_4() +{ + string s1, s2, s3; + + s1 = ""; + s2 = "foo1"; + reference_1_4_foo1(&s1, &s2); + unless (s1 eq "foo1") puts("bad 1.1"); + unless (s2 eq "foo1") puts("bad 1.2"); + + s1 = ""; + reference_1_4_foo2(&s1, "foo2"); + unless (s1 eq "foo2") puts("bad 2.1"); + + s1 = ""; + s2 = "xxx"; + reference_1_4_foo3(&s1, "foo3", &s2); + unless (s1 eq "foo3xxx") puts("bad 3.1"); + unless (s2 eq "xxx") puts("bad 3.2"); + + s1 = "xx"; + s2 = "yy"; + reference_1_4_foo4(&s1, "foo4", &s2); + unless (s1 eq "foo4yy") puts("bad 4.1"); + unless (s2 eq "foo4") puts("bad 4.2"); + + s1 = "zz"; + s2 = "xx"; + s3 = "yy"; + reference_1_4_foo5(&s1, &s2, &s3); + unless (s1 eq "xxyy") puts("bad 4.1"); + unless (s2 eq "yy") puts("bad 4.2"); + unless (s3 eq "x") puts("bad 4.3"); + + s1 = "x"; + s2 = "y"; + reference_1_4_foo6(&s1, "foo61", &s2, "foo62"); + unless (s1 eq "foo61y") puts("bad 5.1"); + unless (s2 eq "yfoo62") puts("bad 5.2"); + + s1 = "a"; + s2 = "b"; + reference_1_4_foo7("foo71", &s1, "foo72", "foo73", &s2); + unless (s1 eq "foo71afoo72") puts("bad 6.1"); + unless (s2 eq "foo72foo73b") puts("bad 6.2"); +} +reference_1_4(); +} -output {} + +test reference-1.5 {test parameter multiple declaration errs with references} -body { +#lang L --line=1 -nowarn +void reference_1_5_1(string &arg1, string arg1) {} +void reference_1_5_2(string &arg2, string &arg2) {} +void reference_1_5_3(string arg3, string &arg3) {} +void reference_1_5_4(string &arg4, string &arg4, string arg4) {} +void reference_1_5_5(string &arg5, string arg5, string &arg5) {} +} -returnCodes error -match regexp -result {.*1: L Error: multiple declaration of local arg1 +.*2: L Error: multiple declaration of local &arg2 +.*3: L Error: multiple declaration of local arg3 +.*4: L Error: multiple declaration of local &arg4 +.*4: L Error: multiple declaration of local arg4 +.*5: L Error: multiple declaration of local &arg5 +.*5: L Error: multiple declaration of local arg5 +.*5: L Error: multiple declaration of local arg5 +} + +test reference-1.6 {test reference parameter passed as a reference parameter} -body { +#lang L --line=1 +string reference_1_6_g; +void reference_1_6_1(string &arg) +{ + arg .= "2"; + reference_1_6_2(&arg); +} +void reference_1_6_2(string &arg) +{ + arg .= "3"; +} +void reference_1_6() +{ + string s; + + s = "1"; + reference_1_6_1(&s); + unless (s == "123") puts("bad 1"); + + reference_1_6_g = "1"; + reference_1_6_1(&reference_1_6_g); + unless (reference_1_6_g == "123") puts("bad 2"); +} +reference_1_6(); +} -output {} + +test pointer-1 {check L pointers} -body { +#lang L --line=1 +string pointer_1_g_public; +private string pointer_1_g_private; +private string chk(_argused string opt, poly var) +{ + return (var); +} +class pointer_1_cls { + public string s; + instance { + public string si; + } + constructor pointer_1_cls_new() + { + string nm; + + nm = chk(textvariable: &pointer_1_g_public); + unless (nm eq "::pointer_1_g_public") { + puts("bad c1.1"); + } + nm = chk(textvariable: &pointer_1_g_private); + unless (nm =~ /::_[0-9]+%l_toplevel_pointer_1_g_private/) { + puts("bad c1.2"); + puts(nm); + } + nm = chk(textvariable: &s); + unless (nm eq "::L::_class_pointer_1_cls::s") { + puts("bad c1.3"); + } + nm = chk(textvariable: &si); + unless (nm eq "::L::_instance_pointer_1_cls1::si") { + puts("bad c1.4"); + } + } +} +void pointer_1() +{ + string nm; + pointer_1_cls obj = pointer_1_cls_new(); + + nm = chk(textvariable: &pointer_1_g_public); + unless (nm eq "::pointer_1_g_public") { + puts("bad 1.1"); + } + nm = chk(textvariable: &pointer_1_g_private); + unless (nm =~ /::_[0-9]+%l_toplevel_pointer_1_g_private/) { + puts("bad 1.2"); + } + nm = chk(textvariable: &pointer_1_cls->s); + unless (nm eq "::L::_class_pointer_1_cls::s") { + puts("bad 1.3"); + } + nm = chk(textvariable: &obj->si); + unless (nm eq "::L::_instance_pointer_1_cls1::si") { + puts("bad 1.4"); + } +} +pointer_1(); +} -output {} + +test pointer-2 {check L pointer identification} -body { +#lang L --line=1 +string pointer_2_g; +private void chk(_argused string opt, poly arg, string varname) +{ + unless (arg =~ /${varname}/) puts("bad chk.1"); +} +private string joinargs(...args) +{ + string ret, s; + + foreach (s in args) { + if (defined(ret)) { + ret .= " " . s; + } else { + ret = s; + } + } + return (ret); +} +void pointer_2() +{ + string s; + + /* These are L pointers. */ + s = joinargs(textvariable: &pointer_2_g); + unless (s eq "-textvariable ::pointer_2_g") puts("bad 1.1"); + s = joinargs(tvariable: &pointer_2_g); + unless (s eq "-tvariable ::pointer_2_g") puts("bad 1.2"); + s = joinargs(variable: &pointer_2_g); + unless (s eq "-variable ::pointer_2_g") puts("bad 1.3"); + + /* These are reference parameters, not pointers. */ + s = joinargs(ariable: &s); + unless (s eq "-ariable s") puts("bad 2.1"); + s = joinargs(o: &s); + unless (s eq "-o s") puts("bad 2.2"); + + /* Mix of L pointers and ref parms. */ + s = joinargs(textvariable: &pointer_2_g, &s); + unless (s eq "-textvariable ::pointer_2_g s") puts("bad 3.1"); + s = joinargs(textvariable: &pointer_2_g, &s, &s); + unless (s eq "-textvariable ::pointer_2_g s s") puts("bad 3.2"); + s = joinargs(&s, textvariable: &pointer_2_g); + unless (s eq "s -textvariable ::pointer_2_g") puts("bad 3.3"); + s = joinargs(&s, &s, textvariable: &pointer_2_g); + unless (s eq "s s -textvariable ::pointer_2_g") puts("bad 3.4"); + s = joinargs(&s, textvariable: &pointer_2_g, &s); + unless (s eq "s -textvariable ::pointer_2_g s") puts("bad 3.5"); +} +pointer_2(); +} -output {} + +test pointer-3 {check L pointer errors} -body { +#lang L --line=1 -nowarn +class pointer_3_cls {} +private void chk(_argused string opt, _argused poly arg) {} +void pointer_3() +{ + string s; + string sa[]; + string saa[][]; + string h{string}; + + /* + * These should all issue errors, not crash the compiler. + */ + chk(textvariable: &undeclared1); + chk(textvariable: &undeclared2[2]); + chk(textvariable: &undeclared3.s); + chk(textvariable: &undeclared4->s); + chk(textvariable: &pointer_3_cls->undeclared1); + chk(textvariable: &pointer_3_cls->undeclared2[3]); + chk(textvariable: &s); + chk(textvariable: &sa[1]); + chk(textvariable: &saa[1][2]); + chk(textvariable: &h{"bad"}); + chk(textvariable: &chk); +} +} -returnCodes error -match regexp -result {.*13: L Error: undeclared variable: undeclared1 +.*14: L Error: undeclared variable: undeclared2 +.*15: L Error: undeclared variable: undeclared3 +.*16: L Error: undeclared variable: undeclared4 +.*17: L Error: undeclared1 is not a member of class pointer_3_cls +.*18: L Error: undeclared2 is not a member of class pointer_3_cls +.*19: L Error: illegal operand to & +.*20: L Error: illegal operand to & +.*21: L Error: illegal operand to & +.*22: L Error: illegal operand to & +.*23: L Error: illegal operand to & +} + +test typedef-1.0 {basic typedef support} -body { +#lang L --line=1 +typedef int typedef_1_0_foot[5]; +typedef string typedef_1_0_nike; +typedef struct typedef_1_0_point { + int x; + int y; +} typedef_1_0_point; + +void typedef_1_0() { + puts(typedef_1_0_aux()); +} + +typedef_1_0_nike typedef_1_0_aux() { + typedef_1_0_foot cheese; + typedef_1_0_nike shoe = "pegasus"; + typedef_1_0_point p; + + p.x = 1; + p.y = 2; + puts(p); + cheese[2] = 1; + cheese[3] = 2; + cheese[4] = 3; + puts(cheese[3]); + puts(shoe); + return shoe; +} +#lang tcl +typedef_1_0 +} -output "1 2\n2\npegasus\npegasus\n" + +test typedef-1.1 {test redefining identical typedefs} -body { +#lang L --line=1 +typedef int t1; +typedef int t1; +typedef int t1; + +typedef float t2; +typedef float t2; +typedef float t2; + +typedef string t3; +typedef string t3; +typedef string t3; + +typedef widget t4; +typedef widget t4; +typedef widget t4; + +typedef poly t5; +typedef poly t5; +typedef poly t5; + +typedef int a11_1[]; +typedef int a11_1[]; +typedef int a11_1[]; + +typedef int a11_2[2]; +typedef int a11_2[2]; +typedef int a11_2[2]; + +typedef int a11_3{int}; +typedef int a11_3{int}; +typedef int a11_3{int}; + +typedef int a11_4[2][3]; +typedef int a11_4a[3]; +typedef a11_4a a11_4[2]; + +typedef struct { int x,y; } s11_1; +typedef struct { int x,y; } s11_1; +typedef struct { int x,y; } s11_1; + +typedef int int_typedef; + +typedef int h11_1{int}; +typedef int h11_1{int_typedef}; +typedef int_typedef h11_1{int}; +typedef int_typedef h11_1{int_typedef}; + +typedef int h11_2{int}{int}; +typedef int h11_2a{int}; +typedef h11_2a h11_2{int}; +} -output "" + +test typedef-1.2 {test redefining different typedefs} -body { +#lang L --line=1 +typedef int t12; +typedef float t12; +typedef string t12; +typedef widget t12; +typedef poly t12; // not an error, but perhaps should be +typedef int t12[]; +typedef int t12[2]; +typedef int t12{int}; +typedef struct { int i; } t12; + +typedef int a12_1[]; // not an error -- array size is ignored +typedef int a12_1[2]; + +typedef int a12_2[2]; // not an error -- array size is ignored +typedef int a12_2[]; + +typedef int a12_3[2]; +typedef string a12_3[2]; + +typedef int h12_1{int}; +typedef int h12_1{string}; + +typedef int h12_2{int}; +typedef string h12_2{int}; + +typedef int h12_3{int}; +typedef string h12_3{string}; + +typedef struct { int x; } s12_1; +typedef struct { string x; } s12_1; + +typedef struct { int x; } s12_2; +typedef struct { int x,y; } s12_2; + +typedef struct { int x,y; } s12_3; +typedef struct { int x; } s12_3; + +typedef struct s1 { int x; } s12_4; +typedef struct s2 { string x; } s12_4; + +typedef struct s3 { int x; } s12_5; +typedef struct s4 { int x,y; } s12_5; + +typedef struct s5 { int x,y; } s12_6; +typedef struct s6 { int x; } s12_6; +} -returnCodes error -match regexp -result {.*2: L Error: Cannot redefine type t12 +.*3: L Error: Cannot redefine type t12 +.*4: L Error: Cannot redefine type t12 +.*6: L Error: Cannot redefine type t12 +.*7: L Error: Cannot redefine type t12 +.*8: L Error: Cannot redefine type t12 +.*9: L Error: Cannot redefine type t12 +.*18: L Error: Cannot redefine type a12_3 +.*21: L Error: Cannot redefine type h12_1 +.*24: L Error: Cannot redefine type h12_2 +.*27: L Error: Cannot redefine type h12_3 +.*30: L Error: Cannot redefine type s12_1 +.*33: L Error: Cannot redefine type s12_2 +.*36: L Error: Cannot redefine type s12_3 +.*39: L Error: Cannot redefine type s12_4 +.*42: L Error: Cannot redefine type s12_5 +.*45: L Error: Cannot redefine type s12_6 +} + +test typedef-1.3 {test some typedef cases} -body { +#lang L --line=1 +/* + * This is really a regression test. These have caused errors in the past. + */ +typedef int int_t; +typedef int h1_t{int_t}; +typedef int_t h2_t{int}; +typedef int_t h3_t{int_t}; +void typedef_1_3() +{ + int k, n; + h1_t h1 = { 1=>2 }; + h2_t h2 = { 3=>4, 5=>6 }; + h3_t h3 = { 7=>8, 9=>10, 11=>12 }; + + unless (h1{1} == 2) puts("bad 1"); + n = 0; + foreach (k in h1) ++n; + unless (n == 1) puts("bad 2"); + + unless ((h2{3} == 4) && (h2{5} == 6)) puts("bad 3"); + n = 0; + foreach (k in h2) ++n; + unless (n == 2) puts("bad 4"); + + unless ((h3{7} == 8) && (h3{9} == 10) && (h3{11} == 12)) puts("bad 4"); + n = 0; + foreach (k in h3) ++n; + unless (n == 3) puts("bad 5"); +} +#lang tcl +typedef_1_3 +} -output {} + +test typedef-1.4 {test another typedef case} -body { +#lang L --line=1 +/* Another regression test. This used to fail. */ +typedef struct { + int x; + int y; +} typedef_1_4_t; + +typedef_1_4_t typedef_1_4_bars{string}; + +void typedef_1_4_foo(typedef_1_4_t f) +{ + typedef_1_4_bars{"FOO"} = f; + puts("X = ${f.x}"); +} + +void typedef_1_4() +{ + typedef_1_4_t f = { 1, 2 }; + typedef_1_4_foo(f); +} +#lang tcl +typedef_1_4 +} -output {X = 1 +} + + +test defined-1.0 {interesting defined form support} -body { +#lang L --line=1 +void defined_1_0() { + int arr[5][2], i, j; + for (i = 0; defined(arr[i]); i++) { + for (j = 0; defined(arr[i][j]); j++) { + puts(format("%d, %d", i, j)); + } + } + puts("-*-"); + puts(defined(arr[3])); + puts(defined(arr[-1])); +} +#lang tcl +defined_1_0 +} -output "-*- +0 +0 +" + +test defined-1.1 {defined works on hashes} -body { +#lang L --line=1 +void defined_1_1() { + hash foo[5]; + + foo[2]{"a"} = 1; + foo[3]{"b"} = 2; + + if (defined(foo[2]{"a"})) { + puts("defined works"); + } + if (!defined(foo[2]{"b"})) { + puts("defined works even better"); + } +} +#lang tcl +defined_1_1 +} -output "defined works\ndefined works even better\n" + +test main-1.0 {test that main gets called} -setup { + set fname [makeFile { + void main() { + printf("main got called\n"); + } + } test-1.0.l] +} -constraints { + exec +} -body { + exec [interpreter] $fname +} -cleanup { + removeFile test-1.0.l +} -result {main got called} + +test main-2.1 {test main() with one parameter} -setup { + set fname [makeFile { + void main(string av[]) { + string s; + undef(av[0]); // don't print av[0] + foreach (s in av) printf("<${s}>"); + } + } main-2.1.l] +} -constraints { + exec +} -body { + exec [interpreter] $fname arg1 arg2 arg3 +} -cleanup { + removeFile main-2.1.l +} -result {<arg1><arg2><arg3>} + +test main-2.2 {test main() with two parameters} -setup { + set fname [makeFile { + void main(int ac, string av[]) { + string s; + printf("<${ac}>"); + undef(av[0]); // don't print av[0] + foreach (s in av) printf("<${s}>"); + } + } main-2.2.l] +} -constraints { + exec +} -body { + exec [interpreter] $fname arg1 arg2 arg3 +} -cleanup { + removeFile main-2.2.l +} -result {<4><arg1><arg2><arg3>} + +test main-2.3 {test main() with three parameters} -setup { + set fname [makeFile { + putenv("MAIN23_TEST=YES"); + void main(int ac, string av[], string env{string}) { + string s; + printf("<${ac}>"); + undef(av[0]); // don't print av[0] + foreach (s in av) printf("<${s}>"); + printf("<${env{"MAIN23_TEST"}}>"); + } + } main-2.3.l] +} -constraints { + exec +} -body { + exec [interpreter] $fname arg1 arg2 arg3 +} -cleanup { + removeFile main-2.3.l +} -result {<4><arg1><arg2><arg3><YES>} + +test main-3 {check that main() return value is tclsh exit status} -setup { + set fname1 [makeFile { + int main(string av[]) + { + puts("main here"); + return (int)av[1]; + } + } main-3-int.l] + set fname2 [makeFile { + void main() + { + puts("main here"); + } + } main-3-void.l] +} -body { +#lang L --line=1 +void main3() +{ + int ret; + string out; + string tclsh = eval("interpreter"); + + ret = system({tclsh, "main-3-int.l", 0}, undef, &out, undef); + unless (ret == 0) puts("1.1"); + unless (out == "main here\n") puts("bad 1.2"); + + ret = system({tclsh, "main-3-int.l", 1}, undef, &out, undef); + unless (ret == 1) puts("bad 2.1"); + unless (out == "main here\n") puts("bad 2.2"); + + ret = system({tclsh, "main-3-int.l", 123}, undef, &out, undef); + unless (ret == 123) puts("bad 3.1"); + unless (out == "main here\n") puts("bad 3.2"); + + /* Check that a void main() gives an exit status of 0. */ + ret = system({tclsh, "main-3-void.l", 123}, undef, &out, undef); + unless (ret == 0) puts("bad 4.1"); + unless (out == "main here\n") puts("bad 4.2"); +} +main3(); +} -output {} + +test main-4 {check main() type checking} -body { +#lang L --line=1 +float main() { return (3.14159); } +void main(float bad) {} +void main(int ac, string bad) {} +void main(int ac, string av[], string bad) {} +void main(int bad1, string bad2[], string bad3{string}, string too_many) {} +} -returnCodes error -match regexp -result {.*1: L Error: main must have int or void return type +.*2: L Error: invalid parameter types for main\(\) +.*3: L Error: invalid parameter types for main\(\) +.*4: L Error: invalid parameter types for main\(\) +.*5: L Error: too many formal parameters for main\(\) +} + +test defined-1.2 {defined operator on scalars} -body { +#lang L --line=1 +int d12_fint() { return 0; } +float d12_ffloat() { return 0.0; } +string d12_fstring() { return "0"; } +void +defined_1_2() +{ + int i; + int ii = 0; + string s; + string ss = ""; + float f; + float ff = 3.14159; + + if (defined(i)) puts("err 1"); + unless (defined(ii)) puts("err 2"); + if (defined(s)) puts("err 3"); + unless (defined(ss)) puts("err 4"); + if (defined(f)) puts("err 5"); + unless (defined(ff)) puts("err 6"); + unless (defined(0)) puts("err 7"); + unless (defined(1)) puts("err 7"); + unless (defined("")) puts("err 8"); + unless (defined("x")) puts("err 9"); + unless (defined(0.0)) puts("err 10"); + unless (defined(1.0)) puts("err 11"); + unless (defined(d12_fint())) puts("err 12"); + unless (defined(d12_ffloat())) puts("err 13"); + unless (defined(d12_fstring())) puts("err 14"); + unless (defined(1-0)) puts("err 16"); + unless (defined(1+2+3+4)) puts("err 17"); +} +#lang tcl +defined_1_2 +} -output "" + +test defined-1.3 {defined operator on auto-extended arrays} -body { +#lang L --line=1 +void +defined_1_3() +{ + int i; + int a[]; + int a3[3] = {0, 0, 0}; + string s[]; + string s3[3] = {"", "", ""}; + float f[]; + float f3[3] = {0.0, 0.0, 0.0}; + string h{int}[]; + + a[3] = 3; + a[5] = 5; + a[6] = 6; + a[8] = 8; + if (defined(a[0])) puts("err 1.1"); + if (defined(a[1])) puts("err 1.2"); + if (defined(a[2])) puts("err 1.3"); + unless (defined(a[3])) puts("err 1.4"); + if (defined(a[4])) puts("err 1.5"); + unless (defined(a[5])) puts("err 1.6"); + unless (defined(a[6])) puts("err 1.7"); + if (defined(a[7])) puts("err 1.8"); + unless (defined(a[8])) puts("err 1.9"); + for (i = 9; i < 1000; ++i) { + if (defined(a[i])) printf("err 1.10 i=%d\n", i); + } + + unless (defined(a3[0])) puts("err 2.1"); + unless (defined(a3[1])) puts("err 2.2"); + unless (defined(a3[2])) puts("err 2.3"); + for (i = 3; i < 1000; ++i) { + if (defined(a3[i])) printf("err 2.4 i=%d\n", i); + } + + s[3] = "3"; + s[5] = "5"; + s[6] = "6"; + s[8] = "8"; + if (defined(s[0])) puts("err 3.1"); + if (defined(s[1])) puts("err 3.2"); + if (defined(s[2])) puts("err 3.3"); + unless (defined(s[3])) puts("err 3.4"); + if (defined(s[4])) puts("err 3.5"); + unless (defined(s[5])) puts("err 3.6"); + unless (defined(s[6])) puts("err 3.7"); + if (defined(s[7])) puts("err 3.8"); + unless (defined(s[8])) puts("err 3.9"); + for (i = 9; i < 1000; ++i) { + if (defined(s[i])) printf("err 3.10 i=%d\n", i); + } + + unless (defined(s3[0])) puts("err 4.1"); + unless (defined(s3[1])) puts("err 4.2"); + unless (defined(s3[2])) puts("err 4.3"); + for (i = 3; i < 1000; ++i) { + if (defined(s3[i])) printf("err 4.4 i=%d\n", i); + } + + f[3] = 3.0; + f[5] = 5.0; + f[6] = 6.0; + f[8] = 8.0; + if (defined(f[0])) puts("err 5.1"); + if (defined(f[1])) puts("err 5.2"); + if (defined(f[2])) puts("err 5.3"); + unless (defined(f[3])) puts("err 5.4"); + if (defined(f[4])) puts("err 5.5"); + unless (defined(f[5])) puts("err 5.6"); + unless (defined(f[6])) puts("err 5.7"); + if (defined(f[7])) puts("err 5.8"); + unless (defined(f[8])) puts("err 5.9"); + for (i = 9; i < 1000; ++i) { + if (defined(f[i])) printf("err 5.10 i=%d\n", i); + } + + unless (defined(f3[0])) puts("err 5.1"); + unless (defined(f3[1])) puts("err 5.2"); + unless (defined(f3[2])) puts("err 5.3"); + for (i = 3; i < 1000; ++i) { + if (defined(f3[i])) printf("err 5.4 i=%d\n", i); + } + + h{0}[2] = "2"; + if (defined(h{0}[0])) puts("err 6.1"); + if (defined(h{0}[1])) puts("err 6.2"); + unless (defined(h{0}[2])) puts("err 6.3"); + if (defined(h{0}[3])) puts("err 6.4"); +} +#lang tcl +defined_1_3 +} -output "" + +test defined-1.4 {check propagation of undefined values} -body { +#lang L --line=1 +int +d14(int i) +{ + return (i); +} +void +defined_1_4() +{ + int i, j; + int a[]; + + a[1] = 1; // a[0] is now undefined + i = a[0]; // i is now undefined + j = d14(i); // j is now undefined + + if (defined(a[0])) puts("err 1"); + if (defined(i)) puts("err 2"); + if (defined(j)) puts("err 3"); + if (defined(d14(i))) puts("err 4"); + if (defined(d14(j))) puts("err 5"); + if (defined(d14(d14(j)))) puts("err 6"); + if (defined(d14(d14(d14(j))))) puts("err 7"); +} +#lang tcl +defined_1_4 +} -output "" + +test defined-1.5 {check that tcl shimmering does not make undef defined} -body { +#lang L --line=1 +void defined_1_5() +{ + /* + * This tests that the use of the undefined "s" in the printf, + * or the undefined ah[0] in the foreach, does not shimmer the + * shared undef object to something that is defined. This was + * a bug in an earlier implementation of undef. + */ + + string a[], s; + int ah[]{int}, k, v; + + s = a[0]; // s is now undef + + if (defined(s)) puts("bad 1.1"); + printf("s = '%s'\n", s); + if (defined(s)) puts("bad 1.2"); + printf("s = '%s'\n", s); + + if (defined(ah[0])) puts("bad 2.1"); + foreach (k=>v in ah[0]) {} + if (defined(ah[0])) puts("bad 2.2"); + if (defined(s)) puts("bad 1.3"); +} +defined_1_5(); +} -output {s = '' +s = '' +} + +test defined-1.6 {check undef constant} -body { +#lang L --line=1 +string defined_1_6_foo(string arg) +{ + if (arg) { + return (arg); + } else { + return (undef); + } +} +void defined_1_6() +{ + int i; + string s; + + if (defined(undef)) puts("bad 0.1"); + + i = undef; + if (defined(i)) puts("bad 1.1"); + printf("i = '%s'\n", i); + if (defined(i)) puts("bad 1.2"); + + i = 0; + unless (defined(i)) puts("bad 2.1"); + printf("i = '%s'\n", i); + unless (defined(i)) puts("bad 2.2"); + + i = undef; + if (defined(i)) puts("bad 3.1"); + printf("i = '%s'\n", i); + if (defined(i)) puts("bad 3.2"); + + unless (defined(defined_1_6_foo("1"))) puts("bad 4.1"); + if (defined(defined_1_6_foo(s))) puts("bad 4.2"); + if (defined(defined_1_6_foo(undef))) puts("bad 4.3"); +} +defined_1_6(); +} -output {i = '' +i = '0' +i = '' +} + +test defined-1.7 {check attempted assignment to undef} -body { +#lang L --line=1 +void defined_1_7() +{ + undef = 1; + undef += 1; + ++undef; + undef--; + undef =~ s/a/b/; +} +} -returnCodes error -match regexp -result {.*3: L Error: invalid l-value in assignment +.*4: L Error: invalid l-value in assignment +.*5: L Error: invalid l-value in inc/dec +.*6: L Error: invalid l-value in inc/dec +.*7: L Error: invalid l-value in =~ +} + +test defined-1.8 {check attempted declaration of undef} -body { +#lang L --line=1 +void undef() {} +int undef; +void defined_1_8() +{ + int undef; +} +} -returnCodes error -match regexp -result {.*1: L Error: cannot use undef for function name +.*2: L Error: cannot use undef for variable name +.*5: L Error: cannot use undef for variable name +} + +test defined-1.9 {check that undef has type poly} -body { +#lang L --line=1 +class defined_1_9_cls {} +void defined_1_9() +{ + int i; + float f; + string s; + int a[], aa[][]; + int h{int}, hh{int}{int}; + struct { int i,j; } st; + defined_1_9_cls o; + + /* None of these should be type errors. */ + + i = undef; + if (defined(i)) puts("bad 1"); + f = undef; + if (defined(f)) puts("bad 2"); + s = undef; + if (defined(s)) puts("bad 3"); + a = undef; + if (defined(a)) puts("bad 4"); + aa = undef; + if (defined(aa)) puts("bad 5"); + h = undef; + if (defined(h)) puts("bad 6"); + hh = undef; + if (defined(hh)) puts("bad 7"); + st = undef; + if (defined(st)) puts("bad 8"); + o = undef; + if (defined(o)) puts("bad 9"); +} +defined_1_9(); +} -output {} + +test defined-1.10 {check undef as a reference parameter} -body { +#lang L --line=1 +void defined_1_10_foo(int &arg) { arg = 0; } +void defined_1_10() +{ + defined_1_10_foo(&undef); // err +} +defined_1_10(); +} -returnCodes error -match regexp -result {.*4: L Error: illegal operand to & +} + +test defined-1.10.2 {check undef as a reference parameter 2} -setup { + set fname1 [makeFile { + // The docs say this causes a run-time error in foo(). + void foo(string &p) + { + puts(p); + } + void main() + { + foo(undef); + } + } defined-1-10-2-read.l .] + set fname2 [makeFile { + // The docs say this causes a run-time error in foo(). + void foo(string &p) + { + p = "x"; + } + void main() + { + foo(undef); + } + } defined-1-10-2-write.l .] +} -body { +#lang L +void defined_1_10_2() +{ + int ret; + string err[]; + string tclsh = interpreter(); + + ret = system({tclsh, "defined-1-10-2-read.l"}, undef, undef, &err); + unless (ret) puts("bad 1"); + + ret = system({tclsh, "defined-1-10-2-write.l"}, undef, undef, &err); + unless (ret) puts("bad 2"); +} +defined_1_10_2(); +} -output {} + +test defined-1.11 {check that assignment to part of an obj makes it defined} -body { +#lang L --line=1 +void defined_1_11() +{ + string s; + string a[]; + string aa[][]; + string h{string}; + string hh{string}{string}; + + if (defined(s)) puts("bad 1.1"); + s[0] = "x"; + unless (defined(s)) puts("bad 1.2"); + + if (defined(a)) puts("bad 2.1"); + a[0] = "x"; + unless (defined(a)) puts("bad 2.2"); + + if (defined(aa)) puts("bad 3.1"); + a[0][0] = "x"; + unless (defined(a)) puts("bad 3.2"); + unless (defined(a[0])) puts("bad 3.3"); + + if (defined(h)) puts("bad 4.1"); + h{"k"} = "v"; + unless (defined(h)) puts("bad 4.2"); + + if (defined(hh)) puts("bad 5.1"); + hh{"k1"}{"k2"} = "v"; + unless (defined(hh)) puts("bad 5.2"); + unless (defined(hh{"k1"})) puts("bad 5.3"); +} +defined_1_11(); +} -output {} + +test defined-1.12 {check defined(&var)} -body { +#lang L --line=1 -nowarn +string def1_12_g1 = "global1"; +string def1_12_g2 = "global2"; +string def1_12_g3 = "global3"; + +// The args are all named differently on purpose. +string def1_12_f1(string &a1) +{ + return ((string)defined(&a1)); +} +string def1_12_f2(string &a2, string &b2) +{ + return ((string)defined(&a2) . (string)defined(&b2)); +} +string def1_12_f3(string &a3, string &b3, string &c3) +{ + return ((string)defined(&a3) . (string)defined(&b3) . + (string)defined(&c3)); +} +string def1_12_ff(string &a4, string &b4) +{ + return (def1_12_f1(&a4) . def1_12_f1(&b4)); +} +void defined_1_12() +{ + string a, b, c; + + unless (def1_12_f1(&a) eq "1") puts("bad 1.1"); + unless (def1_12_f1(undef) eq "0") puts("bad 1.2"); + + unless (def1_12_f2(&a, &b) eq "11") puts("bad 2.1"); + unless (def1_12_f2(undef, &b) eq "01") puts("bad 2.2"); + unless (def1_12_f2(&a, undef) eq "10") puts("bad 2.3"); + unless (def1_12_f2(undef, undef) eq "00") puts("bad 2.4"); + + unless (def1_12_f3(&a, &b, &c) eq "111") puts("bad 3.1"); + unless (def1_12_f3(undef, &b, &c) eq "011") puts("bad 3.2"); + unless (def1_12_f3(&a, undef, &c) eq "101") puts("bad 3.3"); + unless (def1_12_f3(&a, &b, undef) eq "110") puts("bad 3.4"); + unless (def1_12_f3(undef, &b, undef) eq "010") puts("bad 3.5"); + unless (def1_12_f3(undef, undef, &a) eq "001") puts("bad 3.6"); + unless (def1_12_f3(&a, undef, undef) eq "100") puts("bad 3.7"); + unless (def1_12_f3(undef, undef, undef) eq "000") puts("bad 3.8"); + + unless (def1_12_ff(&a, &b) eq "11") puts("bad 4.1"); + unless (def1_12_ff(undef, &b) eq "01") puts("bad 4.2"); + unless (def1_12_ff(&a, undef) eq "10") puts("bad 4.3"); + unless (def1_12_ff(undef, undef) eq "00") puts("bad 4.4"); + + unless (def1_12_f1(&def1_12_g1) eq "1") puts("bad 5.1"); + unless (def1_12_f2(&def1_12_g1, &def1_12_g2) eq "11") puts("bad 5.2"); + unless (def1_12_f3(&def1_12_g1, &def1_12_g2, &def1_12_g3) eq "111") { + puts("bad 5.2"); + } +} +defined_1_12(); +} -output {} + +test defined-1.13 {check errors with defined(&var)} -body { +#lang L --line=1 -nowarn +private string not_a_ref_parm1; +string not_a_ref_parm2; +class def_1_13_cls +{ + public string not_a_ref_parm3; + instance { + public string not_a_ref_parm4; + } +} +void defined_1_13() +{ + string not_a_ref_parm5; + def_1_13_cls obj = def_1_13_cls_new(); + + defined(¬_declared); + defined(¬_a_ref_parm1); + defined(¬_a_ref_parm2); + defined(&def_1_13_cls->not_a_ref_parm3); + defined(&obj->not_a_ref_parm4); + defined(¬_a_ref_parm5); + defined(&defined_1_13); // fn ptr + defined(&3); +} +defined_1_13(); +} -returnCodes error -match regexp -result {.*15: L Error:.*not a call-by-reference parm +.*16: L Error:.*not a call-by-reference parm +.*17: L Error:.*not a call-by-reference parm +.*18: L Error:.*not a call-by-reference parm +.*19: L Error:.*not a call-by-reference parm +.*20: L Error:.*not a call-by-reference parm +.*21: L Error:.*not a call-by-reference parm +.*22: L Error:.*not a call-by-reference parm +} + +test defined-1.14 {check that undef is false} -body { +#lang L --line=1 +string defined_1_14fn(_argused string &s) +{ + if (&s) { + return ("def"); + } else { + return ("undef"); + } +} +void defined_1_14() +{ + int i; + string s; + string a[]; + string h{string}; + struct { int i; int j; } st; + poly p; + + if (undef) puts("bad 1"); + if (i) puts("bad 2"); + if (s) puts("bad 3"); + if (p) puts("bad 4.1"); + if (a) puts("bad 4.2"); + if (h) puts("bad 4.3"); + if (st) puts("bad 4.4"); + unless (defined_1_14fn(&s) eq "def") puts("bad 4.5"); + unless (defined_1_14fn(undef) eq "undef") puts("bad 4.6"); + + /* Check that Tcl code does the same thing. */ + eval('if {$i} {puts "bad 5"}'); + eval('if {$s} {puts "bad 6"}'); + eval('if {$p} {puts "bad 7"}'); + eval('if {$a} {puts "bad 8"}'); + eval('if {$h} {puts "bad 8"}'); + eval('if {$st} {puts "bad 10"}'); +} +defined_1_14(); +} -output {} + +test defined-1.15 {check that undef != anything defined} -body { +#lang L --line=1 +void defined_1_15() +{ + int i; + string s; + poly p; + + if (defined(i) || defined(s) || defined(p)) puts("bad"); + + if (i == 0) puts("bad 1.1"); + unless (i != 0) puts("bad 1.2"); + + if (s eq "") puts("bad 2.1"); + unless (s ne "") puts("bad 2.2"); + + if (p eq "") puts("bad 3.1"); + unless (p ne "") puts("bad 3.2"); + + /* + * An L regexp compiles down to different opcodes depending on the + * complexity of the regexp, so test each. + */ + if (s =~ /^$/) puts("bad 4.1"); // constant (INST_STR_EQ) + if (s =~ /.*/) puts("bad 4.2"); // glob (INST_STR_MATCH) + if (s =~ /x*/) puts("bad 4.2"); // non-glob re (INST_REGEXP) + if (s =~ //g) puts("bad 4.3"); // complex (::regexp cmd) + + /* Check that Tcl code does the same thing. */ + eval('if {$i == 0} {puts "bad 5.1"}'); + eval('if {$s == ""} {puts "bad 5.2"}'); +} +defined_1_15(); +} -output {} + +test defined-1.16 {check calling defined proc from Tcl code} -body { +#lang L +void defined_1_16() +{ + string d = "this is defined"; + string u; // this is not + + if (defined(u)) puts("bad 1.1"); + eval('if [defined $u] {puts "bad 1.2"}'); + + unless (defined(d)) puts("bad 2.1"); + eval('if ![defined $d] {puts "bad 2.2"}'); +} +defined_1_16(); +} -output {} + +test undef-1 {check undef built-in} -body { +#lang L --line=1 +void undef_1() +{ + string s; + string a[], a2[]; + string h{string}, h2{string}; + + h = { "k1"=>"v1", "k2"=>"v2", "k3"=>"v3" }; + h2 = h; + undef(h{"k1"}); + unless (length(h) == 2) puts("bad 1.1"); + unless ((h{"k2"} eq "v2") && (h{"k3"} eq "v3")) puts("bad 1.2"); + undef(h{"k2"}); + unless (length(h) == 1) puts("bad 1.3"); + unless (h{"k3"} eq "v3") puts("bad 1.4"); + undef(h{"k3"}); + unless (length(h) == 0) puts("bad 1.5"); + unless (defined(h)) puts("bad 1.6"); + + /* Make sure deleting from h didn't affect a copy of h. */ + unless (length(h2) == 3) puts("bad 2.1"); + unless ((h2{"k1"} eq "v1") && (h2{"k2"} eq "v2")) puts("bad 2.2"); + unless (h2{"k3"} eq "v3") puts("bad 2.3"); + + /* + * Deleting a non-existent hash element is legal. Deep-dive + * semantics says to create the element, then it gets deleted. + */ + h = {}; + undef(h{"not_here"}); + unless (length(h) == 0) puts("bad 3.1"); + unless (defined(h)) puts("bad 3.2"); + + a = { "1", "2", "3" }; + a2 = a; + undef(a[0]); + unless (length(a) == 2) puts("bad 4.1"); + unless ((a[0] eq "2") && (a[1] eq "3")) puts("bad 4.2"); + undef(a[0]); + unless (length(a) == 1) puts("bad 4.3"); + unless (a[0] eq "3") puts("bad 4.4"); + undef(a[0]); + unless (length(a) == 0) puts("bad 4.5"); + unless (defined(a)) puts("bad 4.6"); + + /* Make sure deleting from "a" didn't affect a copy of "a". */ + unless (length(a2) == 3) puts("bad 5.1"); + unless ((a2[0] eq "1") && (a2[1] eq "2")) puts("bad 5.2"); + unless (a2[2] eq "3") puts("bad 5.3"); + + /* + * Deleting a non-existent array element is legal. Deep-dive + * semantics says to create the element (AND all before it), + * then it gets deleted but all the elements before it remain. + */ + a = {}; + undef(a[3]); + unless (length(a) == 3) puts("bad 6.1"); + unless (defined(a)) puts("bad 6.2"); + if (defined(a[0]) || defined(a[1]) || defined(a[2])) puts("bad 6.3"); + + s = "0123456789"; + undef(s[0]); + unless (s eq "123456789") puts("bad 10.1"); + undef(s[1]); + unless (s eq "13456789") puts("bad 10.2"); + undef(s[7]); + unless (s eq "1345678") puts("bad 10.3"); + + /* undef(var) is like var=undef. */ + s = "testing"; + undef(s); + if (defined(s)) puts("bad 20.1"); +} +undef_1(); +} -output {} + +test undef-2 {check undef built-in on nested arrays and hashes} -body { +#lang L --line=1 +void undef_2() +{ + int a[][] = { {1,2,3}, {4,5,6}, {7,8,9} }; + int h{int}{int} = { + 1 => { 10=>10, 20=>20, 30=>30 }, + 2 => { 10=>10, 20=>20, 30=>30 }, + 3 => { 10=>10, 20=>20, 30=>30 }, + }; + + undef(h{2}); + unless (length(h) == 2) puts("bad 1.1"); + + undef(h{1}{20}); + unless (length(h{1}) == 2) puts("bad 2.1"); + unless ((h{1}{10} == 10) && (h{1}{30} == 30)) puts("bad 2.2"); + undef(h{1}{10}); + unless (length(h{1}) == 1) puts("bad 2.3"); + unless (h{1}{30} == 30) puts("bad 2.4"); + undef(h{1}{30}); + unless (length(h{1}) == 0) puts("bad 2.5"); + + unless (length(h) == 2) puts("bad 3.1"); + undef(h{1}); + unless (length(h) == 1) puts("bad 3.3"); + unless (length(h{3}) == 3) puts("bad 3.4"); + + undef(a[1]); + unless (length(a) == 2) puts("bad 4.1"); + unless (length(a[0]) == 3) puts("bad 4.2"); + unless (length(a[1]) == 3) puts("bad 4.3"); + unless ((a[0][0] == 1) && (a[0][1] == 2)) puts("bad 4.4"); + unless (a[0][2] == 3) puts("bad 4.5"); + + undef(a[1][1]); + unless (length(a[1]) == 2) puts("bad 5.1"); + unless ((a[1][0] == 7) && (a[1][1] == 9)) puts("bad 5.2"); + + undef(a[0]); + unless (length(a) == 1) puts("bad 6.1"); + unless (length(a[0]) == 2) puts("bad 6.2"); + undef(a[0]); + unless (length(a) == 0) puts("bad 6.3"); +} +undef_2(); +} -output {} + +test undef-3 {check undef built-in on class variables} -body { +#lang L --line=1 +class undef_3_cls { + public string hcls{string}; + public string acls[]; + public string scls; + instance { + public string hins{string}; + public string ains[]; + public string sins; + } +} +void undef_3() +{ + undef_3_cls obj = undef_3_cls_new(); + + undef_3_cls->hcls = { "k1"=>"v1", "k2"=>"v2", "k3"=>"v3" }; + undef(undef_3_cls->hcls{"k1"}); + unless (length(undef_3_cls->hcls) == 2) puts("bad 1.1"); + unless (undef_3_cls->hcls{"k2"} eq "v2") puts("bad 1.2"); + unless (undef_3_cls->hcls{"k3"} eq "v3") puts("bad 1.3"); + undef(undef_3_cls->hcls{"k2"}); + unless (length(undef_3_cls->hcls) == 1) puts("bad 1.4"); + unless (undef_3_cls->hcls{"k3"} eq "v3") puts("bad 1.5"); + undef(undef_3_cls->hcls{"k3"}); + unless (length(undef_3_cls->hcls) == 0) puts("bad 1.6"); + unless (defined(undef_3_cls->hcls)) puts("bad 1.7"); + + undef_3_cls->acls = { "1", "2", "3" }; + undef(undef_3_cls->acls[0]); + unless (length(undef_3_cls->acls) == 2) puts("bad 2.1"); + unless (undef_3_cls->acls[0] eq "2") puts("bad 2.2"); + unless (undef_3_cls->acls[1] eq "3") puts("bad 2.3"); + undef(undef_3_cls->acls[0]); + unless (length(undef_3_cls->acls) == 1) puts("bad 2.4"); + unless (undef_3_cls->acls[0] eq "3") puts("bad 2.5"); + undef(undef_3_cls->acls[0]); + unless (length(undef_3_cls->acls) == 0) puts("bad 2.6"); + unless (defined(undef_3_cls->acls)) puts("bad 2.7"); + + obj->hins = { "k1"=>"v1", "k2"=>"v2", "k3"=>"v3" }; + undef(obj->hins{"k1"}); + unless (length(obj->hins) == 2) puts("bad 3.1"); + unless (obj->hins{"k2"} eq "v2") puts("bad 3.2"); + unless (obj->hins{"k3"} eq "v3") puts("bad 3.3"); + undef(obj->hins{"k2"}); + unless (length(obj->hins) == 1) puts("bad 3.4"); + unless (obj->hins{"k3"} eq "v3") puts("bad 3.5"); + undef(obj->hins{"k3"}); + unless (length(obj->hins) == 0) puts("bad 3.6"); + unless (defined(obj->hins)) puts("bad 3.7"); + + obj->ains = { "1", "2", "3" }; + undef(obj->ains[0]); + unless (length(obj->ains) == 2) puts("bad 4.1"); + unless (obj->ains[0] eq "2") puts("bad 4.2"); + unless (obj->ains[1] eq "3") puts("bad 4.3"); + undef(obj->ains[0]); + unless (length(obj->ains) == 1) puts("bad 4.4"); + unless (obj->ains[0] eq "3") puts("bad 4.5"); + undef(obj->ains[0]); + unless (length(obj->ains) == 0) puts("bad 4.6"); + unless (defined(obj->ains)) puts("bad 4.7"); + + undef_3_cls->scls = "testing"; + undef(undef_3_cls->scls); + if (defined(undef_3_cls->scls)) puts("bad 5.1"); + + obj->sins = "testing"; + undef(obj->sins); + if (defined(obj->sins)) puts("bad 6.1"); +} +undef_3(); +} -output {} + +test undef-4 {check undef built-in errors} -body { +#lang L --line=1 +private string[] foo() { return {"x"}; } +void undef_4() +{ + string a[]; + struct { int i,j; } st; + + undef(); + undef(a[0], a[1]); + undef(a[1..3]); + undef(foo()); + undef(st.i); + undef(3); +} +undef_4(); +} -returnCodes error -match regexp -result {.*7: L Error: incorrect # args to undef +.*8: L Error: incorrect # args to undef +.*9: L Error: illegal l-value in undef\(\) +.*10: L Error: illegal l-value in undef\(\) +.*11: L Error: cannot undef\(\) a struct field +.*12: L Error: illegal l-value in undef\(\) +} + +test undef-5 {check that undefined list goes to defined} -body { +#lang L --line=1 +void undef_5() +{ + string a[] = {"x"}; + + a = undef; + if (defined(a)) puts("bad 1.1"); + a[END+1] = "x"; + unless (defined(a)) puts("bad 1.2"); + + a = undef; + if (defined(a)) puts("bad 2.1"); + push(&a, "x"); + unless (defined(a)) puts("bad 2.2"); + + a = undef; + if (defined(a)) puts("bad 3.1"); + a[0] = "x"; + unless (defined(a)) puts("bad 3.2"); + + a = undef; + if (defined(a)) puts("bad 4.1"); + a[10] = "x"; + unless (defined(a)) puts("bad 4.2"); + + a = undef; + if (defined(a)) puts("bad 5.1"); + push(&a, {"x","y"}); + unless (defined(a)) puts("bad 5.2"); +} +undef_5(); +} -output {} + +test undef-6 {check comparison errors against undef} -body { +#lang L --line=1 +void undef_6() +{ + int i; + string s; + + i == undef; // line 6 + i != undef; + i <= undef; + i < undef; + i >= undef; + i > undef; + undef == i; + undef != i; + undef <= i; + undef < i; + undef >= i; + undef > i; // line 17 + + s eq undef; // line 19 + s ne undef; + s le undef; + s lt undef; + s ge undef; + s gt undef; + undef eq s; + undef ne s; + undef le s; + undef lt s; + undef ge s; + undef gt s; // line 30 + + undef == undef; // line 32 + undef != undef; + undef <= undef; + undef < undef; + undef >= undef; + undef > undef; + undef eq undef; + undef ne undef; + undef le undef; + undef lt undef; + undef ge undef; + undef gt undef; // line 43 +} +} -returnCodes error -match regexp -result {.*6: L Error: undef illegal in comparison +.*7: L Error: undef illegal in comparison +.*8: L Error: undef illegal in comparison +.*9: L Error: undef illegal in comparison +.*10: L Error: undef illegal in comparison +.*11: L Error: undef illegal in comparison +.*12: L Error: undef illegal in comparison +.*13: L Error: undef illegal in comparison +.*14: L Error: undef illegal in comparison +.*15: L Error: undef illegal in comparison +.*16: L Error: undef illegal in comparison +.*17: L Error: undef illegal in comparison +.*19: L Error: undef illegal in comparison +.*20: L Error: undef illegal in comparison +.*21: L Error: undef illegal in comparison +.*22: L Error: undef illegal in comparison +.*23: L Error: undef illegal in comparison +.*24: L Error: undef illegal in comparison +.*25: L Error: undef illegal in comparison +.*26: L Error: undef illegal in comparison +.*27: L Error: undef illegal in comparison +.*28: L Error: undef illegal in comparison +.*29: L Error: undef illegal in comparison +.*30: L Error: undef illegal in comparison +.*32: L Error: undef illegal in comparison +.*33: L Error: undef illegal in comparison +.*34: L Error: undef illegal in comparison +.*35: L Error: undef illegal in comparison +.*36: L Error: undef illegal in comparison +.*37: L Error: undef illegal in comparison +.*38: L Error: undef illegal in comparison +.*39: L Error: undef illegal in comparison +.*40: L Error: undef illegal in comparison +.*41: L Error: undef illegal in comparison +.*42: L Error: undef illegal in comparison +.*43: L Error: undef illegal in comparison +} + +test undef-7 {check for bug with undef object ref count} -body { +#lang L --line=1 +void undef_7() +{ + string a[]; + + /* + * This used to trip a bug in undef (and assert or core dump) + * where the undef object's ref count would be reset to 1234 + * in Lcompile.c every time a reference to the undef object + * was given out. If undef propagated more than this # of + * times, the wheels could fall off while freeing an object + * that had these undefs in it. + */ + + // This creates 3000 Tcl_Obj's that point to undef, and when + // they are added to the array, the undef ref count is + // incremented as expected. + a[3000] = ""; + + // Now create one more ref to undef (when it is pushed onto + // the Tcl run-time stack). This used to reset the ref count + // back to 1234, then when the locals were freed which includes + // the 3000 undefs above, we used to assert or core dump. + undef; +} +undef_7(); +} -output {} + +test undef-8 {check for another bug with undef object ref count} -body { +#lang L --line=1 +#pragma nowarn +void undef_8() +{ + int iters = 100; + int a[], aft, bef, h{int}, i, j, x, y; + string s; + FILE f; + + /* + * These check for an old bug where the undef object's ref + * count would continually grow until it eventually + * overflowed. Here we check that various operations which + * should create and then drop a reference to undef don't grow + * the ref count. + */ + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + {x,y} = {i}; // uses INST_L_LINDEX_STK bytecode + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 1 composite assign ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + a[0] = 0; // grows array w/undef + undef(a); + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 2 a[] write ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + a[0]; // read of undefined array element + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 3 a[] read ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + pop(&a); // elt delete on empty array + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 5 pop(&a) ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + ((hash){i}){0}; // hash read of non-hash + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 6 not-a-hash{idx} ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + h{0}; // hash read of undef element + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 7 h{} ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + s[0]; // string index of undef string + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 8 undef_string[] ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + "s"[2]; // string index beyond end of string + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 9 string[beyond] ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + undef; // puts undef on run-time stack + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 10 undef ${bef} -> ${aft}"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + getopt({}, "", {}); // getopt returns undef + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 11 getopt ${bef} -> ${aft}"); + + f = fopen("tst", "w"); + puts(f, "testing"); + fclose(f); + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + f = fopen("tst", "r"); + while (<f>) ; // returns undef on EOF + fclose(f); + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 12 <f> ${bef} -> ${aft}"); + unlink("tst"); + + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + fgetline("bad channel"); // returns undef + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 13 fgetline ${bef} -> ${aft}"); + + /* + * This one can't be tested here unless we spawn another tclsh + * since it eats args from the cmd line and messes up tcltest. + */ + /* + bef = Lrefcnt(undef); + for (i = 0; i < iters; ++i) { + <>; + } + aft = Lrefcnt(undef); + if (aft > bef) puts("bad 14 <> ${bef} -> ${aft}"); + */ + +} +undef_8(); +} -output {} + +test undef-9 {test read of an undef ref parm} -body { +#lang L +void undef_9f(string &arg) +{ + puts(arg); +} +void undef_9() +{ + undef_9f(undef); +} +undef_9(); +} -returnCodes error -match regexp -result {undefined reference parameter read} + +test undef-10 {test write of an undef ref parm} -body { +#lang L +void undef_10f(string &arg) +{ + arg = "bad"; +} +void undef_10() +{ + undef_10f(undef); +} +undef_10(); +} -returnCodes error -match regexp -result {undefined reference parameter written} + +test undef-11 {test read of an _optional undef ref parm} -body { +#lang L +void undef_11f(_optional string &arg) +{ + puts(arg); +} +void undef_11() +{ + undef_11f(); +} +undef_11(); +} -returnCodes error -match regexp -result {undefined reference parameter read} + +test undef-12 {test write of an _optional undef ref parm} -body { +#lang L +void undef_12f(_optional string &arg) +{ + arg = "bad"; +} +void undef_12() +{ + undef_12f(); +} +undef_12(); +} -returnCodes error -match regexp -result {undefined reference parameter written} + +test undef-13 {test definedness tests on ref parm} -body { +#lang L +string undef_13f(string &arg) +{ + string ret; + + ret = (string)defined(&arg); + if (defined(&arg)) ret .= (string)defined(arg); + + return (ret); +} +string undef_13opt(_optional string &arg) +{ + string ret; + + ret = (string)defined(&arg); + if (defined(&arg)) ret .= (string)defined(arg); + + return (ret); +} +void undef_13() +{ + string p; + + unless (undef_13f(undef) == "0") puts("bad 1.1"); + unless (undef_13f(&p) == "10") puts("bad 1.2"); + p = "ok"; + unless (undef_13f(&p) == "11") puts("bad 1.3"); + + p = undef; + unless (undef_13opt() == "0") puts("bad 2.0"); + unless (undef_13opt(undef) == "0") puts("bad 2.1"); + unless (undef_13opt(&p) == "10") puts("bad 2.2"); + p = "ok"; + unless (undef_13opt(&p) == "11") puts("bad 2.3"); +} +undef_13(); +} -output {} + +test undef-14 {test definedness tests on function-pointer parm} -body { +#lang L +/* + * Although function-pointer args look like ref parms because they + * have a &, they are not references and the rules for defined() + * tests are different. You cannot say defined(&arg). + */ +string undef_14foo() { return ("x"); } +string undef_14f(string &arg()) +{ + return ((string)defined(arg)); +} +string undef_14opt(_optional string &arg()) +{ + return ((string)defined(arg)); +} +void undef_14() +{ + unless (undef_14f(undef) == "0") puts("bad 1.1"); + unless (undef_14f(&undef_14foo) == "1") puts("bad 1.2"); + + unless (undef_14opt() == "0") puts("bad 2.1"); + unless (undef_14opt(undef) == "0") puts("bad 2.2"); + unless (undef_14opt(&undef_14foo) == "1") puts("bad 2.3"); +} +undef_14(); +} -output {} + +test toplevel-1.0 {Toplevel code in L} -body { +#lang L --line=1 +int toplevel_1_0_i = 2; +printf("at the toplevel, i is: %d\n", toplevel_1_0_i); + +void toplevel_1_0(void) { + printf("in toplevel_1_0, i is: %d\n", toplevel_1_0_i); +} +#lang tcl +toplevel_1_0 +} -output {at the toplevel, i is: 2 +in toplevel_1_0, i is: 2 +} + +test toplevel-1.1 {Toplevel code via the L command, sharing variables} -body { +L { puts("Accent on helpful side of your nature. Drain the moat."); } +proc toplevel_1_1 {} { + set toplevel_1_1_v 2 + L { + string toplevel_1_1_v = "Sphenic numbers always have exactly " + "eight divisors."; + } + puts $toplevel_1_1_v +} +toplevel_1_1 +} -output {Accent on helpful side of your nature. Drain the moat. +2 +} + +test typecheck-1.0 {L typechecking} -body { +#lang L --line=1 +string typecheck_1_0_foo() { + return "string"; +} + +void typecheck_1_0() { + puts(typecheck_1_0_foo() + 22); +} +#lang tcl +typecheck_1_0 +} -returnCodes {error} -match glob \ +-result "*:6: L Error: expected type int or float but got string*\n" + +test typecheck-1.1 {arity check} -body { +#lang L --line=1 -nowarn +void typecheck_1_1_foo() {} +void typecheck_1_1_bar(int a, int b) {} +void typecheck_1_1() { + typecheck_1_1_foo(1, 2, 3); + typecheck_1_1_bar(); +} +#lang tcl +} -returnCodes {error} -match glob \ +-result "*:4: L Error: too many arguments for function typecheck_1_1_foo +*:5: L Error: not enough arguments for function typecheck_1_1_bar\n" + +test typecheck-1.2 {check functions returning int arrays of arrays} -body { +#lang L --line=1 +int[] +typecheck_1_2_int() +{ + int i, a[3]; + + for (i = 0; i < 3; ++i) { + a[i] = i; + } + return a; +} +int[][] +typecheck_1_2_int_int() +{ + int i, j, a[3][4]; + + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + a[i][j] = 10*i + j; + } + } + return a; +} +int[][][] +typecheck_1_2_int_int_int() +{ + int i, j, k, a[3][4][5]; + + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + for (k = 0; k < 5; ++k) { + a[i][j][k] = 100*i + 10*j + k; + } + } + } + return a; +} +void +typecheck_1_2() +{ + int i, j, k; + int one[3]; + int two[3][4]; + int three[3][4][5]; + + one = typecheck_1_2_int(); + two = typecheck_1_2_int_int(); + three = typecheck_1_2_int_int_int(); + + for (i = 0; i < 3; ++i) { + unless (one[i] == i) { + printf("one: i=%d bad\n", i); + } + } + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + unless (two[i][j] == (10*i + j)) { + printf("two: i=%d j=%d bad\n", i, j); + } + } + } + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + for (k = 0; k < 5; ++k) { + unless (three[i][j][k] == (100*i + 10*j + k)) { + printf("three: i=%d j=%d k=%d bad\n", + i, j, k); + } + } + } + } +} +typecheck_1_2(); +} -output {} + +test typecheck-1.3 {check functions returning float arrays of arrays} -body { +#lang L --line=1 +float[] +typecheck_1_3_float() +{ + int i; + float a[3]; + + for (i = 0; i < 3; ++i) { + a[i] = i; + } + return a; +} +float[][] +typecheck_1_3_float_float() +{ + int i, j; + float a[3][4]; + + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + a[i][j] = 10.0*i + j; + } + } + return a; +} +float[][][] +typecheck_1_3_float_float_float() +{ + int i, j, k; + float a[3][4][5]; + + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + for (k = 0; k < 5; ++k) { + a[i][j][k] = 100.0*i + 10.0*j + k; + } + } + } + return a; +} +void +typecheck_1_3() +{ + int i, j, k; + float one[3]; + float two[3][4]; + float three[3][4][5]; + + one = typecheck_1_3_float(); + two = typecheck_1_3_float_float(); + three = typecheck_1_3_float_float_float(); + + /* + * Although testing equality of floats is usually unwise, + * there should be sufficient precision in this case to make + * the comparisons true when they should be. + */ + for (i = 0; i < 3; ++i) { + unless (one[i] == i) { + printf("one: i=%d bad\n", i); + } + } + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + unless (two[i][j] == (10.0*i + j)) { + printf("two: i=%d j=%d bad\n", i, j); + } + } + } + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + for (k = 0; k < 5; ++k) { + unless (three[i][j][k] == (100.0*i+10.0*j+k)) { + printf("three: i=%d j=%d k=%d bad\n", + i, j, k); + } + } + } + } +} +typecheck_1_3(); +} -output {} + +test typecheck-1.4 {check functions returning string arrays of arrays} -body { +#lang L --line=1 +string[] +typecheck_1_4_string() +{ + int i; + string a[3]; + + for (i = 0; i < 3; ++i) { + a[i] = "${i}"; + } + return a; +} +string[][] +typecheck_1_4_string_string() +{ + int i, j; + string a[3][4]; + + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + a[i][j] = "${i}:${j}"; + } + } + return a; +} +string[][][] +typecheck_1_4_string_string_string() +{ + int i, j, k; + string a[3][4][5]; + + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + for (k = 0; k < 5; ++k) { + a[i][j][k] = "${i}:${j}:${k}"; + } + } + } + return a; +} +void +typecheck_1_4() +{ + int i, j, k; + string one[3]; + string two[3][4]; + string three[3][4][5]; + + one = typecheck_1_4_string(); + two = typecheck_1_4_string_string(); + three = typecheck_1_4_string_string_string(); + + for (i = 0; i < 3; ++i) { + unless (one[i] eq "${i}") { + printf("one: i=%d bad\n", i); + } + } + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + unless (two[i][j] eq "${i}:${j}") { + printf("two: i=%d j=%d bad\n", i, j); + } + } + } + for (i = 0; i < 3; ++i) { + for (j = 0; j < 4; ++j) { + for (k = 0; k < 5; ++k) { + unless (three[i][j][k] eq "${i}:${j}:${k}") { + printf("three: i=%d j=%d k=%d bad\n", + i, j, k); + } + } + } + } +} +typecheck_1_4(); +} -output {} + +test typecheck-1.5 {check functions returning void arrays are illegal} -body { +#lang L --line=1 +void[] typecheck_1_5() { return; } +} -returnCodes error -match regexp -result {.*1: L Error: type void illegal.* +} + +test typecheck-2.1 {check int-to-float casts and coercions} -body { +#lang L --line=1 +float +typecheck_2_1_return_float(float f) +{ + return f; +} + +float +typecheck_2_1_sum_three_floats(float f1, float f2, float f3) +{ + return f1 + f2 + f3; +} + +void +typecheck_2_1() +{ + /* + * Exact comparisons with floats must be done with care. Keep + * the precision of the numbers low so there is sufficient + * precision for the variable comparisons to be true when + * intended. + */ + + /* Test initializers and all comparison ops that allow floats. */ + + int i1 = 1964; + int i2 = 0; + float f1 = i1; + float f2 = 0.0; + + unless (f1 == 1964) puts("BAD 1.1.1"); + unless (1964 == f1) puts("BAD 1.1.2"); + unless (f1 == 1964.0) puts("BAD 1.1.3"); + unless (1964.0 == f1) puts("BAD 1.1.4"); + unless (f1 == (float)1964) puts("BAD 1.1.5"); + unless ((float)1964 == f1) puts("BAD 1.1.6"); + unless (f1 == (float)i1) puts("BAD 1.1.7"); + unless ((float)i1 == f1) puts("BAD 1.1.8"); + unless (f1 == i1) puts("BAD 1.1.9"); + unless (i1 == f1) puts("BAD 1.1.10"); + + unless (f1 >= 1964) puts("BAD 1.2.1"); + unless (1964 >= f1) puts("BAD 1.2.2"); + unless (f1 >= 1964.0) puts("BAD 1.2.3"); + unless (1964.0 >= f1) puts("BAD 1.2.4"); + unless (f1 >= (float)1964) puts("BAD 1.2.5"); + unless ((float)1964 >= f1) puts("BAD 1.2.6"); + unless (f1 >= (float)i1) puts("BAD 1.2.7"); + unless ((float)i1 >= f1) puts("BAD 1.2.8"); + unless (f1 >= i1) puts("BAD 1.2.9"); + unless (i1 >= f1) puts("BAD 1.2.10"); + + unless (f1 <= 1964) puts("BAD 1.3.1"); + unless (1964 <= f1) puts("BAD 1.3.2"); + unless (f1 <= 1964.0) puts("BAD 1.3.3"); + unless (1964.0 <= f1) puts("BAD 1.3.4"); + unless (f1 <= (float)1964) puts("BAD 1.3.5"); + unless ((float)1964 <= f1) puts("BAD 1.3.6"); + unless (f1 <= (float)i1) puts("BAD 1.3.7"); + unless ((float)i1 <= f1) puts("BAD 1.3.8"); + unless (f1 <= i1) puts("BAD 1.3.9"); + unless (i1 <= f1) puts("BAD 1.3.10"); + + unless (f1 != 1999) puts("BAD 1.4.1"); + unless (1999 != f1) puts("BAD 1.4.2"); + unless (f1 != 1999.0) puts("BAD 1.4.3"); + unless (1999.0 != f1) puts("BAD 1.4.4"); + unless (f1 != (float)1999) puts("BAD 1.4.5"); + unless ((float)1999 != f1) puts("BAD 1.4.6"); + unless (f1 != (float)i2) puts("BAD 1.4.7"); + unless ((float)i2 != f1) puts("BAD 1.4.8"); + unless (f1 != i2) puts("BAD 1.4.9"); + unless (i2 != f1) puts("BAD 1.4.10"); + + /* Test assignments and all binary ops that allow floats. */ + + i2 = 1965; + f2 = i2; + unless (f2 == 1965.0) puts("BAD 2.1"); + + f2 = f2 + 1; + unless (f2 == 1966.0) puts("BAD 2.2"); + + f2 = f2 - 2; + unless (f2 == 1964.0) puts("BAD 2.3"); + + f2 = f2 / 2; + unless (f2 == 982.0) puts("BAD 2.4"); + + f2 = f2 * 2; + unless (f2 == 1964.0) puts("BAD 2.5"); + + f2 = i2; + f2 = 1 + f2; + unless (f2 == 1966.0) puts("BAD 3.1"); + + f2 = -2 + f2; + unless (f2 == 1964.0) puts("BAD 3.2"); + + f2 = f2 / 2; + unless (f2 == 982.0) puts("BAD 3.3"); + + f2 = 2; + f2 = 2 / f2; + unless (f2 == 1.0) puts("BAD 3.4"); + + i2 = 1965; + f2 = i2; + f2 += 1; + unless (f2 == 1966.0) puts("BAD 4.1"); + + f2 -= 2; + unless (f2 == 1964.0) puts("BAD 4.2"); + + f2 /= 2; + unless (f2 == 982.0) puts("BAD 4.3"); + + f2 *= 2; + unless (f2 == 1964.0) puts("BAD 4.4"); + + /* Test that int actuals coerce to a float when the formal is a float. */ + + f2 = typecheck_2_1_return_float(1); + unless (f2 == 1.0) puts("BAD 5.1"); + + i2 = 3; + f2 = typecheck_2_1_return_float(i2); + unless (f2 == 3.0) puts("BAD 5.2"); + + f2 = typecheck_2_1_sum_three_floats(1, 2, 3); + unless (f2 = 6.0) puts("BAD 5.3"); + + i1 = 1; + i2 = 3; + f2 = typecheck_2_1_sum_three_floats(i1, i2, 3); + unless (f2 = 6.0) puts("BAD 5.4"); +} +typecheck_2_1(); +} -output "" + +test typecheck-3.1 {void illegal in if-stmt conditional} -body { +#lang L --line=1 +void typecheck_3_1_v() { return; } +void +typecheck_3_1() +{ + if (typecheck_3_1_v()) return; +} +} -returnCodes error -match regexp -result {void type illegal in predicate} + +test typecheck-3.2 {void illegal in unless-stmt conditional} -body { +#lang L --line=1 +void typecheck_3_2_v() { return; } +void +typecheck_3_2() +{ + unless (typecheck_3_2_v()) return; +} +} -returnCodes error -match regexp -result {void type illegal in predicate} + +test typecheck-3.3 {void illegal in while-loop conditional} -body { +#lang L --line=1 +void typecheck_3_3_v() { return; } +void +typecheck_3_3() +{ + while (typecheck_3_3_v()) return; +} +} -returnCodes error -match regexp -result {void type illegal in predicate} + +test typecheck-3.4 {void illegal in do-loop conditional} -body { +#lang L --line=1 +void typecheck_3_4_v() { return; } +void +typecheck_3_4() +{ + do { + return; + } while(typecheck_3_4_v()); +} +} -returnCodes error -match regexp -result {void type illegal in predicate} + +test typecheck-3.5 {void illegal in for-loop conditional} -body { +#lang L --line=1 +void typecheck_3_5_v() { return; } +void +typecheck_3_5() +{ + for (1; typecheck_3_5_v(); 1) return; +} +} -returnCodes error -match regexp -result {void type illegal in predicate} + +test typecheck-3.6 {void illegal in abbreviated-for-loop conditional} -body { +#lang L --line=1 +void typecheck_3_6_v() { return; } +void +typecheck_3_6() +{ + for (1; typecheck_3_6_v();) return; +} +} -returnCodes error -match regexp -result {void type illegal in predicate} + +test typecheck-3.10 {void illegal in binary operators} -body { +#lang L --line=1 +void t310v() { return; } +void +typecheck_3_10() +{ + int i; + + if (t310v() && 0) return; + if (0 && t310v()) return; + if (t310v() || 0) return; + if (0 || t310v()) return; + if (t310v() =~ /bad/) return; + if (t310v() eq "") return; + if ("" eq t310v()) return; + if (t310v() ne "") return; + if ("" ne t310v()) return; + if (t310v() gt "") return; + if ("" gt t310v()) return; + if (t310v() ge "") return; + if ("" ge t310v()) return; + if (t310v() lt "") return; + if ("" lt t310v()) return; + if (t310v() le "") return; + if ("" le t310v()) return; + if (t310v() == 0) return; + if (0 == t310v()) return; + if (t310v() != 0) return; + if (0 != t310v()) return; + if (t310v() > 0) return; + if (0 > t310v()) return; + if (t310v() >= 0) return; + if (0 >= t310v()) return; + if (t310v() < 0) return; + if (0 < t310v()) return; + if (t310v() <= 0) return; + if (0 <= t310v()) return; + i = t310v() + 1; + i = 1 + t310v(); + i = t310v() - 1; + i = 1 - t310v(); + i = t310v() * 1; + i = 1 * t310v(); + i = t310v() / 1; + i = 1 / t310v(); + i = t310v() % 1; + i = 1 % t310v(); + i = t310v() & 1; + i = 1 & t310v(); + i = t310v() | 1; + i = 1 | t310v(); + i = t310v() ^ 1; + i = 1 ^ t310v(); + i = t310v() << 1; + i = 1 << t310v(); + i = t310v() >> 1; + i = 1 >> t310v(); +} +} -returnCodes error -match regexp -result {.*7: L Error: void type illegal in predicate +.*8: L Error: void type illegal in predicate +.*9: L Error: void type illegal in predicate +.*10: L Error: void type illegal in predicate +.*11: L Error: expected type.*but got void in =~ +.*12: L Error: expected type.*but got void in string comparison +.*13: L Error: expected type.*but got void in string comparison +.*14: L Error: expected type.*but got void in string comparison +.*15: L Error: expected type.*but got void in string comparison +.*16: L Error: expected type.*but got void in string comparison +.*17: L Error: expected type.*but got void in string comparison +.*18: L Error: expected type.*but got void in string comparison +.*19: L Error: expected type.*but got void in string comparison +.*20: L Error: expected type.*but got void in string comparison +.*21: L Error: expected type.*but got void in string comparison +.*22: L Error: expected type.*but got void in string comparison +.*23: L Error: expected type.*but got void in string comparison +.*24: L Error: type void illegal +.*25: L Error: type void illegal +.*26: L Error: type void illegal +.*27: L Error: type void illegal +.*28: L Error: type void illegal +.*29: L Error: type void illegal +.*30: L Error: type void illegal +.*31: L Error: type void illegal +.*32: L Error: type void illegal +.*33: L Error: type void illegal +.*34: L Error: type void illegal +.*35: L Error: type void illegal +.*36: L Error: expected type.*but got void in arithmetic operator +.*37: L Error: expected type.*but got void in arithmetic operator +.*38: L Error: expected type.*but got void in arithmetic operator +.*39: L Error: expected type.*but got void in arithmetic operator +.*40: L Error: expected type.*but got void in arithmetic operator +.*41: L Error: expected type.*but got void in arithmetic operator +.*42: L Error: expected type.*but got void in arithmetic operator +.*43: L Error: expected type.*but got void in arithmetic operator +.*44: L Error: expected type.*but got void in arithmetic operator +.*45: L Error: expected type.*but got void in arithmetic operator +.*46: L Error: expected type.*but got void in arithmetic operator +.*47: L Error: expected type.*but got void in arithmetic operator +.*48: L Error: expected type.*but got void in arithmetic operator +.*49: L Error: expected type.*but got void in arithmetic operator +.*50: L Error: expected type.*but got void in arithmetic operator +.*51: L Error: expected type.*but got void in arithmetic operator +.*52: L Error: expected type.*but got void in arithmetic operator +.*53: L Error: expected type.*but got void in arithmetic operator +.*54: L Error: expected type.*but got void in arithmetic operator +.*55: L Error: expected type.*but got void in arithmetic operator +} + +test typecheck-3.10.2 {void illegal in binary operators 2} -body { +#lang L --line=1 +void t310_2v() { return; } +void +typecheck_3_10_2() +{ + int i; + + /* + * Similar to typecheck-3.10 but testing void as both lhs and + * rhs. The earlier test was getting too big which makes it + * hard to update for changes in error messages or error + * checking in the compiler. + */ + + if (t310_2v() && t310_2v()) return; + if (t310_2v() || t310_2v()) return; + if (t310_2v() =~ /bad/) return; + if (t310_2v() eq t310_2v()) return; + if (t310_2v() ne t310_2v()) return; + if (t310_2v() gt t310_2v()) return; + if (t310_2v() ge t310_2v()) return; + if (t310_2v() lt t310_2v()) return; + if (t310_2v() le t310_2v()) return; + if (t310_2v() == t310_2v()) return; + if (t310_2v() != t310_2v()) return; + if (t310_2v() > t310_2v()) return; + if (t310_2v() >= t310_2v()) return; + if (t310_2v() < t310_2v()) return; + if (t310_2v() <= t310_2v()) return; + i = t310_2v() + t310_2v(); + i = t310_2v() - t310_2v(); + i = t310_2v() * t310_2v(); + i = t310_2v() / t310_2v(); + i = t310_2v() % t310_2v(); + i = t310_2v() & t310_2v(); + i = t310_2v() | t310_2v(); + i = t310_2v() ^ t310_2v(); + i = t310_2v() << t310_2v(); + i = t310_2v() >> t310_2v(); +} +} -returnCodes error -match regexp -result {.*14: L Error: void type illegal in predicate +.*15: L Error: void type illegal in predicate +.*16: L Error: expected type.*but got void in =~ +.*17: L Error: expected type.*but got void in string comparison +.*18: L Error: expected type.*but got void in string comparison +.*19: L Error: expected type.*but got void in string comparison +.*20: L Error: expected type.*but got void in string comparison +.*21: L Error: expected type.*but got void in string comparison +.*22: L Error: expected type.*but got void in string comparison +.*23: L Error: type void illegal +.*24: L Error: type void illegal +.*25: L Error: type void illegal +.*26: L Error: type void illegal +.*27: L Error: type void illegal +.*28: L Error: type void illegal +.*29: L Error: expected type.*but got void in arithmetic operator +.*30: L Error: expected type.*but got void in arithmetic operator +.*31: L Error: expected type.*but got void in arithmetic operator +.*32: L Error: expected type.*but got void in arithmetic operator +.*33: L Error: expected type.*but got void in arithmetic operator +.*34: L Error: expected type.*but got void in arithmetic operator +.*35: L Error: expected type.*but got void in arithmetic operator +.*36: L Error: expected type.*but got void in arithmetic operator +.*37: L Error: expected type.*but got void in arithmetic operator +.*38: L Error: expected type.*but got void in arithmetic operator +} + +test typecheck-3.11 {void illegal in casts and unary operators} -body { +#lang L --line=1 +void t311v() { return; } +void +typecheck_3_11() +{ + int i; + float f; + string s; + hash h; + + i = (int)t311v(); + f = (float)t311v(); + s = (string)t311v(); + h = (hash)t311v(); + i = !t311v(); + i = ~t311v(); + i = +t311v(); + i = -t311v(); +} +} -returnCodes error -match regexp -result {.*10: L Error: type void illegal +.*11: L Error: type void illegal +.*12: L Error: type void illegal +.*13: L Error: type void illegal +.*14: L Error: void type illegal in predicate +.*15: L Error: expected type int.* +.*16: L Error: expected type int or float.* +.*17: L Error: expected type int or float.* +} + +test typecheck-3.12 {void illegal in assignments} -body { +#lang L --line=1 +void t312v() { return; } +int takes_int(int i) { return i; } +void +typecheck_3_12() +{ + int i; + + i = t312v(); + i += t312v(); + i -= t312v(); + i /= t312v(); + i *= t312v(); + i %= t312v(); + i &= t312v(); + i |= t312v(); + i ^= t312v(); + i >>= t312v(); + i <<= t312v(); + takes_int(t312v()); +} +} -returnCodes error -match regexp -result {.*8: L Error: type void illegal +.*9: L Error: type void illegal +.*10: L Error: type void illegal +.*11: L Error: type void illegal +.*12: L Error: type void illegal +.*13: L Error: type void illegal +.*14: L Error: type void illegal +.*15: L Error: type void illegal +.*16: L Error: type void illegal +.*17: L Error: type void illegal +.*18: L Error: type void illegal +.*19: L Error: parameter 1 has incompatible type +} + +test typecheck-3.13 {void illegal as foreach expr} -body { +#lang L --line=1 -nowarn +void t313v() { return; } +void +typecheck_3_13() +{ + int k; + + foreach (k in t313v()) { } +} +} -returnCodes error -match regexp -result {.*foreach expression must be array, hash, or string} + +test typecheck-4.1 {type errors in foreach} -body { +#lang L --line=1 +void +typecheck_4_1() +{ + int vi; + float vf; + string vs; + int ai[2] = { 22, 23 }; + string as[2] = { "b", "c" }; + float af[2] = { 2.1, 2.2 }; + hash h = { 1=>2, 2=>3 }; + + foreach (vi in as) {} + foreach (vi in af) {} + foreach (vs in ai) {} + foreach (vs in af) {} + foreach (vf in as) {} + foreach (vi,vi in h) {} +} +} -returnCodes error -match regexp -result {.*12: L Error: loop index type incompatible with array element type +.*13: L Error: loop index type incompatible with array element type +.*14: L Error: loop index type incompatible with array element type +.*15: L Error: loop index type incompatible with array element type +.*16: L Error: loop index type incompatible with array element type +.*17: L Error: multiple variables illegal in foreach over hash +} + +test typecheck-4.2 {type errors in foreach with multiple variables} -body { +#lang L --line=1 +void +typecheck_4_2() +{ + int i1,i2,i3; + float f1,f2,f3; + string s1,s2,s3; + int ai[3] = { 22, 23, 24 }; + string as[3] = { "b", "c", "d" }; + float af[3] = { 2.1, 2.2, 2.3 }; + + foreach (i1,s2,s3 in as) {} + foreach (s1,i2,s3 in as) {} + foreach (s1,s2,i3 in as) {} + foreach (s1,i2,i3 in ai) {} + foreach (i1,s2,i3 in ai) {} + foreach (i1,i2,s3 in ai) {} + foreach (s1,f2,f3 in af) {} + foreach (f1,s2,f3 in af) {} + foreach (f1,f2,s3 in af) {} + + /* Make sure that multiple type errors get caught. */ + foreach (i1,i2,s3 in as) {} + foreach (i1,i2,i3 in as) {} +} +} -returnCodes error -match regexp -result {.*11: L Error: loop index type incompatible with array element type +.*12: L Error: loop index type incompatible with array element type +.*13: L Error: loop index type incompatible with array element type +.*14: L Error: loop index type incompatible with array element type +.*15: L Error: loop index type incompatible with array element type +.*16: L Error: loop index type incompatible with array element type +.*17: L Error: loop index type incompatible with array element type +.*18: L Error: loop index type incompatible with array element type +.*19: L Error: loop index type incompatible with array element type +.*22: L Error: loop index type incompatible with array element type +.*22: L Error: loop index type incompatible with array element type +.*23: L Error: loop index type incompatible with array element type +.*23: L Error: loop index type incompatible with array element type +.*23: L Error: loop index type incompatible with array element type +} + +test typecheck-4.4 {scalars as condition expressions} -body { +#lang L --line=1 +void +typecheck_4_4() +{ + /* These are all legal. */ + + int i = 0; + float f = 0.0; + string s1, s2 = "defined"; + widget w; + poly p = "0"; + + if (i) puts("bad 1"); + if (f) puts("bad 2"); // Exact comparisons w/floats don't always work + + /* Strings as conditionals get checked for defined. */ + if (s1) puts("bad 3"); + unless (s2) puts("bad 4"); + + /* !condition should work too. */ + unless (!s1) puts("bad 4.1"); + if (!s2) puts("bad 4.2"); + if (s1 || !s2) puts("bad 4.3"); + + if (w) puts("bad 5"); + if (p) puts("bad 6"); +} +typecheck_4_4(); +} -output {} + +test typecheck-5.1 {type errors in hash elements} -body { +#lang L --line=1 +struct st51 { + int x; + int y; +}; +void +typecheck_5_1() +{ + int a[3], i; + string s; + float f; + poly p; + struct st51 st = {0,0}; + + int ihi{int}; + int ihs{string}; + int ihf{float}; + + string shi{int}; + string shs{string}; + string shf{float}; + + float fhi{int}; + float fhs{string}; + float fhf{float}; + + poly phi{int}; + poly phs{string}; + poly phf{float}; + + ihi{1.1} = 0; // These want an index of type int. + ihi{"s"} = 0; + ihi{st} = 0; + ihi{a} = 0; + ihi{shi} = 0; + shi{1.1} = "s"; + shi{"s"} = "s"; + shi{st} = "s"; + shi{a} = "s"; + shi{shi} = "s"; + fhi{1.1} = 0.0; + fhi{"s"} = 0.0; + fhi{st} = 0.0; + fhi{a} = 0.0; + fhi{shi} = 0.0; + phi{1.1} = 0.0; + phi{"s"} = 0.0; + phi{st} = 0.0; + phi{a} = 0.0; + phi{shi} = 0.0; + i = ihi{1.1}; + i = ihi{"s"}; + i = ihi{st}; + i = ihi{a}; + i = ihi{shi}; + s = shi{1.1}; + s = shi{"s"}; + s = shi{st}; + s = shi{a}; + s = shi{shi}; + f = fhi{1.1}; + f = fhi{"s"}; + f = fhi{st}; + f = fhi{a}; + f = fhi{shi}; + p = phi{1.1}; + p = phi{"s"}; + p = phi{st}; + p = phi{a}; + p = phi{shi}; + ihs{1.1} = 0; // These want an index of type string. + ihs{0} = 0; + ihs{st} = 0; + ihs{a} = 0; + ihs{shi} = 0; + shs{1.1} = "s"; + shs{0} = "s"; + shs{st} = "s"; + shs{a} = "s"; + shs{shi} = "s"; + fhs{1.1} = 0.0; + fhs{0} = 0.0; + fhs{st} = 0.0; + fhs{a} = 0.0; + fhs{shi} = 0.0; + phs{1.1} = 0.0; + phs{0} = 0.0; + phs{st} = 0.0; + phs{a} = 0.0; + phs{shi} = 0.0; + i = ihs{1.1}; + i = ihs{0}; + i = ihs{st}; + i = ihs{a}; + i = ihs{shi}; + s = shs{1.1}; + s = shs{0}; + s = shs{st}; + s = shs{a}; + s = shs{shi}; + f = fhs{1.1}; + f = fhs{0}; + f = fhs{st}; + f = fhs{a}; + f = fhs{shi}; + p = phs{1.1}; + p = phs{0}; + p = phs{st}; + p = phs{a}; + p = phs{shi}; + ihf{"s"} = 0; // These want an index of type float (but int is OK). + ihf{st} = 0; + ihf{a} = 0; + ihf{shi} = 0; + shf{"s"} = "s"; + shf{st} = "s"; + shf{a} = "s"; + shf{shi} = "s"; + fhf{"s"} = 0.0; + fhf{st} = 0.0; + fhf{a} = 0.0; + fhf{shi} = 0.0; + phf{"s"} = 0.0; + phf{st} = 0.0; + phf{a} = 0.0; + phf{shi} = 0.0; + i = ihf{"s"}; + i = ihf{st}; + i = ihf{a}; + i = ihf{shi}; + s = shf{"s"}; + s = shf{st}; + s = shf{a}; + s = shf{shi}; + f = fhf{"s"}; + f = fhf{st}; + f = fhf{a}; + f = fhf{shi}; + p = phf{"s"}; + p = phf{st}; + p = phf{a}; + p = phf{shi}; +} +#lang tcl +typecheck_5_1 +} -returnCodes error -match regexp -result {.*30: L Error: expected type int but got float in hash index +.*31: L Error: expected type int but got string in hash index +.*32: L Error: expected type int but got struct in hash index +.*33: L Error: expected type int but got array in hash index +.*34: L Error: expected type int but got hash in hash index +.*35: L Error: expected type int but got float in hash index +.*36: L Error: expected type int but got string in hash index +.*37: L Error: expected type int but got struct in hash index +.*38: L Error: expected type int but got array in hash index +.*39: L Error: expected type int but got hash in hash index +.*40: L Error: expected type int but got float in hash index +.*41: L Error: expected type int but got string in hash index +.*42: L Error: expected type int but got struct in hash index +.*43: L Error: expected type int but got array in hash index +.*44: L Error: expected type int but got hash in hash index +.*45: L Error: expected type int but got float in hash index +.*46: L Error: expected type int but got string in hash index +.*47: L Error: expected type int but got struct in hash index +.*48: L Error: expected type int but got array in hash index +.*49: L Error: expected type int but got hash in hash index +.*50: L Error: expected type int but got float in hash index +.*51: L Error: expected type int but got string in hash index +.*52: L Error: expected type int but got struct in hash index +.*53: L Error: expected type int but got array in hash index +.*54: L Error: expected type int but got hash in hash index +.*55: L Error: expected type int but got float in hash index +.*56: L Error: expected type int but got string in hash index +.*57: L Error: expected type int but got struct in hash index +.*58: L Error: expected type int but got array in hash index +.*59: L Error: expected type int but got hash in hash index +.*60: L Error: expected type int but got float in hash index +.*61: L Error: expected type int but got string in hash index +.*62: L Error: expected type int but got struct in hash index +.*63: L Error: expected type int but got array in hash index +.*64: L Error: expected type int but got hash in hash index +.*65: L Error: expected type int but got float in hash index +.*66: L Error: expected type int but got string in hash index +.*67: L Error: expected type int but got struct in hash index +.*68: L Error: expected type int but got array in hash index +.*69: L Error: expected type int but got hash in hash index +.*70: L Error: expected type string but got float in hash index +.*71: L Error: expected type string but got int in hash index +.*72: L Error: expected type string but got struct in hash index +.*73: L Error: expected type string but got array in hash index +.*74: L Error: expected type string but got hash in hash index +.*75: L Error: expected type string but got float in hash index +.*76: L Error: expected type string but got int in hash index +.*77: L Error: expected type string but got struct in hash index +.*78: L Error: expected type string but got array in hash index +.*79: L Error: expected type string but got hash in hash index +.*80: L Error: expected type string but got float in hash index +.*81: L Error: expected type string but got int in hash index +.*82: L Error: expected type string but got struct in hash index +.*83: L Error: expected type string but got array in hash index +.*84: L Error: expected type string but got hash in hash index +.*85: L Error: expected type string but got float in hash index +.*86: L Error: expected type string but got int in hash index +.*87: L Error: expected type string but got struct in hash index +.*88: L Error: expected type string but got array in hash index +.*89: L Error: expected type string but got hash in hash index +.*90: L Error: expected type string but got float in hash index +.*91: L Error: expected type string but got int in hash index +.*92: L Error: expected type string but got struct in hash index +.*93: L Error: expected type string but got array in hash index +.*94: L Error: expected type string but got hash in hash index +.*95: L Error: expected type string but got float in hash index +.*96: L Error: expected type string but got int in hash index +.*97: L Error: expected type string but got struct in hash index +.*98: L Error: expected type string but got array in hash index +.*99: L Error: expected type string but got hash in hash index +.*100: L Error: expected type string but got float in hash index +.*101: L Error: expected type string but got int in hash index +.*102: L Error: expected type string but got struct in hash index +.*103: L Error: expected type string but got array in hash index +.*104: L Error: expected type string but got hash in hash index +.*105: L Error: expected type string but got float in hash index +.*106: L Error: expected type string but got int in hash index +.*107: L Error: expected type string but got struct in hash index +.*108: L Error: expected type string but got array in hash index +.*109: L Error: expected type string but got hash in hash index +.*110: L Error: expected type float but got string in hash index +.*111: L Error: expected type float but got struct in hash index +.*112: L Error: expected type float but got array in hash index +.*113: L Error: expected type float but got hash in hash index +.*114: L Error: expected type float but got string in hash index +.*115: L Error: expected type float but got struct in hash index +.*116: L Error: expected type float but got array in hash index +.*117: L Error: expected type float but got hash in hash index +.*118: L Error: expected type float but got string in hash index +.*119: L Error: expected type float but got struct in hash index +.*120: L Error: expected type float but got array in hash index +.*121: L Error: expected type float but got hash in hash index +.*122: L Error: expected type float but got string in hash index +.*123: L Error: expected type float but got struct in hash index +.*124: L Error: expected type float but got array in hash index +.*125: L Error: expected type float but got hash in hash index +.*126: L Error: expected type float but got string in hash index +.*127: L Error: expected type float but got struct in hash index +.*128: L Error: expected type float but got array in hash index +.*129: L Error: expected type float but got hash in hash index +.*130: L Error: expected type float but got string in hash index +.*131: L Error: expected type float but got struct in hash index +.*132: L Error: expected type float but got array in hash index +.*133: L Error: expected type float but got hash in hash index +.*134: L Error: expected type float but got string in hash index +.*135: L Error: expected type float but got struct in hash index +.*136: L Error: expected type float but got array in hash index +.*137: L Error: expected type float but got hash in hash index +.*138: L Error: expected type float but got string in hash index +.*139: L Error: expected type float but got struct in hash index +.*140: L Error: expected type float but got array in hash index +.*141: L Error: expected type float but got hash in hash index +} + +test typecheck-6.1 {type check errors with push built-in} -body { +#lang L --line=1 -nowarn +class typecheck_6_1_cls {} +void +typecheck_6_1() +{ + int a[], aa[][], i, j; + int h{int}; + float f; + string s; + struct { int i,j; } st; + poly p; + widget w; + typecheck_6_1_cls o; + + /* Errors -- first arg not a reference (&). */ + push(a, i); + push(i, i); + push(h, i); + push(f, i); + push(s, i); + push(st, i); + push(p, i); + push(w, i); + + /* Error -- too few arguments. */ + push(&a); + push(); + + + /* Error -- first arg not an array reference. */ + push(&i, i); + push(&h, i); + push(&f, i); + push(&s, i); + push(&st, i); + push(&w, i); + push(&1, i); + push(&3.14159, i); + push(&o, i); +} +#lang tcl +typecheck_6_1 +} -returnCodes {error} -match regexp -result {.*:15: L Error: first arg to push not an array reference.* +.*:16: L Error: first arg to push not an array reference.* +.*:17: L Error: first arg to push not an array reference.* +.*:18: L Error: first arg to push not an array reference.* +.*:19: L Error: first arg to push not an array reference.* +.*:20: L Error: first arg to push not an array reference.* +.*:21: L Error: first arg to push not an array reference.* +.*:22: L Error: first arg to push not an array reference.* +.*:25: L Error: too few arguments to push +.*:26: L Error: too few arguments to push +.*:30: L Error: first arg to push not an array reference.* +.*:31: L Error: first arg to push not an array reference.* +.*:32: L Error: first arg to push not an array reference.* +.*:33: L Error: first arg to push not an array reference.* +.*:34: L Error: first arg to push not an array reference.* +.*:35: L Error: first arg to push not an array reference.* +.*:36: L Error: first arg to push not an array reference.* +.*:37: L Error: first arg to push not an array reference.* +.*:38: L Error: first arg to push not an array reference.* +} + +test typecheck-6.2 {type check errors with push built-in 2} -body { +#lang L --line=1 +void typecheck_6_2_v() { } +void +typecheck_6_2() +{ + int ai[], i; + string as[], s; + widget aw[], w; + float af[], f; + int aa[][]; // array of array + int ah[]{int}, h{int}; // array of hash, and a hash + struct { int i,j; } ast[], st; // array of struct, and a struct + + /* + * Check pushing incompatible type onto the array. Just check + * for an array of int, since we check the full type-checker + * elsewhere. + */ + + push(&ai, typecheck_6_2_v()); // pushing a void + + push(&ai, f); + push(&ai, s); + + push(&ai, aa); + push(&ai, as); + push(&ai, af); + push(&ai, h); + push(&ai, ah); + push(&ai, st); + push(&ai, ast); + push(&ai, w); + push(&ai, aw); + + push(&aa[0], f); + push(&aa[0], s); + + + push(&aa[0], as); + push(&aa[0], af); + push(&aa[0], h); + push(&aa[0], ah); + push(&aa[0], st); + push(&aa[0], ast); + push(&aa[0], w); + push(&aa[0], aw); + + push(&ai, f, s); + push(&ai, i, f); + push(&ai, i, f, s); +} +typecheck_6_2(); +} -returnCodes {error} -match regexp -result {.*:19: L Error: arg #2 to push has type incompatible with array +.*:21: L Error: arg #2 to push has type incompatible with array +.*:22: L Error: arg #2 to push has type incompatible with array +.*:24: L Error: arg #2 to push has type incompatible with array +.*:25: L Error: arg #2 to push has type incompatible with array +.*:26: L Error: arg #2 to push has type incompatible with array +.*:27: L Error: arg #2 to push has type incompatible with array +.*:28: L Error: arg #2 to push has type incompatible with array +.*:29: L Error: arg #2 to push has type incompatible with array +.*:30: L Error: arg #2 to push has type incompatible with array +.*:31: L Error: arg #2 to push has type incompatible with array +.*:32: L Error: arg #2 to push has type incompatible with array +.*:34: L Error: arg #2 to push has type incompatible with array +.*:35: L Error: arg #2 to push has type incompatible with array +.*:38: L Error: arg #2 to push has type incompatible with array +.*:39: L Error: arg #2 to push has type incompatible with array +.*:40: L Error: arg #2 to push has type incompatible with array +.*:41: L Error: arg #2 to push has type incompatible with array +.*:42: L Error: arg #2 to push has type incompatible with array +.*:43: L Error: arg #2 to push has type incompatible with array +.*:44: L Error: arg #2 to push has type incompatible with array +.*:45: L Error: arg #2 to push has type incompatible with array +.*:47: L Error: arg #2 to push has type incompatible with array +.*:47: L Error: arg #3 to push has type incompatible with array +.*:48: L Error: arg #3 to push has type incompatible with array +.*:49: L Error: arg #3 to push has type incompatible with array +.*:49: L Error: arg #4 to push has type incompatible with array +} + +test typecheck-6.3 {type check push built-in} -body { +#lang L --line=1 +void +typecheck_6_3() +{ + int ai[], i; + string as[], s; + widget aw[], w; + float af[], f; + poly ap[], p; + int aa[][], a[]; // array of array, and an array + int ah[]{int}, h{int}; // array of hash, and a hash + struct { int i,j; } ast[], st; // array of struct, and a struct + + /* All legal. */ + + push(&ai, 0); + push(&ai, i); + + push(&as, "s"); + push(&as, s); + + push(&af, 3.14); + push(&af, f); + push(&af, 0); // legal to push ints onto a float array + push(&af, i); + + push(&ap, 0); + push(&ap, 3.14); + push(&ap, "s"); + push(&ap, i); + push(&ap, s); + push(&ap, w); + push(&ap, f); + push(&ap, p); + push(&ap, ai); + push(&ap, as); + push(&ap, af); + push(&ap, ap); + push(&ap, aw); + push(&ap, ast); + push(&ap, h); + push(&ap, st); + + push(&aw, w); + push(&aw, (widget)"w"); + push(&aw, s); // legal to push strings onto a widget array + push(&aw, "w"); + + push(&ah, h); + + push(&aa, a); + + push(&ast, st); +} +#lang tcl +typecheck_6_3 +} -output {} + +test typecheck-7.1 {test type checking of reference parameters} -body { +#lang L --line=1 -nowarn +void typecheck_7_1_foo(int &a) {} +void typecheck_7_1() +{ + int a; + + typecheck_7_1_foo(a); // incorrect arg type +} +typecheck_7_1(); +} -returnCodes error -match regexp -result {.*6: L Error: parameter 1 has incompatible type +} + +test typecheck-8.1 {widget and string type compatibility} -body { +#lang L --line=1 +void typecheck_8_1() +{ + poly p = "p"; + string s = "s"; + widget w = "w"; + + p = s; + unless (p eq "s") puts("bad 1"); + p = w; + unless (p eq "w") puts("bad 2"); + p = p; + unless (p eq "w") puts("bad 3"); + p = "p"; + s = p; + unless (s eq "p") puts("bad 4"); + s = s; + unless (s eq "p") puts("bad 5"); + s = w; + unless (s eq "w") puts("bad 6"); + s = "s"; + w = p; + unless (w eq "p") puts("bad 7"); + w = s; + unless (w eq "s") puts("bad 8"); + w = w; + unless (w eq "s") puts("bad 9"); + w = "w"; + + unless (p ne s) puts("bad 10"); + unless (s ne p) puts("bad 11"); + unless (p ne w) puts("bad 12"); + unless (w ne p) puts("bad 13"); + unless (s ne w) puts("bad 14"); + unless (w ne s) puts("bad 15"); + unless (p eq p) puts("bad 16"); + unless (s eq s) puts("bad 17"); + unless (w eq w) puts("bad 18"); +} +#lang tcl +typecheck_8_1 +} -output {} + +test typecheck-9.1 {illegal types in function prototype declarations} -body { +#lang L --line=1 +void typecheck_9_1_1(void, void); +void typecheck_9_1_2(void, void, void); +void typecheck_9_1_3(int, void); +void typecheck_9_1_4(void, int); +void typecheck_9_1_5(void[]); +void typecheck_9_1_6(void[][]); +void typecheck_9_1_7(void{int}); +void typecheck_9_1_8(void{int}[]); +void typecheck_9_1_9(void[]{int}); +void typecheck_9_1_10(void &bad); +void typecheck_9_1_11(int{void}); +void{int} typecheck_9_1_12(); +void[] typecheck_9_1_13(); +int{void} typecheck_9_1_14(); +} -returnCodes error -match regexp -result {.*1: L Error: type void illegal +.*1: L Error: type void illegal +.*2: L Error: type void illegal +.*2: L Error: type void illegal +.*2: L Error: type void illegal +.*3: L Error: type void illegal +.*4: L Error: type void illegal +.*5: L Error: type void illegal +.*6: L Error: type void illegal +.*7: L Error: type void illegal +.*8: L Error: type void illegal +.*9: L Error: type void illegal +.*10: L Error: type void illegal in declaration of 'bad' +.*11: L Error: type void illegal +.*12: L Error: type void illegal in declaration of 'typecheck_9_1_12' +.*13: L Error: type void illegal in declaration of 'typecheck_9_1_13' +.*14: L Error: type void illegal in declaration of 'typecheck_9_1_14' +} + +test typecheck-9.2 {illegal types in function pointer args} -body { +#lang L --line=1 +void typecheck_9_2_1(void &bad(void, void)); +void typecheck_9_2_2(void &bad(void, void, void)); +void typecheck_9_2_3(void &bad(int, void)); +void typecheck_9_2_4(void &bad(void, int)); +void typecheck_9_2_5(void &bad(void[])); +void typecheck_9_2_6(void &bad(void[][])); +void typecheck_9_2_7(void &bad(void{int})); +void typecheck_9_2_8(void &bad(void{int}[])); +void typecheck_9_2_9(void &bad(void[]{int})); +void typecheck_9_2_10(void &bad(void &bad)); +void typecheck_9_2_11(void &bad(int{void})); +void typecheck_9_2_12(void{int} &bad()); +void typecheck_9_2_13(void[] &bad()); +void typecheck_9_2_14(int{void} &bad()); +} -returnCodes error -match regexp -result {.*1: L Error: type void illegal +.*1: L Error: type void illegal +.*2: L Error: type void illegal +.*2: L Error: type void illegal +.*2: L Error: type void illegal +.*3: L Error: type void illegal +.*4: L Error: type void illegal +.*5: L Error: type void illegal +.*6: L Error: type void illegal +.*7: L Error: type void illegal +.*8: L Error: type void illegal +.*9: L Error: type void illegal +.*10: L Error: type void illegal in declaration of 'bad' +.*11: L Error: type void illegal +.*12: L Error: type void illegal in declaration of 'bad' +.*13: L Error: type void illegal in declaration of 'bad' +.*14: L Error: type void illegal in declaration of 'bad' +} + +test typecheck-9.3 {illegal types in variable declarations 1} -body { +#lang L --line=1 +void typecheck_9_3() +{ + void bad1; + void bad2[]; + void bad3[][]; + void bad4{int}; + void bad5{int}{int}; + void bad6[]{int}; + void bad7{int}[]; + int bad8{void}; + int bad9[]{void}{int}; + int &bad10; + int &bad11[]; + int &bad12{int}; + int &bad13(void); + int &bad14(int); + int &bad15(int arg); +} +} -returnCodes error -match regexp -result {.*3: L Error:.*bad1.* +.*4: L Error:.*bad2.* +.*5: L Error:.*bad3.* +.*6: L Error:.*bad4.* +.*7: L Error:.*bad5.* +.*8: L Error:.*bad6.* +.*9: L Error:.*bad7.* +.*10: L Error:.*bad8.* +.*11: L Error:.*bad9.* +.*12: L Error:.*bad10.* +.*13: L Error:.*bad11.* +.*14: L Error:.*bad12.* +.*15: L Error:.*bad13.* +.*16: L Error:.*bad14.* +.*17: L Error:.*bad15.* +} + +test typecheck-9.3.1 {illegal types in variable declarations 2} -body { +#lang L --line=1 +void typecheck_9_3_1() +{ + void bad1, bad2[], bad3[][], bad4{int}, bad5{int}{int}; + void bad6[]{int}, bad7{int}[], bad8{void}, bad9[]{void}{int}; + int &bad10, &bad11[], &bad12{int}, &bad13(void); + int &bad14(int), &bad15(int arg); +} +} -returnCodes error -match regexp -result {.*3: L Error:.*bad1.* +.*3: L Error:.*bad2.* +.*3: L Error:.*bad3.* +.*3: L Error:.*bad4.* +.*3: L Error:.*bad5.* +.*4: L Error:.*bad6.* +.*4: L Error:.*bad7.* +.*4: L Error:.*bad8.* +.*4: L Error:.*bad9.* +.*5: L Error:.*bad10.* +.*5: L Error:.*bad11.* +.*5: L Error:.*bad12.* +.*5: L Error:.*bad13.* +.*6: L Error:.*bad14.* +.*6: L Error:.*bad15.* +} + +test typecheck-9.3.2 {illegal types in variable declarations 3} -body { +#lang L --line=1 +typedef void &t932(); +void typecheck_9_3_2() +{ + t932 bad1; + t932 bad2[]; + t932 bad3[][]; + t932 bad4{int}; + t932 bad5{int}{int}; + t932 bad6[]{int}; + t932 bad7{int}[]; + t932 bad8{void}; + t932 bad9[]{void}{int}; + t932 &bad10; + t932 &bad11[]; + t932 &bad12{int}; + t932 &bad13(void); + t932 &bad14(int); + t932 &bad15(int arg); +} +} -returnCodes error -match regexp -result {.*4: L Error:.*bad1.* +.*5: L Error:.*bad2.* +.*6: L Error:.*bad3.* +.*7: L Error:.*bad4.* +.*8: L Error:.*bad5.* +.*9: L Error:.*bad6.* +.*10: L Error:.*bad7.* +.*11: L Error:.*bad8.* +.*12: L Error:.*bad9.* +.*13: L Error:.*bad10.* +.*14: L Error:.*bad11.* +.*15: L Error:.*bad12.* +.*16: L Error:.*bad13.* +.*17: L Error:.*bad14.* +.*18: L Error:.*bad15.* +} + +test typecheck-9.4 {illegal types in struct declarations 1} -body { +#lang L --line=1 +struct { + void bad1; + void bad2[]; + void bad3[][]; + void bad4{int}; + void bad5{int}{int}; + void bad6[]{int}; + void bad7{int}[]; + int bad8{void}; + int bad9[]{void}{int}; + int &bad10; + int &bad11[]; + int &bad12{int}; + int &bad13(void); + int &bad14(int); + int &bad15(int arg); +}; +} -returnCodes error -match regexp -result {.*2: L Error:.*bad1.* +.*3: L Error:.*bad2.* +.*4: L Error:.*bad3.* +.*5: L Error:.*bad4.* +.*6: L Error:.*bad5.* +.*7: L Error:.*bad6.* +.*8: L Error:.*bad7.* +.*9: L Error:.*bad8.* +.*10: L Error:.*bad9.* +.*11: L Error:.*bad10.* +.*12: L Error:.*bad11.* +.*13: L Error:.*bad12.* +.*14: L Error:.*bad13.* +.*15: L Error:.*bad14.* +.*16: L Error:.*bad15.* +} + +test typecheck-9.4.1 {illegal types in struct declarations 2} -body { +#lang L --line=1 +struct { + void bad1, bad2[], bad3[][], bad4{int}, bad5{int}{int}; + void bad6[]{int}, bad7{int}[], bad8{void}; + int bad9[]{void}{int}, &bad10, &bad11[]; + int &bad12{int}, &bad13(void), &bad14(int), &bad15(int arg); +}; +} -returnCodes error -match regexp -result {.*2: L Error:.*bad1.* +.*2: L Error:.*bad2.* +.*2: L Error:.*bad3.* +.*2: L Error:.*bad4.* +.*2: L Error:.*bad5.* +.*3: L Error:.*bad6.* +.*3: L Error:.*bad7.* +.*3: L Error:.*bad8.* +.*4: L Error:.*bad9.* +.*4: L Error:.*bad10.* +.*4: L Error:.*bad11.* +.*5: L Error:.*bad12.* +.*5: L Error:.*bad13.* +.*5: L Error:.*bad14.* +.*5: L Error:.*bad15.* +} + +test typecheck-9.4.2 {illegal types in struct declarations 3} -body { +#lang L --line=1 +typedef void &t942(); +struct { + t942 bad1; + t942 bad2[]; + t942 bad3[][]; + t942 bad4{int}; + t942 bad5{int}{int}; + t942 bad6[]{int}; + t942 bad7{int}[]; + t942 bad8{void}; + t942 bad9[]{void}{int}; + t942 &bad10; + t942 &bad11[]; + t942 &bad12{int}; + t942 &bad13(void); + t942 &bad14(int); + t942 &bad15(int arg); +}; +} -returnCodes error -match regexp -result {.*3: L Error:.*bad1.* +.*4: L Error:.*bad2.* +.*5: L Error:.*bad3.* +.*6: L Error:.*bad4.* +.*7: L Error:.*bad5.* +.*8: L Error:.*bad6.* +.*9: L Error:.*bad7.* +.*10: L Error:.*bad8.* +.*11: L Error:.*bad9.* +.*12: L Error:.*bad10.* +.*13: L Error:.*bad11.* +.*14: L Error:.*bad12.* +.*15: L Error:.*bad13.* +.*16: L Error:.*bad14.* +.*17: L Error:.*bad15.* +} + +test typecheck-9.4.3 {call-by-name type errors} -body { +#lang L --line=1 -nowarn +typedef int arr_t[]; +typedef int hash_t{int}; +typedef struct { int i,j; } struc_t; +void t943(int &i, string &s, float &f, arr_t &a, hash_t &h, struc_t &st) {} + +void typecheck_9_4_3() +{ + int i; + string s; + float f; + arr_t a; + hash_t h; + struc_t st; + + t943( i, &s, &f, &a, &h, &st); + t943(&i, s, &f, &a, &h, &st); + t943(&i, &s, f, &a, &h, &st); + t943(&i, &s, &f, a, &h, &st); + t943(&i, &s, &f, &a, h, &st); + t943(&i, &s, &f, &a, &h, st); + t943( i, s, f, a, h, st); +} +} -returnCodes error -match regexp -result {.*15: L Error: parameter 1 has incompatible type +.*16: L Error: parameter 2 has incompatible type +.*17: L Error: parameter 3 has incompatible type +.*18: L Error: parameter 4 has incompatible type +.*19: L Error: parameter 5 has incompatible type +.*20: L Error: parameter 6 has incompatible type +.*21: L Error: parameter 1 has incompatible type +.*21: L Error: parameter 2 has incompatible type +.*21: L Error: parameter 3 has incompatible type +.*21: L Error: parameter 4 has incompatible type +.*21: L Error: parameter 5 has incompatible type +.*21: L Error: parameter 6 has incompatible type +} + +test typecheck-10.1 {check type errors in op=} -body { +#lang L --line=1 +void typecheck_10_1() +{ + int i1, i2; + string s1; + + + i1 += s1; + i1 -= s1; + i1 *= s1; + i1 /= s1; + + i1 %= s1; + s1 %= i1; + i1 &= s1; + s1 &= i1; + i1 |= s1; + s1 |= i1; + i1 ^= s1; + s1 ^= i1; + i1 <<= s1; + s1 <<= i1; + i1 >>= s1; + s1 >>= i1; + + i1 .= i2; + i1 .= s1; + s1 .= i1; +} +} -returnCodes error -match regexp -result {.*7: L Error: assignment of incompatible types +.*8: L Error: assignment of incompatible types +.*9: L Error: assignment of incompatible types +.*10: L Error: assignment of incompatible types +.*12: L Error: assignment of incompatible types +.*13: L Error: assignment of incompatible types +.*14: L Error: assignment of incompatible types +.*15: L Error: assignment of incompatible types +.*16: L Error: assignment of incompatible types +.*17: L Error: assignment of incompatible types +.*18: L Error: assignment of incompatible types +.*19: L Error: assignment of incompatible types +.*20: L Error: assignment of incompatible types +.*21: L Error: assignment of incompatible types +.*22: L Error: assignment of incompatible types +.*23: L Error: assignment of incompatible types +.*25: L Error: expected type string or widget but got int in .= +.*26: L Error: assignment of incompatible types +.*27: L Error: assignment of incompatible types +} + +test typecheck-10.2 {check type errors in comparison operators} -body { +#lang L --line=1 +void typecheck_10_2() +{ + int i; + string s; + + s == i; // line 6 + i == s; + + s != i; + i != s; // line 10 + + s <= i; + i <= s; + + s >= i; // line 15 + i >= s; + + s < i; + i < s; + // line 20 + s > i; + i > s; + + + i eq s; // line 25 + s eq i; + i eq i; + i ne s; + s ne i; + i ne i; // line 30 + i le s; + s le i; + i le i; + i ge s; + s ge i; // line 35 + i ge i; + i lt s; + s lt i; + i lt i; + i gt s; // line 40 + s gt i; + i gt i; // line 42 +} +} -returnCodes error -match regexp -result {.*6: L Error: incompatible types in comparison +.*7: L Error: incompatible types in comparison +.*9: L Error: incompatible types in comparison +.*10: L Error: incompatible types in comparison +.*12: L Error: incompatible types in comparison +.*15: L Error: incompatible types in comparison +.*16: L Error: incompatible types in comparison +.*18: L Error: incompatible types in comparison +.*19: L Error: incompatible types in comparison +.*21: L Error: incompatible types in comparison +.*22: L Error: incompatible types in comparison +.*25: L Error: expected type string or widget but got int in string comparison +.*26: L Error: expected type string or widget but got int in string comparison +.*27: L Error: expected type string or widget but got int in string comparison +.*28: L Error: expected type string or widget but got int in string comparison +.*29: L Error: expected type string or widget but got int in string comparison +.*30: L Error: expected type string or widget but got int in string comparison +.*31: L Error: expected type string or widget but got int in string comparison +.*32: L Error: expected type string or widget but got int in string comparison +.*34: L Error: expected type string or widget but got int in string comparison +.*35: L Error: expected type string or widget but got int in string comparison +.*36: L Error: expected type string or widget but got int in string comparison +.*37: L Error: expected type string or widget but got int in string comparison +.*38: L Error: expected type string or widget but got int in string comparison +.*39: L Error: expected type string or widget but got int in string comparison +.*40: L Error: expected type string or widget but got int in string comparison +.*41: L Error: expected type string or widget but got int in string comparison +.*42: L Error: expected type string or widget but got int in string comparison +} + +test typecheck-10.3 {check type names in type-error messages} -body { +#lang L --line=1 +class typecheck_10_3_cls {} +void typecheck_10_3() +{ + int x; + typecheck_10_3_cls obj; + + 1 eq "string"; + 1.0 eq "string"; + "string" == 1; + (widget)"s" == 1; + (void)"s" == 1; + (int{int})"s" == 1; + (struct {int i;})"s" == 1; + (int[])"s" == 1; + {1,2,3} == 1; + &x == 1; + obj == 1; +} +} -returnCodes error -match regexp -result {.*7: L Error: expected type string or widget but got int in string comparison +.*8: L Error: expected type string or widget but got float in string comparison +.*9: L Error: incompatible types in comparison +.*10: L Error: incompatible types in comparison +.*11: L Error: type void illegal +.*12: L Error: incompatible types in comparison +.*13: L Error: incompatible types in comparison +.*14: L Error: incompatible types in comparison +.*15: L Error: incompatible types in comparison +.*16: L Error: incompatible types in comparison +.*17: L Error: incompatible types in comparison +} + +test typecheck-11.1 {check FMT errors} -body { +#lang L --line=1 +void typeck_11_1_foo0(_argused FMT fmt, _argused ...args) {} +void typeck_11_1_foo1(_argused int a, _argused FMT fmt, _argused ...args) {} +void typecheck_11_1() +{ + typeck_11_1_foo0("%s"); + typeck_11_1_foo0("%s %s"); + typeck_11_1_foo0("%s %s", "bad"); + typeck_11_1_foo0("%%s %s"); + + typeck_11_1_foo1(1, "%s"); + typeck_11_1_foo1(1, "%s %s"); + typeck_11_1_foo1(1, "%s %s", "bad"); + typeck_11_1_foo1(1, "%%s %s"); + + // With some unicode. + typeck_11_1_foo0("זו ה%sשפה שלנו"); + typeck_11_1_foo0("%s זו ה%%sשפה שלנו"); + + typeck_11_1_foo0(1); // format arg not a string +} +typecheck_11_1(); +} -returnCodes error -match regexp -result {.*5: L Warning: bad format specifier +.*6: L Warning: bad format specifier +.*7: L Warning: bad format specifier +.*8: L Warning: bad format specifier +.*10: L Warning: bad format specifier +.*11: L Warning: bad format specifier +.*12: L Warning: bad format specifier +.*13: L Warning: bad format specifier +.*16: L Warning: bad format specifier +.*17: L Warning: bad format specifier +.*19: L Error: parameter 1 has incompatible type +} + +test typecheck-11.2 {check FMT errors 2} -body { +#lang L --line=1 +void typeck_11_2_foo0(_argused FMT fmt, _argused int bad) {} +void typeck_11_2_foo1(_argused FMT fmt) {} +} -returnCodes error -match regexp -result {.*1: L Error: rest argument must follow FMT +.*2: L Error: rest argument must follow FMT +} + +test typecheck-11.3 {check FMT cases where compile-time checks cannot be done} -body { +#lang L --line=1 +void typeck_11_3_foo0(_argused FMT fmt, _argused ...args) {} +void typecheck_11_3() +{ + string fmt = "%s"; + + typeck_11_3_foo0("${fmt}", "bad", "but", "no", "error"); + typeck_11_3_foo0(fmt, "bad", "but", "no", "error"); +} +typecheck_11_3(); +} -output {} + +test typecheck-11.4 {check that unicode does not confuse FMT checking} -body { +#lang L --line=1 +void typecheck_11_4() +{ + string s; + + s = sprintf("זו ה%sשפה שלנו %s", "is", "meaningless"); + unless (s == "זו הisשפה שלנו meaningless") puts("bad 1"); +} +typecheck_11_4(); +} -output {} + +test typecheck-11.5 {check more legal FMT cases} -body { +#lang L +void typecheck_11_5() +{ + string a[] = { "1", "2", "3" }; + + /* + * These are legal cases where the number of %'s in the format + * arg doesn't equal the number of subsequent args. + */ + + unless (sprintf("%1$d %1$x", 16) == "16 10") puts("bad 1"); + unless (sprintf("%*s", 6, "123") == " 123") puts("bad 2"); + unless (sprintf("%.*s", 3, "1234567890") == "123") puts("bad 3"); + unless (sprintf("%*.*s", 3, 5, "1234567890") == "12345") puts("bad 4"); + unless (sprintf("%%s") == "%s") puts("bad 5"); + + /* + * Here, the number of actuals isn't known at comile time so + * no check should be done and therefore no compile-time error + * should occur. + */ + + unless (sprintf("%s %s %s", (expand)a) == "1 2 3") puts("bad 10"); +} +typecheck_11_5(); +} -output {} + +test fnptr-1 {function pointers 1} -body { +#lang L --line=1 +typedef string &fnptr1_t(int); + +string fnptr1_doit(int x) +{ + return ("doit got ${x}"); +} +string fnptr1_foo(string &f(int)) +{ + return (f(33)); +} +string fnptr1_foo2(fnptr1_t f) +{ + return (f(44)); +} +void fnptr_1() +{ + unless (fnptr1_foo(&fnptr1_doit) eq "doit got 33") puts("bad 1"); + unless (fnptr1_foo2(&fnptr1_doit) eq "doit got 44") puts("bad 2"); +} +#lang tcl +fnptr_1 +} -output {} + +test fnptr-2 {function pointers 2} -body { +#lang L --line=1 +typedef int &fnptr2_t(poly,poly); + +/* Integer comparison. */ +int icmp(int a, int b) +{ + if (a < b) { + return -1; + } else if (a > b) { + return 1; + } else { + return 0; + } +} + +/* Unary comparison. */ +int ucmp(string a, string b) +{ + int al = strlen(a); + int bl = strlen(b); + + if (al < bl) { + return -1; + } else if (al > bl) { + return 1; + } else { + return 0; + } +} + +string fnptr2_sort(poly[] a, fnptr2_t compar) +{ + int i, swapped; + + do { + swapped = 0; + for (i = 0; i < length(a)-1; ++i) { + if (compar(a[i], a[i+1]) > 0) { + poly t = a[i]; + a[i] = a[i+1]; + a[i+1] = t; + swapped = 1; + } + } + } while (swapped); + + return ((string)a); +} + +void fnptr_2() +{ + unless (fnptr2_sort((int[])"3 1 4 1 5 9", &icmp) eq "1 1 3 4 5 9") { + puts("bad 1"); + } + unless (fnptr2_sort((string[])"111 1 1 11 111111111 11111", &ucmp) eq + "1 1 11 111 11111 111111111") { + puts("bad 2"); + } +} +#lang tcl +fnptr_2 +} -output {} + +test fnptr-3 {function pointer type errors} -body { +#lang L --line=1 -nowarn +typedef void &fp3_v_v_t(void); +typedef void &fp3_v_i_t(int); +typedef int &fp3_i_v_t(void); +typedef int &fp3_i_i_t(int); +typedef void &fp3_v_is_t(int, string); + +void fp3_v_v(void) {} +void fp3_v_i(int i) {} +int fp3_i_v(void) { return (0); } +int fp3_i_i(int i) { return (i); } +void fp3_v_is(int i, string s) {} + +void fp3f_vv (fp3_v_v_t f) { f(); } +void fp3f_vi (fp3_v_i_t f) { f(1); } +void fp3f_iv (fp3_i_v_t f) { f(); } +void fp3f_ii (fp3_i_i_t f) { f(1); } +void fp3f_vis(fp3_v_is_t f) { f(1,"s"); } + +void fnptr_3() +{ + fp3f_vv(1); + fp3f_vv(1.1); + fp3f_vv((int[])"1 2 3"); + fp3f_vv((hash)"1 2 3 4"); + fp3f_vv((struct { int i,j; })"1 2"); + + /* Try all the various error combinations, given the above types. */ + + fp3f_vv(fp3_v_v); + fp3f_vv(&fp3_v_i); + fp3f_vv(&fp3_i_v); + fp3f_vv(&fp3_i_i); + fp3f_vv(&fp3_v_is); + + fp3f_vi(fp3_v_i); + fp3f_vi(&fp3_v_v); + fp3f_vi(&fp3_i_v); + fp3f_vi(&fp3_i_i); + fp3f_vi(&fp3_v_is); + + fp3f_iv(fp3_i_v); + fp3f_iv(&fp3_v_v); + fp3f_iv(&fp3_v_i); + fp3f_iv(&fp3_i_i); + fp3f_iv(&fp3_v_is); + + fp3f_ii(fp3_i_i); + fp3f_ii(&fp3_v_v); + fp3f_ii(&fp3_v_i); + fp3f_ii(&fp3_i_v); + fp3f_ii(&fp3_v_is); + + fp3f_vis(fp3_v_is); + fp3f_vis(&fp3_v_v); + fp3f_vis(&fp3_v_i); + fp3f_vis(&fp3_i_v); + fp3f_vis(&fp3_i_i); +} +} -returnCodes error -match regexp -result {.*21: L Error: parameter 1.* +.*22: L Error: parameter 1.* +.*23: L Error: parameter 1.* +.*24: L Error: parameter 1.* +.*25: L Error: parameter 1.* +.*30: L Error: parameter 1.* +.*31: L Error: parameter 1.* +.*32: L Error: parameter 1.* +.*33: L Error: parameter 1.* +.*36: L Error: parameter 1.* +.*37: L Error: parameter 1.* +.*38: L Error: parameter 1.* +.*39: L Error: parameter 1.* +.*42: L Error: parameter 1.* +.*43: L Error: parameter 1.* +.*44: L Error: parameter 1.* +.*45: L Error: parameter 1.* +.*48: L Error: parameter 1.* +.*49: L Error: parameter 1.* +.*50: L Error: parameter 1.* +.*51: L Error: parameter 1.* +.*54: L Error: parameter 1.* +.*55: L Error: parameter 1.* +.*56: L Error: parameter 1.* +.*57: L Error: parameter 1.* +} + +test assign-1 {check assignment statement value and type} -body { +#lang L --line=1 +void +assign_1() +{ + /* + * Check type and value of "lhs = rhs". Rhs should be + * evaluated before lhs. The type of (lhs = rhs) should be + * the type of lhs and have the value of lhs. + */ + + int i, j, k; + float f, g; + string s1, s2; + int a1[], a2[], a3[]; + int h1{int}, h2{int}, h3{int}; + + i = (j = 13); + unless ((i == 13) && (j == 13)) puts("bad 1"); + + i = (j = (k = 14)); + unless ((i == 14) && (j == 14) && (k == 14)) puts("bad 2"); + + i = j = k = 14; // = should be right associative + unless ((i == 14) && (j == 14) && (k == 14)) puts("bad 2.1"); + + /* Note: exact comparisons against floats don't always work. */ + f = (g = (i = 1)); + unless ((f == 1.0) && (g == 1.0)) puts("bad 3"); + + s1 = (s2 = "ok"); + unless ((s1 eq "ok") && (s2 eq "ok")) puts("bad 4"); + + a1[0] = 3; + a3 = (a2 = a1); + unless ((a1[0] == 3) && !defined(a1[1])) puts("bad 5.1"); + unless ((a2[0] == 3) && !defined(a2[1])) puts("bad 5.2"); + unless ((a3[0] == 3) && !defined(a3[1])) puts("bad 5.3"); + + h1{1} = 4; + h3 = (h2 = h1); + unless ((h1{1} == 4) && (h2{1} == 4) && (h3{1} == 4)) puts("bad 6.1"); + foreach (i in h1) unless (i == 1) puts("bad 6.2"); + foreach (i in h2) unless (i == 1) puts("bad 6.3"); + foreach (i in h3) unless (i == 1) puts("bad 6.4"); + + /* Check that rhs is evaluated *before* lhs. */ + + i = 0; + a1[i] = (i = 2); + unless (a1[2] == 2) puts("bad 7"); + + i = 3; + a1[3] = 1; + a1[4] = 2; + a1[i] = ++i; + unless ((a1[3] == 1) && (a1[4] == 4)) puts("bad 8"); + + i = 3; + a1[3] = 1; + a1[4] = 2; + a1[i] = i++; + unless ((a1[3] == 1) && (a1[4] == 3)) puts("bad 9"); + + i = 3; + a1[3] = 1; + a1[4] = 2; + a1[i] += ++i; + unless ((a1[3] == 1) && (a1[4] == 6)) puts("bad 10"); + + i = 3; + a1[3] = 1; + a1[4] = 2; + a1[i] += i++; + unless ((a1[3] == 1) && (a1[4] == 5)) puts("bad 11"); +} +#lang tcl +assign_1 +} -output {} + +test backtrace-1.0 {backtracing in L} -setup { + set fname [makeFile { +void foo() +{ + puts("foo", "bar"); +} + +void bar() +{ + foo(); +} + +int +main() +{ + bar(); +} + + } backtrace-1.0.l] +} -constraints { + exec +} -body { + exec [interpreter] $fname +} -cleanup { + removeFile backtrace-1.0.l +} -returnCodes {error} -match regexp -result {.*line 4.*line 9.*line 15} + +test pattern-1.0 {L pattern functions} -body { +#lang L --line=1 +string Pattern1_() +{ + // This is NOT a pattern function (because the _ is trailing). + return("Pattern1_"); +} +string Pattern1_foo(int a, int b) +{ + return("Pattern1_foo ${a} ${b}"); +} +string Pattern1_*(...args) +{ + poly p; + string ret = "Pattern1_* ${$1}"; + foreach (p in args) ret .= " ${p}"; + return (ret); +} +string pattern2(...args) +{ + poly p; + string ret = "pattern2"; + foreach (p in args) ret .= " ${p}"; + return (ret); +} +string p1_0_widget(...args) +{ + poly p; + string ret = "p1_0_widget"; + foreach (p in args) ret .= " ${p}"; + return (ret); +} +void pattern_1_0() +{ + string s; + widget w = "p1_0_widget"; + + s = Pattern1_foo(1, 2); // calls Pattern1_foo(1, 2) + unless (s eq "Pattern1_foo 1 2") puts("bad 1.1"); + + s = Pattern1_bar(); // calls Pattern1_*("bar") + unless (s eq "Pattern1_* bar") puts("bad 2.1"); + s = Pattern1_bar(3); // calls Pattern1_*("bar", 3) + unless (s eq "Pattern1_* bar 3") puts("bad 2.2"); + s = Pattern1_bar(3, 4); // calls Pattern1_*("bar", 3, 4) + unless (s eq "Pattern1_* bar 3 4") puts("bad 2.3"); + s = Pattern1_foo123(1, 2); // calls Pattern1_*("foo123", 1, 2) + unless (s eq "Pattern1_* foo123 1 2") puts("bad 2.4"); + s = Pattern1_foo_(1, 2); // calls Pattern1_*("foo_", 1, 2) + unless (s eq "Pattern1_* foo_ 1 2") puts("bad 2.5"); + + s = Pattern1_Bar(); // calls Pattern1_*("bar") + unless (s eq "Pattern1_* bar") puts("bad 3.1"); + s = Pattern1_Bar(3); // calls Pattern1_*("bar", 3) + unless (s eq "Pattern1_* bar 3") puts("bad 3.2"); + s = Pattern1_Bar(3, 4); // calls Pattern1_*("bar", 3, 4) + unless (s eq "Pattern1_* bar 3 4") puts("bad 3.3"); + + s = Pattern1_barBaz(); + unless (s eq "Pattern1_* bar baz") puts("bad 4.1"); + s = Pattern1_barBaz(3); + unless (s eq "Pattern1_* bar baz 3") puts("bad 4.2"); + s = Pattern1_barBaz(3, 4); + unless (s eq "Pattern1_* bar baz 3 4") puts("bad 4.3"); + + s = Pattern1_barBazBlech(); + unless (s eq "Pattern1_* bar baz blech") puts("bad 5.1"); + s = Pattern1_barBazBlech(3); + unless (s eq "Pattern1_* bar baz blech 3") puts("bad 5.2"); + s = Pattern1_barBazBlech(3, 4); + unless (s eq "Pattern1_* bar baz blech 3 4") puts("bad 5.3"); + + s = Pattern2_bar(); // calls pattern2("bar") + unless (s eq "pattern2 bar") puts("bad 6.1"); + s = Pattern2_bar(5); // calls pattern2("bar", 5) + unless (s eq "pattern2 bar 5") puts("bad 6.2"); + s = Pattern2_bar(5, 6); // calls pattern2("bar", 5, 6) + unless (s eq "pattern2 bar 5 6") puts("bad 6.3"); + + s = Pattern2_Bar(); + unless (s eq "pattern2 bar") puts("bad 7.1"); + s = Pattern2_Bar(5); + unless (s eq "pattern2 bar 5") puts("bad 7.2"); + s = Pattern2_Bar(5, 6); + unless (s eq "pattern2 bar 5 6") puts("bad 7.3"); + + s = Pattern2_barBaz(); + unless (s eq "pattern2 bar baz") puts("bad 8.1"); + s = Pattern2_barBaz(5); + unless (s eq "pattern2 bar baz 5") puts("bad 8.2"); + s = Pattern2_barBaz(5, 6); + unless (s eq "pattern2 bar baz 5 6") puts("bad 8.3"); + + s = Pattern2_barBazBlech(); + unless (s eq "pattern2 bar baz blech") puts("bad 9.1"); + s = Pattern2_barBazBlech(5); + unless (s eq "pattern2 bar baz blech 5") puts("bad 9.2"); + s = Pattern2_barBazBlech(5, 6); + unless (s eq "pattern2 bar baz blech 5 6") puts("bad 9.3"); + + s = Pattern1_(); // calls Pattern1_() + unless (s eq "Pattern1_") puts("bad 10.1"); + + s = Pattern2_bar(w); // calls p1_0_widget("bar") + unless (s eq "p1_0_widget bar") puts("bad 20.1"); + s = Pattern2_bar(w, 1); // calls p1_0_widget("bar", 1) + unless (s eq "p1_0_widget bar 1") puts("bad 20.2"); + s = Pattern2_bar(w, 1, 2); // calls p1_0_widget("bar", 1, 2) + unless (s eq "p1_0_widget bar 1 2") puts("bad 20.3"); + + s = Pattern2_Bar(w); + unless (s eq "p1_0_widget bar") puts("bad 21.1"); + s = Pattern2_Bar(w, 1); + unless (s eq "p1_0_widget bar 1") puts("bad 21.2"); + s = Pattern2_Bar(w, 1, 2); + unless (s eq "p1_0_widget bar 1 2") puts("bad 21.3"); + + s = Pattern2_barBaz(w); + unless (s eq "p1_0_widget bar baz") puts("bad 22.1"); + s = Pattern2_barBaz(w, 1); + unless (s eq "p1_0_widget bar baz 1") puts("bad 22.2"); + s = Pattern2_barBaz(w, 1, 2); + unless (s eq "p1_0_widget bar baz 1 2") puts("bad 22.3"); + + s = Pattern2_barBazBlech(w); + unless (s eq "p1_0_widget bar baz blech") puts("bad 23.1"); + s = Pattern2_barBazBlech(w, 1); + unless (s eq "p1_0_widget bar baz blech 1") puts("bad 23.2"); + s = Pattern2_barBazBlech(w, 1, 2); + unless (s eq "p1_0_widget bar baz blech 1 2") puts("bad 23.3"); +} +pattern_1_0(); +} -output {} + +test pattern-1.2 {check pattern function argument type checking} -body { +#lang L --line=1 -nowarn +void Pattern120_*() {} +void Pattern121_*(int a) {} +void Pattern122_*(int a, int b) {} +void pattern_1_2() +{ + Pattern120_foo(1); + Pattern121_foo(); + Pattern121_foo(1,2); + Pattern122_foo(); + Pattern122_foo(1); + Pattern122_foo(1,2,3); +} +pattern_1_2(); +} -returnCodes {error} -match regexp -result {.*6: L Error: too many arguments for function Pattern120_foo +.*7: L Error: not enough arguments for function Pattern121_foo +.*8: L Error: too many arguments for function Pattern121_foo +.*9: L Error: not enough arguments for function Pattern122_foo +.*10: L Error: not enough arguments for function Pattern122_foo +.*11: L Error: too many arguments for function Pattern122_foo +} + +test pattern-1.3 {check pattern function call with (expand) args} -body { +#lang L --line=1 +string pattern13(...args) +{ + poly p; + string ret = "pattern13"; + foreach (p in args) ret .= " ${p}"; + return (ret); +} +void pattern_1_3() +{ + int i; + string got, want; + string args[], args2[]; + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo((expand)args); + want = "pattern13 foo"; + if (length(args)) want .= " " . join(" ", args); + unless (got eq want) { + printf("bad 1.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo((expand)args, "a"); + want = "pattern13 foo"; + if (length(args)) want .= " " . join(" ", args); + want .= " a"; + unless (got eq want) { + printf("bad 2.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo((expand)args, "a", "b"); + want = "pattern13 foo"; + if (length(args)) want .= " " . join(" ", args); + want .= " a b"; + unless (got eq want) { + printf("bad 3.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo((expand)args, "a", "b", "c"); + want = "pattern13 foo"; + if (length(args)) want .= " " . join(" ", args); + want .= " a b c"; + unless (got eq want) { + printf("bad 4.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBar((expand)args); + want = "pattern13 foo bar"; + if (length(args)) want .= " " . join(" ", args); + unless (got eq want) { + printf("bad 5.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBar((expand)args, "a"); + want = "pattern13 foo bar"; + if (length(args)) want .= " " . join(" ", args); + want .= " a"; + unless (got eq want) { + printf("bad 6.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBar((expand)args, "a", "b"); + want = "pattern13 foo bar"; + if (length(args)) want .= " " . join(" ", args); + want .= " a b"; + unless (got eq want) { + printf("bad 7.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBar((expand)args, "a", "b", "c"); + want = "pattern13 foo bar"; + if (length(args)) want .= " " . join(" ", args); + want .= " a b c"; + unless (got eq want) { + printf("bad 8.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBarBaz((expand)args); + want = "pattern13 foo bar baz"; + if (length(args)) want .= " " . join(" ", args); + unless (got eq want) { + printf("bad 9.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBarBaz((expand)args, "a"); + want = "pattern13 foo bar baz"; + if (length(args)) want .= " " . join(" ", args); + want .= " a"; + unless (got eq want) { + printf("bad 10.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBarBaz((expand)args, "a", "b"); + want = "pattern13 foo bar baz"; + if (length(args)) want .= " " . join(" ", args); + want .= " a b"; + unless (got eq want) { + printf("bad 11.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBarBaz((expand)args, "a", "b", "c"); + want = "pattern13 foo bar baz"; + if (length(args)) want .= " " . join(" ", args); + want .= " a b c"; + unless (got eq want) { + printf("bad 12.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + args2 = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo((expand)args, (expand)args2, "a"); + want = "pattern13 foo"; + if (length(args)) want .= " " . join(" ", args); + want .= " a"; + unless (got eq want) { + printf("bad 20.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + args2 = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo((expand)args, (expand)args2, "a"); + want = "pattern13 foo"; + if (length(args)) want .= " " . join(" ", args); + if (length(args2)) want .= " " . join(" ", args2); + want .= " a"; + unless (got eq want) { + printf("bad 20.2 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + args2[END+1] = (string)(i*100); + } + + args = {}; + args2 = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo((expand)args, "a", (expand)args2); + want = "pattern13 foo"; + if (length(args)) want .= " " . join(" ", args); + want .= " a"; + if (length(args2)) want .= " " . join(" ", args2); + unless (got eq want) { + printf("bad 20.3 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + args2[END+1] = (string)(i*100); + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo("a", (expand)args); + want = "pattern13 foo a"; + if (length(args)) want .= " " . join(" ", args); + unless (got eq want) { + printf("bad 21.1 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_foo("a", "b", (expand)args); + want = "pattern13 foo a b"; + if (length(args)) want .= " " . join(" ", args); + unless (got eq want) { + printf("bad 21.2 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBar("a", (expand)args); + want = "pattern13 foo bar a"; + if (length(args)) want .= " " . join(" ", args); + unless (got eq want) { + printf("bad 21.3 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } + + args = {}; + for (i = 0; i < 10; ++i) { + got = Pattern13_fooBar("a", "b", (expand)args); + want = "pattern13 foo bar a b"; + if (length(args)) want .= " " . join(" ", args); + unless (got eq want) { + printf("bad 21.4 got '%s' want '%s'\n", got, want); + } + args[END+1] = (string)i; + } +} +pattern_1_3(); +} -output {} + +test include-1.0 {include files} -setup { + set fname [makeFile { + ++include_1_0; + unless (basename(__FILE__) eq "foo-1.0.l") puts("bad 1"); + unless (__LINE__ == 4) puts("bad 2"); + } foo-1.0.l [file dirname [info script]]] +} -body { +#lang L --line=1 +int include_1_0 = 0; +puts(include_1_0); +#include "foo-1.0.l" +puts(include_1_0); +// Check variations in spacing and punctation. +// The compiler should include foo-1.0.l only once. +#include"foo-1.0.l" +#include "foo-1.0.l" +#include "foo-1.0.l" +#include "foo-1.0.l" +#include"foo-1.0.l" +puts(include_1_0); +} -cleanup { + removeFile $fname +} -output {0 +1 +1 +} + +test include-1.1 {nested include files} -setup { +# +# The code for these files isn't indented because L recognizes +# include() only when it starts at the beginning of the line. +# + set fname1 [makeFile {#include "foo-1.1-2.l" +unless (basename(__FILE__) eq "foo-1.1-1.l") puts("bad 1.1"); +unless (__LINE__ == 3) puts("bad 1.2 ${__LINE__}"); +} foo-1.1-1.l [file dirname [info script]]] + set fname2 [makeFile {unless (__LINE__ == 1) puts("bad 2.1"); +int include_1_1a = 3; +unless (basename(__FILE__) eq "foo-1.1-2.l") puts("bad 2.2"); +unless (__LINE__ == 4) puts("bad 2.3"); +#include "foo-1.1-3.l" +unless (basename(__FILE__) eq "foo-1.1-2.l") puts("bad 2.4"); +unless (__LINE__ == 7) puts("bad 2.5 ${__LINE__}"); +} foo-1.1-2.l .] + set fname3 [makeFile { +int include_1_1b = 4; +unless (basename(__FILE__) eq "foo-1.1-3.l") puts("bad 3.1"); +unless (__LINE__ == 4) puts("bad 3.2"); +} foo-1.1-3.l .] +} -body { +#lang L --line=1 +#include "foo-1.1-1.l" +unless (include_1_1a == 3) puts("bad 10.1"); +unless (include_1_1b == 4) puts("bad 10.2"); +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 +} -output {} + +test include-1.2 {malformed includes} -body { +#lang L --line=1 +#include " +#include < +#include "" +#include <> +} -returnCodes {error} -match regexp -result {.*1: L Error: malformed #include +.*2: L Error: malformed #include +.*3: L Error: malformed #include +.*4: L Error: malformed #include +} + +test include-1.3 {test line number tracking with include files} -setup { + set fname1 [makeFile {int include_1_3a = "bad1"; +#include "foo-1.3-2.l"} foo-1.3-1.l [file dirname [info script]]] + set fname2 [makeFile {int include_1_3b = "bad2"; +#include "foo-1.3-3.l" +int include_1_3c = "bad3";} foo-1.3-2.l .] + set fname3 [makeFile {int include_1_3d = "bad4";} foo-1.3-3.l .] +} -body { +#lang L --line=1 +int include_1_3 = "bad0"; +#include "foo-1.3-1.l" +int include_1_3last = "badn"; +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 +} -returnCodes {error} -match regexp -result {.*1: L Error: assignment of incompatible types +.*foo-1.3-1.l:1: L Error: assignment of incompatible types +.*foo-1.3-2.l:1: L Error: assignment of incompatible types +.*foo-1.3-3.l:1: L Error: assignment of incompatible types +.*foo-1.3-2.l:3: L Error: assignment of incompatible types +.*3: L Error: assignment of incompatible types +} + +test include-1.4 {test missing include file} -body { +#lang L --line=1 +#include "does-not-exist.l" +} -returnCodes {error} -match regexp -result {.*1: L Error: cannot find include file does-not-exist.l +} + +# Create files with the same names in $BIN/mydir, $BIN/include, and in +# the cwd of the L script, and ensure that the one specified by an +# absolute path (to mydir) gets included, where $BIN is where the +# running tclsh lives. +test include-1.5 {test include "/abs/path" search path} -setup { + set mydir [makeDirectory mydir [file dirname [interpreter]]] + set incdir [makeDirectory include [file dirname [interpreter]]] + set fname1 [makeFile {puts("good");} f-1.5-1.l $mydir] + set fname2 [makeFile {puts("bad");} f-1.5-1.l $incdir] + set fname3 [makeFile {puts("bad");} f-1.5-1.l .] + set script [makeFile "#include \"$mydir/f-1.5-1.l\"" f-1.5-scr.l .] +} -constraints { + exec +} -body { + exec [interpreter] $script +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 + removeFile $script + removeDirectory $mydir + removeDirectory $incdir +} -result {good} + +# Create files with the same names in $BIN/include and in +# the cwd of the L script, and ensure that #include "file.l" includes +# the one in the cwd, where $BIN is where the running tclsh lives. +test include-1.6 {test include "file" search path} -setup { + set incdir [makeDirectory include [file dirname [interpreter]]] + set fname1 [makeFile {puts("bad");} f-1.6-1.l $incdir] + set fname2 [makeFile {puts("good");} f-1.6-1.l .] + set script [makeFile "#include \"f-1.6-1.l\"" f-1.6-scr.l .] +} -constraints { + exec +} -body { + exec [interpreter] $script +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $script + removeDirectory $incdir +} -result {good} + +# Create files with the same names in $BIN/include and in +# the cwd of the L script, and ensure that #include <file.l> includes +# the one in $BIN, where $BIN is where the running tclsh lives. +test include-1.7 {test include <file> search path 1} -setup { + set incdir [makeDirectory include [file dirname [interpreter]]] + set fname1 [makeFile {puts("good");} f-1.7-1.l $incdir] + set fname2 [makeFile {puts("bad");} f-1.7-1.l .] + set script [makeFile "#include <f-1.7-1.l>" f-1.7-scr.l .] +} -constraints { + exec +} -body { + exec [interpreter] $script +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $script + removeDirectory $incdir +} -result {good} + +# Ensure that #include <file.l> finds file.l in $BIN/include, +# where $BIN is where the running tclsh lives. +test include-1.8 {test include <file> search path 1} -setup { + set incdir [makeDirectory include [file dirname [interpreter]]] + set fname1 [makeFile {puts("good");} f-1.8-1.l $incdir] + set script [makeFile "#include <f-1.8-1.l>" f-1.8-scr.l .] +} -constraints { + exec +} -body { + exec [interpreter] $script +} -cleanup { + removeFile $fname1 + removeFile $script + removeDirectory $incdir +} -result {good} + +test include-2.1 {nested include files almost nested too deeply} -setup { + set fname1 [makeFile {#include "f-1.2.l"} f-1.1.l [file dirname [info script]]] + set fname2 [makeFile {#include "f-1.3.l"} f-1.2.l .] + set fname3 [makeFile {#include "f-1.4.l"} f-1.3.l .] + set fname4 [makeFile {#include "f-1.5.l"} f-1.4.l .] + set fname5 [makeFile {#include "f-1.6.l"} f-1.5.l .] + set fname6 [makeFile {#include "f-1.7.l"} f-1.6.l .] + set fname7 [makeFile {#include "f-1.8.l"} f-1.7.l .] + set fname8 [makeFile {#include "f-1.9.l"} f-1.8.l .] + set fname9 [makeFile {#include "f-1.10.l"} f-1.9.l .] + set fname10 [makeFile {#include "f-1.11.l"} f-1.10.l .] + set fname11 [makeFile {printf("ok");} f-1.11.l .] +} -body { +#lang L --line=1 +#include "f-1.1.l" +} -output {ok} + +test include-2.2 {nested include files nested too deeply} -setup { + set fname1 [makeFile {#include "f-2.2.l"} f-2.1.l [file dirname [info script]]] + set fname2 [makeFile {#include "f-2.3.l"} f-2.2.l .] + set fname3 [makeFile {#include "f-2.4.l"} f-2.3.l .] + set fname4 [makeFile {#include "f-2.5.l"} f-2.4.l .] + set fname5 [makeFile {#include "f-2.6.l"} f-2.5.l .] + set fname6 [makeFile {#include "f-2.7.l"} f-2.6.l .] + set fname7 [makeFile {#include "f-2.8.l"} f-2.7.l .] + set fname8 [makeFile {#include "f-2.9.l"} f-2.8.l .] + set fname9 [makeFile {#include "f-2.10.l"} f-2.9.l .] + set fname10 [makeFile {#include "f-2.11.l"} f-2.10.l .] + set fname11 [makeFile {#include "f-2.12.l"} f-2.11.l .] + set fname12 [makeFile {printf("ok");} f-2.12.l .] +} -body { +#lang L --line=1 +#include "f-2.1.l" +} -returnCodes {error} -match regexp -result {f-2.11.l:1: L Error: include file nesting too deep -- aborting +} + +# This test creates two slave interps that declare global symbols +# with the same names as those declared in the master interp. +# If the L global state is properly kept per-interp, there +# should be no multiple-declaration errors. + +test interp-1 {test per-interp global state} -body { +#lang L --line=1 +int interp_1_g; +void interp_1_foo() {} + +#lang tcl +interp create interp_1_1 +interp eval interp_1_1 { +#lang L --line=1 +int interp_1_g; +void interp_1_foo() {} +} +interp create interp_1_2 +interp eval interp_1_2 { +#lang L --line=1 +int interp_1_g; +void interp_1_foo() {} +} +interp delete interp_1_2 +interp delete interp_1_1 +} -output {} + +test split-1.0 {test split function} -body { +#lang L --line=1 +void +split_1_0() +{ + int m; + string s; + string r[]; + widget w; + + /* These are all white space. */ + string allspace[] = { + "", + " ", + " ", + " ", + " ", + "\n", + "\t", + "\n\n" }; + + foreach (s in allspace) { + r = split(s); + if (defined(r[0])) printf("bad 1: '%s'\n", s); + } + + /* + * A split followed by a join should give the string back. + */ + + s = "This is not a test. This is really not a test."; + r = split(s); + unless (s eq join(" ", r)) puts("bad 2.1"); + + s = "This:is:not:a:test.:This:is:really:not:a:test."; + r = split(/:/, s); + unless (s eq join(":", r)) puts("bad 2.3"); + + s = ":This:is:not:a:test.:This:is:really:not:a:test."; + r = split(/:/, s); + unless (s eq join(":", r)) puts("bad 2.4"); + + /* + * A split with no regexp should split on white space but + * return no null field for any initial white space. + * A split on / / can return initial null fields however. + */ + + r = split(" has one"); + unless ((r[0] eq "has") && (r[1] eq "one")) puts("bad 3.1"); + unless (length(r) == 2) puts("bad 3.2"); + + r = split(/ /, "has none"); + unless ((r[0] eq "has") && (r[1] eq "none")) puts("bad 3.3"); + unless (length(r) == 2) puts("bad 3.4"); + + r = split(/ /, " has one"); + unless ((r[0] eq "") && (r[1] eq "has") && + (r[2] eq "one")) puts("bad 3.5"); + unless (length(r) == 3) puts("bad 3.6"); + + /* Trailing white space never produces a null field. */ + + r = split("trail "); + unless (r[0] eq "trail") puts("bad 4.1"); + unless (length(r) == 1) puts("bad 4.2"); + + r = split(/ /, "trail "); + unless (r[0] eq "trail") puts("bad 4.3"); + unless (length(r) == 1) puts("bad 4.4"); + + r = split(/ /, "trail "); + unless (r[0] eq "trail") puts("bad 4.5"); + unless (length(r) == 1) puts("bad 4.6"); + + /* + * If all result fields are null, they are considered to be + * trailing and should not be returned. + */ + + r = split(/x/, "xxx"); + unless (length(r) == 0) puts("bad 4.7"); + + r = split(/x/, "xxx"); + unless (length(r) == 0) puts("bad 4.8"); + + r = split(/xx/, "xxxxxx"); + unless (length(r) == 0) puts("bad 4.9"); + + r = split(/xx/, "xxxxxx"); + unless (length(r) == 0) puts("bad 4.10"); + + r = split(/two/, "twotwotwo"); + unless (length(r) == 0) puts("bad 4.11"); + + r = split(/two/, "twotwotwo"); + unless (length(r) == 0) puts("bad 4.12"); + + /* Check split on a regexp. */ + + r = split(/[abc]/, "XaXbXcX"); + unless ((r[0] eq "X") && (r[1] eq "X") && (r[2] eq "X") && + (r[3] eq "X")) { + puts("bad 5.3"); + } + unless (length(r) == 4) puts("bad 5.4"); + + r = split(/[abc]/, "XaaXbXcX"); + unless ((r[0] eq "X") && (r[1] eq "") && (r[2] eq "X") && + (r[3] eq "X") && (r[4] eq "X")) { + puts("bad 5.5"); + } + unless (length(r) == 5) puts("bad 5.6"); + + r = split(/xx/, "xxxyxx"); + unless ((r[0] eq "") && (r[1] eq "xy")) { + puts("bad 5.11"); + } + unless (length(r) == 2) puts("bad 5.12"); + + /* A match at the end never produces a trailing null field. */ + + r = split(/d/, "abcd"); + unless (r[0] eq "abc") puts("bad 5.15"); + unless (length(r) == 1) puts("bad 5.16"); + + r = split(/def/, "abcdef"); + unless (r[0] eq "abc") puts("bad 5.17"); + unless (length(r) == 1) puts("bad 5.18"); + + /* A match on the first char always produces a null field. */ + + r = split(/a/, "abcd"); + unless ((r[0] eq "") && (r[1] eq "bcd")) puts("bad 5.19"); + unless (length(r) == 2) puts("bad 5.20"); + + /* Test interpolated regexp. */ + + s = "abc"; + r = split(/[${s}]/, "XaXbXcX"); + unless ((r[0] eq "X") && (r[1] eq "X") && (r[2] eq "X") && + (r[3] eq "X")) { + puts("bad 6.1"); + } + unless (length(r) == 4) puts("bad 6.2"); + + /* Test limits, regexp match. */ + + r = split(/ /, "1 2 3 4", 4); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3") && + (r[3] eq "4")) { + puts("bad 7.17"); + } + unless (length(r) == 4) puts("bad 7.18"); + + r = split(/ /, "1 2 3 4", 3); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3 4")) { + puts("bad 7.19"); + } + unless (length(r) == 3) puts("bad 7.20"); + + r = split(/ /, "1 2 3 4", 2); + unless ((r[0] eq "1") && (r[1] eq "2 3 4")) puts("bad 7.21"); + unless (length(r) == 2) puts("bad 7.22"); + + r = split(/ /, "1 2 3 4", 1); + unless (r[0] eq "1 2 3 4") puts("bad 7.23"); + unless (length(r) == 1) puts("bad 7.24"); + + r = split(/ /, "1 2 3 4", 0); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3") && + (r[3] eq "4")) { + puts("bad 7.25"); + } + unless (length(r) == 4) puts("bad 7.26"); + + r = split(/ /, "1 2 3 4", -1); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3") && + (r[3] eq "4")) { + puts("bad 7.27"); + } + unless (length(r) == 4) puts("bad 7.28"); + + /* Test limits, multi-char match. */ + + r = split(/aa/, "1aa2aa3aa4", 5); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3") && + (r[3] eq "4")) { + puts("bad 7.30"); + } + unless (length(r) == 4) puts("bad 7.31"); + + r = split(/aa/, "1aa2aa3aa4", 4); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3") && + (r[3] eq "4")) { + puts("bad 7.32"); + } + unless (length(r) == 4) puts("bad 7.33"); + + r = split(/aa/, "1aa2aa3aa4", 3); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3aa4")) { + puts("bad 7.34"); + } + unless (length(r) == 3) puts("bad 7.35"); + + r = split(/aa/, "1aa2aa3aa4", 2); + unless ((r[0] eq "1") && (r[1] eq "2aa3aa4")) puts("bad 7.36"); + unless (length(r) == 2) puts("bad 7.37"); + + r = split(/aa/, "1aa2aa3aa4", 1); + unless (r[0] eq "1aa2aa3aa4") puts("bad 7.38"); + unless (length(r) == 1) puts("bad 7.39"); + + r = split(/aa/, "1aa2aa3aa4", 0); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3") && + (r[3] eq "4")) { + puts("bad 7.40"); + } + unless (length(r) == 4) puts("bad 7.41"); + + r = split(/aa/, "1aa2aa3aa4", -1); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3") && + (r[3] eq "4")) { + puts("bad 7.42"); + } + unless (length(r) == 4) puts("bad 7.43"); + + /* Test that an escape of the regexp delimeter works. */ + + r = split(/\//, "/this/is/a/pathname"); + unless ((r[0] eq "") && (r[1] eq "this") && (r[2] eq "is") && + (r[3] eq "a") && (r[4] eq "pathname")) { + puts("bad 8.1"); + } + unless (length(r) == 5) puts("bad 8.2"); + + /* Ensure third arg is not parsed as a regexp. */ + + m = 3; + r = split(/ /, "1 2 3 4", m); + unless ((r[0] eq "1") && (r[1] eq "2") && (r[2] eq "3 4")) { + puts("bad 9.7"); + } + unless (length(r) == 3) puts("bad 9.8"); + + /* Split on a multi-character delimeter. */ + + r = split(/two/, "onetwothreetwofourtwo"); + unless ((r[0] eq "one") && (r[1] eq "three") && (r[2] eq "four")) { + puts("bad 10.7"); + } + unless (length(r) == 3) puts("bad 10.8"); + + r = split(/two/, "twoonetwo"); + unless ((r[0] eq "") && (r[1] eq "one")) { + puts("bad 10.9"); + } + unless (length(r) == 2) puts("bad 10.10"); + + r = split(/two/, "nomatches"); + unless (r[0] eq "nomatches") { + puts("bad 10.11"); + } + unless (length(r) == 1) puts("bad 10.12"); + + /* Split on an empty regexp. */ + + r = split(//, "abc"); + unless ((r[0] eq "a") && (r[1] eq "b") && (r[2] eq "c")) { + puts("bad 12.1"); + } + unless (length(r) == 3) puts("bad 12.2"); + + /* Split on a widget should work. */ + + w = "axbxc"; + r = split(/x/, w); + unless ((r[0] eq "a") && (r[1] eq "b") && (r[2] eq "c")) { + puts("bad 13.1"); + } + unless (length(r) == 3) puts("bad 13.2"); + + /* + * Check splitting on a regexp w/trimming leading null fields + * from the result. + */ + + r = split(/ /t, " A B"); + unless ((r[0] eq "A") && (r[1] eq "B")) puts("bad 14.1"); + unless (length(r) == 2) puts("bad 14.2"); + + r = split(/ /t, " A B"); + unless ((r[0] eq "A") && (r[1] eq "B")) puts("bad 14.3"); + unless (length(r) == 2) puts("bad 14.4"); + + r = split(/ /t, " A B "); + unless ((r[0] eq "A") && (r[1] eq "") && (r[2] eq "B")) puts("bad 14.5"); + unless (length(r) == 3) puts("bad 14.6"); +} +split_1_0(); +} -output {} + +test split-1.1 {test split regexp alternate delim syntax} -body { +#lang L +void split_1_1() +{ + string m, mm, mvar, r[], re; + + r = split(m|\n|, "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.1"); + + r = split(m:\n:, "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.2"); + + r = split(m,\n,, "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.3"); + + r = split(m"\n", "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.3.1"); + + r = split(m!\n!, "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.3.2"); + + /* Test some interpolations inside the regexp. */ + + re = '\n'; + r = split(m|${re}|, "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.4"); + + re = '\n'; + r = split(m$${re}$, "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.5"); + + re = '\n'; + r = split(m{${re}}, "l1\nl2\nl3\n"); + unless (eq(r, {"l1","l2","l3"})) puts("bad 1.6"); + + re = "y"; + r = split(m|x${re}|, "axybxyc"); + unless (eq(r, {"a","b","c"})) puts("bad 1.8"); + + re = "x"; + r = split(m|${re}y|, "axybxyc"); + unless (eq(r, {"a","b","c"})) puts("bad 1.9"); + + re = "y"; + r = split(m|x${re}z|, "axyzbxyzc"); + unless (eq(r, {"a","b","c"})) puts("bad 1.10"); + + /* Test regexp modifiers. */ + + r = split(m|x|, "xaxbXcXdx"); + unless (eq(r, {"","a","bXcXd"})) puts("bad 2.1 ${r}"); + + r = split(m|x|t, "xaxbXcXdx"); + unless (eq(r, {"a","bXcXd"})) puts("bad 2.2 ${r}"); + + r = split(m|x|i, "xaxbXcXdx"); + unless (eq(r, {"","a","b","c","d"})) puts("bad 2.3 ${r}"); + + r = split(m|x|it, "xaxbXcXdx"); + unless (eq(r, {"a","b","c","d"})) puts("bad 2.4 ${r}"); + + r = split(m|x|ti, "xaxbXcXdx"); + unless (eq(r, {"a","b","c","d"})) puts("bad 2.5 ${r}"); + + /* + * Test splitting on a variable named "m" or whose name begins + * with "m". + */ + + m = "l1\nl2\nl3\n"; + r = split(m); + unless (eq(r, {"l1","l2","l3"})) puts("bad 3.1"); + + mm = "l1\nl2\nl3\n"; + r = split(mm); + unless (eq(r, {"l1","l2","l3"})) puts("bad 3.2"); + + mvar = "l1\nl2\nl3\n"; + r = split(mvar); + unless (eq(r, {"l1","l2","l3"})) puts("bad 3.3"); +} +split_1_1(); +} -output {} + +test split-2 {test split errors} -body { +#lang L --line=1 +void split_2() +{ + split(/re/g, "bad"); + split(/re/ig, "bad"); +} +} -returnCodes error -match regexp -result {.*3: L Error: illegal regular expression modifier +.*4: L Error: illegal regular expression modifier +} + +test split-3 {test split errors 2} -body { +#lang L --line=1 +void split_3() +{ + /* + * This is a syntax error because the grammar special-cases + * split() because the 1st arg can be a regexp or a string, + * and does not allow no args. + */ + split(); +} +} -returnCodes error -match regexp -result {.*8: L Error: syntax error, unexpected \) +} + +test split-4 {test split errors 3} -body { +#lang L --line=1 +void split_4() +{ + split(/delim/, "str", 0, 0); + split(0); + split(/delim/, "str", "bad"); + split("bad delim", "str"); + split("bad delim", "str", 0); +} +} -returnCodes error -match regexp -result {.*3: L Error: too many args to split +.*4: L Error: expression to split must be string +.*5: L Error: third arg to split must be integer +.*6: L Error: split delimiter must be a regular expression +.*7: L Error: split delimiter must be a regular expression +} + +test split-5 {test split errors 4 -- bad regexp} -body { +#lang L --line=1 +void split_5() +{ + split(/+/, "str"); +} +split_5(); +} -returnCodes error -result {couldn't compile pcre pattern: nothing to repeat} +#' + +test split-8 {test m() as arg to split} -setup { + makeFile { + /* + * Put this in its own file to avoid polluting + * the global name space with a function m(). + */ + string m(...args) + { + string ret = "", s; + + foreach (s in args) ret .= s; + return (ret); + } + void main() + { + string s[]; + + s = split(m()); + if (length(s)) puts("bad 1"); + + s = split(m("x")); + unless (eq(s, {"x"})) puts("bad 2"); + + s = split(m("x"," ","y")); + unless (eq(s, {"x","y"})) puts("bad 3"); + } + } split-8.l +} -body { +#lang L +void split_8() +{ + int ret; + string tclsh = interpreter(); + string out, err; + + ret = system({tclsh, "split-8.l"}, undef, &out, &err); + unless (ret == 0) puts("bad 1.1"); + if (out) puts("bad 1.2: ${out}"); + if (err) puts("bad 1.3: ${err}"); +} +split_8(); +} -output {} + +test consts-1.0 {test constants function} -body { +#lang L --line=1 +void +constants_1_0() +{ + int i; + float f; + + /* + * Adding 0 to these forces Tcl to shimmer them to a numeric type. + */ + + i = 0 + 0; + unless ((tcl)i eq "0") puts("bad 1.1"); + i = 00 + 0; + unless ((tcl)i eq "0") puts("bad 1.2"); + i = 000 + 0; + unless ((tcl)i eq "0") puts("bad 1.3"); + i = 1234 + 0; + unless ((tcl)i eq "1234") puts("bad 1.4"); + i = 01235 + 0; + unless ((tcl)i eq "1235") puts("bad 1.5"); + i = 001236 + 0; + unless ((tcl)i eq "1236") puts("bad 1.6"); + i = 10000000000 + 0; // >32 bits + unless ((tcl)i eq "10000000000") puts("bad 1.7"); + i = 36893488147419103232 + 0; // >64 bits + unless ((tcl)i eq "36893488147419103232") puts("bad 1.8"); + i = 314159265358979323846264338327950288 + 1; // even bigger + unless ((tcl)i eq "314159265358979323846264338327950289") { + puts("bad 1.9"); + } + i = 111111111111111111111111111111 + 222222222222222222222222222222; + unless ((tcl)i eq "333333333333333333333333333333") { + puts("bad 1.10"); + } + + i = 0xdeadbeef + 0; + unless ((tcl)i eq "3735928559") puts("bad 2.1"); + i = 0xdeadbeefbadb0bad + 0; // 64 bits + unless ((tcl)i eq "16045690984232324013") puts("bad 2.2"); + i = 0xdeadbeefbadb0badb0 + 0; // >64 bits + unless ((tcl)i eq "4107696891963474947504") puts("bad 2.3"); + + i = 0o755 + 0; + unless ((tcl)i eq "493") puts("bad 3.1"); + i = 0o0756 + 0; + unless ((tcl)i eq "494") puts("bad 3.2"); + + f = 1234.5678 + 0.0; + unless (sprintf("%.4f", f) eq "1234.5678") puts("bad 4.1"); +} +constants_1_0(); +} -output {} + +# These tests check the L compiler's mapping between the source-file +# offsets of each "command" and the tcl bytecodes generated for it. +# Generally speaking, a command is a statement or expression, although +# some statements don't generate a mapping per-se (like "if" +# statements). This is tested by generating a bytecode disassembly +# and checking that the text of the commands were identified properly +# in various syntactic contexts. This seems like the only way to get +# at the mappings easily for testing. + +test src-mappings-1 {test bytecode <-> source-file-offset mappings 1} -body { +#lang L --line=1 -nowarn +struct sm1 { + int i; +}; +void +src_mappings_1() +{ + /* + * This test checks the mappings for declarations. + * Note: avoid tabs in the source to make the test regexp clearer. + */ + + int i1; + int i2 = 2; + int i3, i4; + int i5, i6 = 6, i7; + string s1; + string s2 = "str2"; + string s3, s4; + string s5, s6 = "str6", s7; + float f1; + float f2 = 2.0; + float f3, f4; + float f5, f6 = 6.0, f7; + /* The hash ones test typedef names (hash is a typedef). */ + hash h1; + hash h2 = {2=>2}; + hash h3, h4; + hash h5, h6 = {6=>6}, h7; + struct sm1 st1; + struct sm1 st2 = {2}; + struct sm1 st3, st4; + struct sm1 st5, st6 = {6}, st7; + poly p1; + poly p2 = 2; + poly p3, p4; + poly p5, p6 = 6, p7; + widget w1; + widget w2 = "w2"; + widget w3, w4; + widget w5, w6 = "w6", w7; + int ai1[]; + int ai2[2]; + int ai3[] = {3}; + int ai4[], ai5[5]; + int ai6[], ai7[] = {7}, ai8[]; + string as1[]; + string as2[2]; + string as3[] = {"3"}; + string as4[], as5[5]; + string as6[], as7[] = {"7"}, as8[]; + float af1[]; + float af2[2]; + float af3[] = {3.0}; + float af4[], af5[5]; + float af6[], af7[] = {7.0}, af8[]; + hash ah1[]; + hash ah2[2]; + hash ah3[], ah4[4], ah5[]; + struct s ast1[]; + struct s ast2[2]; + struct s ast3[], ast4[4], ast5[]; + + puts(::tcl::unsupported::disassemble("proc", "src_mappings_1")); + return; +} +#lang tcl +src_mappings_1 +} -match regexp -output {.*Command \d+: "i1" +.*Command \d+: "i2 = 2" +.*Command \d+: "i3" +.*Command \d+: "i4" +.*Command \d+: "i5" +.*Command \d+: "i6 = 6" +.*Command \d+: "i7" +.*Command \d+: "s1" +.*Command \d+: "s2 = \\"str2\\"" +.*Command \d+: "s3" +.*Command \d+: "s4" +.*Command \d+: "s5" +.*Command \d+: "s6 = \\"str6\\"" +.*Command \d+: "s7" +.*Command \d+: "f1" +.*Command \d+: "f2 = 2.0" +.*Command \d+: "f3" +.*Command \d+: "f4" +.*Command \d+: "f5" +.*Command \d+: "f6 = 6.0" +.*Command \d+: "f7" +.*Command \d+: "h1" +.*Command \d+: "h2 = \{2=>2\}" +.*Command \d+: "h3" +.*Command \d+: "h4" +.*Command \d+: "h5" +.*Command \d+: "h6 = \{6=>6\}" +.*Command \d+: "h7" +.*Command \d+: "st1" +.*Command \d+: "st2 = \{2\}" +.*Command \d+: "st3" +.*Command \d+: "st4" +.*Command \d+: "st5" +.*Command \d+: "st6 = \{6\}" +.*Command \d+: "st7" +.*Command \d+: "p1" +.*Command \d+: "p2 = 2" +.*Command \d+: "p3" +.*Command \d+: "p4" +.*Command \d+: "p5" +.*Command \d+: "p6 = 6" +.*Command \d+: "p7" +.*Command \d+: "w1" +.*Command \d+: "w2 = \\"w2\\"" +.*Command \d+: "w3" +.*Command \d+: "w4" +.*Command \d+: "w5" +.*Command \d+: "w6 = \\"w6\\"" +.*Command \d+: "w7" +.*Command \d+: "ai1\[\]" +.*Command \d+: "ai2\[2\]" +.*Command \d+: "ai3\[\] = \{3\}" +.*Command \d+: "ai4\[\]" +.*Command \d+: "ai5\[5\]" +.*Command \d+: "ai6\[\]" +.*Command \d+: "ai7\[\] = \{7\}" +.*Command \d+: "ai8\[\]" +.*Command \d+: "as1\[\]" +.*Command \d+: "as2\[2\]" +.*Command \d+: "as3\[\] = \{\\"3\\"\}" +.*Command \d+: "as4\[\]" +.*Command \d+: "as5\[5\]" +.*Command \d+: "as6\[\]" +.*Command \d+: "as7\[\] = \{\\"7\\"\}" +.*Command \d+: "as8\[\]" +.*Command \d+: "af1\[\]" +.*Command \d+: "af2\[2\]" +.*Command \d+: "af3\[\] = \{3.0\}" +.*Command \d+: "af4\[\]" +.*Command \d+: "af5\[5\]" +.*Command \d+: "af6\[\]" +.*Command \d+: "af7\[\] = \{7.0\}" +.*Command \d+: "af8\[\]" +.*Command \d+: "ah1\[\]" +.*Command \d+: "ah2\[2\]" +.*Command \d+: "ah3\[\]" +.*Command \d+: "ah4\[4\]" +.*Command \d+: "ah5\[\]" +.*Command \d+: "ast1\[\]" +.*Command \d+: "ast2\[2\]" +.*Command \d+: "ast3\[\]" +.*Command \d+: "ast4\[4\]" +.*Command \d+: "ast5\[\]" +} + +test src-mappings-2 {test bytecode <-> source-file-offset mappings 2} -body { +#lang L --line=1 -nowarn +int f0() { return (0); } +int f1(int i) { return (1); } +int f2(int i, int j) { return (2); } +int f3(string opt, int i) {} +void +src_mappings_2() +{ + /* + * This test checks the mappings for expressions. + * Note: avoid tabs in the source to make the test regexp clearer. + */ + + int i, j; + int i1 = 1+2; + int i2 = i1+2*3; + int i3, i4, i5; + string s, t; + float f; + int ai[]; + int aii[][]; + int ah{int}; + int ahh{int}{int}; + + puts(::tcl::unsupported::disassemble("proc", "src_mappings_2")); + return; + + /* Check assignments. */ + i1 = 1; + f = 3.14; + s = "str"; + + /* Check array and hash subscripts. */ + i = ai[i1 - i2 - i3]; + i = aii[i1][i2]; + i = ah{i3 - i4}; + i = ahh{i3}{i4 - i5}; + + /* Check that each sub-expression has a mapping. */ + i3 = 3; + i4 = 4 + 3; + i5 = i3 + i4 * i5 - 5; + + /* Check parameters. */ + f0(); + f1(i1); + f2(i1, i2); + f2(i1, i2 + f1(2)); + f3(opt: i3); // try this b/c at one point we were injecting an extra : + + /* Check that each binary and unary operator gets a mapping. */ + (tcl)i; + (string)i; + (widget)i; + (float)i; + !i; + ~i; + +i; + -i; + &i; + defined(i); + i = j; + i += j; + i -= j; + i *= j; + i /= j; + i %= j; + i &= j; + i |= j; + i <<= j; + i >>= j; + i && j; + i || j; + s eq t; + s ne t; + s gt t; + s ge t; + s lt t; + s le t; + i == j; + i != j; + i > j; + i >= j; + i < j; + i <= j; + i + j; + i - j; + i * j; + i / j; + i % j; + i & j; + i | j; + i ^ j; + i << j; + i >> j; + s =~ /x/; + s =~ /x/i; + s =~ /x/g; + s =~ /x/ig; + s =~ m|x|; + s =~ m|x|i; + s =~ m|x|g; + s =~ m|x|ig; + s =~ s/x/y/; + s =~ s/x/y/i; + s =~ s/x/y/g; + s =~ s/x/y/ig; + + /* Check ?: operator. */ + i = (i>j)?(i-1):(j-1); + + /* Check interpolated strings. */ + s = "abc${t}"; + s = "${t}xyz"; + s = "abc${t}xyz"; + s = "abc${"${t}"}xyz"; +} +#lang tcl +src_mappings_2 +} -match regexp -output {.*Command \d+: "1\+2" +.*Command \d+: "i1 = 1\+2" +.*Command \d+: "i1\+2\*3" +.*Command \d+: "i2 = i1\+2\*3" +.*Command \d+: "2\*3" +.*Command \d+: "i1 = 1" +.*Command \d+: "f = 3.14" +.*Command \d+: "s = \\"str\\"" +.*Command \d+: "ai\[i1 - i2 - i3\]" +.*Command \d+: "i = ai\[i1 - i2 - i3\]" +.*Command \d+: "i1 - i2" +.*Command \d+: "i1 - i2 - i3" +.*Command \d+: "aii\[i1\]\[i2\]" +.*Command \d+: "i = aii\[i1\]\[i2\]" +.*Command \d+: "ah\{i3 - i4\}" +.*Command \d+: "i = ah\{i3 - i4\}" +.*Command \d+: "i3 - i4" +.*Command \d+: "ahh\{i3\}\{i4 - i5\}" +.*Command \d+: "i = ahh\{i3\}\{i4 - i5\}" +.*Command \d+: "i4 - i5" +.*Command \d+: "i3 = 3" +.*Command \d+: "4 \+ 3" +.*Command \d+: "i4 = 4 \+ 3" +.*Command \d+: "i3 \+ i4 \* i5" +.*Command \d+: "i3 \+ i4 \* i5 - 5" +.*Command \d+: "i5 = i3 \+ i4 \* i5 - 5" +.*Command \d+: "i4 \* i5" +.*Command \d+: "f0\(\)" +.*Command \d+: "f1\(i1\)" +.*Command \d+: "f2\(i1, i2\)" +.*Command \d+: "f2\(i1, i2 \+ f1\(2\)\)" +.*Command \d+: "i2 \+ f1\(2\)" +.*Command \d+: "f1\(2\)" +.*Command \d+: "f3\(opt: i3\)" +.*Command \d+: "\(tcl\)i" +.*Command \d+: "\(string\)i" +.*Command \d+: "\(widget\)i" +.*Command \d+: "\(float\)i" +.*Command \d+: "!i" +.*Command \d+: "~i" +.*Command \d+: "\+i" +.*Command \d+: "-i" +.*Command \d+: "&i" +.*Command \d+: "defined\(i\)" +.*Command \d+: "i = j" +.*Command \d+: "i \+= j" +.*Command \d+: "i -= j" +.*Command \d+: "i \*= j" +.*Command \d+: "i /= j" +.*Command \d+: "i %= j" +.*Command \d+: "i <<= j" +.*Command \d+: "i >>= j" +.*Command \d+: "i && j" +.*Command \d+: "i \|\| j" +.*Command \d+: "s eq t" +.*Command \d+: "s ne t" +.*Command \d+: "s gt t" +.*Command \d+: "s ge t" +.*Command \d+: "s lt t" +.*Command \d+: "s le t" +.*Command \d+: "i == j" +.*Command \d+: "i != j" +.*Command \d+: "i > j" +.*Command \d+: "i >= j" +.*Command \d+: "i < j" +.*Command \d+: "i <= j" +.*Command \d+: "i \+ j" +.*Command \d+: "i - j" +.*Command \d+: "i \* j" +.*Command \d+: "i / j" +.*Command \d+: "i % j" +.*Command \d+: "i & j" +.*Command \d+: "i \| j" +.*Command \d+: "i \^ j" +.*Command \d+: "i << j" +.*Command \d+: "i >> j" +.*Command \d+: "s =~ /x/" +.*Command \d+: "s =~ /x/i" +.*Command \d+: "s =~ /x/g" +.*Command \d+: "s =~ /x/ig" +.*Command \d+: "s =~ m\|x\|" +.*Command \d+: "s =~ m\|x\|i" +.*Command \d+: "s =~ m\|x\|g" +.*Command \d+: "s =~ m\|x\|ig" +.*Command \d+: "s =~ s/x/y/" +.*Command \d+: "s =~ s/x/y/i" +.*Command \d+: "s =~ s/x/y/g" +.*Command \d+: "s =~ s/x/y/ig" +.*Command \d+: "\(i>j\)\?\(i-1\):\(j-1\)" +.*Command \d+: "\(i-1\)" +.*Command \d+: "\(j-1\)" +.*Command \d+: "\\"abc\$\{t\}\\"" +.*Command \d+: "s = \\"abc\$\{t\}\\"" +.*Command \d+: "\\"\$\{t\}xyz\\"" +.*Command \d+: "s = \\"\$\{t\}xyz\\"" +.*Command \d+: "\\"abc\$\{t\}xyz\\"" +.*Command \d+: "s = \\"abc\$\{t\}xyz\\"" +.*Command \d+: "\\"abc\$\{\\"\$\{t\}\\"\}xyz\\"" +.*Command \d+: "s = \\"abc\$\{\\"\$\{t\}\\"\}xyz\\"" +.*Command \d+: "\\"\$\{t\}\\"" +} + +test src-mappings-3 {test bytecode <-> source-file-offset mappings 3} -body { +#lang L --line=1 -nowarn +int +f() +{ + return (0); +} +void +fv() +{ + return; +} +int{int} +fh() +{ + int h{int}; + return (h); +} +int[] +fa() +{ + int a[5]; + return (a); +} +int +src_mappings_3() +{ + /* + * This test checks the mappings for statements. + */ + + int i, j, k, v; + int a[5]; + int h{int}; + + /* Disassemble fv() to get its "return" stmt w/no arg. */ + puts(::tcl::unsupported::disassemble("proc", "fv")); + puts(::tcl::unsupported::disassemble("proc", "src_mappings_3")); + return(0); + + while (0) f(); + do f(); while (0); + for (i = 0; i < 10;) f(); + for (i = 0; i < 10; ++i) f(); + foreach (k => v in fh()) f(); + foreach (i,j in fa()) f(); + switch (0) { + case i: ++i; break; + default: break; + } + push (&a, f()); + /* Check break and continue. */ + do { + break; + continue; + } while (0); + goto L1; + L1: +} +#lang tcl +src_mappings_3 +} -match regexp -output {.*Command \d+: "return" +.*Command \d+: "return\(0\)" +.*Command \d+: "while \(0\) f\(\);" +.*Command \d+: "f\(\)" +.*Command \d+: "do f\(\); while \(0\);" +.*Command \d+: "i = 0" +.*Command \d+: "for \(i = 0; i < 10;\) f\(\);" +.*Command \d+: "i < 10" +.*Command \d+: "f\(\)" +.*Command \d+: "i = 0" +.*Command \d+: "for \(i = 0; i < 10; \+\+i\) f\(\);" +.*Command \d+: "i < 10" +.*Command \d+: "f\(\)" +.*Command \d+: "\+\+i" +.*Command \d+: "fh\(\)" +.*Command \d+: "foreach \(k => v in fh\(\)\) f\(\);" +.*Command \d+: "f\(\)" +.*Command \d+: "fa\(\)" +.*Command \d+: "foreach \(i,j in fa\(\)\) f\(\);" +.*Command \d+: "f\(\)" +.*Command \d+: "switch \(0\) \{\\n\\t\\tcase i: \+\+i; break;\\n\\t\\tdefault: break;\\n\\t\}" +.*Command \d+: "i" +.*Command \d+: "default:" +.*Command \d+: "push \(&a, f\(\)\)" +.*Command \d+: "break" +.*Command \d+: "continue" +.*Command \d+: "goto L1;" +} + +test src-mappings-4 {test bytecode <-> source-file-offset mappings with includes} -setup { + set fname1 [makeFile { +void src_mappings_4_foo1() +{ + int v1 = 123; + while (0) { + puts(v1); + } +} +#include "foo-sm4-2.l" +} foo-sm4-1.l [file dirname [info script]]] + set fname2 [makeFile { +void src_mappings_4_foo2() +{ + int i, j; + i = j+1; +} +} foo-sm4-2.l .] +} -body { +#lang L --line=1 +#include "foo-sm4-1.l" +void src_mappings_4() +{ + /* + * We don't need much for this test. If the source offsets are + * mis-aligned, it can be seen with even just one command. + */ + + int k, l; + + puts("--foo1--"); + puts(::tcl::unsupported::disassemble("proc", "src_mappings_4_foo1")); + puts("--foo2--"); + puts(::tcl::unsupported::disassemble("proc", "src_mappings_4_foo2")); + puts("--main--"); + puts(::tcl::unsupported::disassemble("proc", "src_mappings_4")); + return; + + k = l+2; +} +src_mappings_4(); +} -match regexp -output {--foo1-- +.*Command \d+: "v1 = 123" +.*Command \d+: "puts\(v1\)" +.*--foo2-- +.*Command \d+: "i = j\+1" +.*--main-- +.*Command \d+: "return" +.*Command \d+: "k = l\+2" +} + +test src-mappings-5 {test bytecode <-> source-file-offset mappings w/here docs} -body { +#lang L --line=1 -nowarn +void src_mappings_5() +{ + string s1 = <<END +str1 +END + string s2 = <<'END' +str2 +END + + puts(::tcl::unsupported::disassemble("proc", "src_mappings_5")); +} +src_mappings_5(); +} -match regexp -output {.*Command \d+: "s1 = <<END\\nstr1\\nEND" +.*Command \d+: "s2 = <<'END'\\nstr2\\nEND" +} + +test src-mappings-6 {test bytecode <-> source-file-offset mapping for variable} -body { +#lang L --line=1 +void src_mappings_6() +{ + string s = ""; + + if (s) s = "1"; + + puts(::tcl::unsupported::disassemble("proc", "src_mappings_6")); +} +src_mappings_6(); +} -match regexp -output {.*Command \d+: "s" +} + +test function-1.0 {check function call rules} -body { +#lang L --line=1 +void function_1_0_foo() { puts("foo"); } +void function_1_0_f() { puts("f"); } +void +function_1_0() +{ + function_1_0_foo(); + function_1_0_f(); + + /* + * Calling an undeclared function is not an error, we just get + * no arg type checking, so passing anything should be allowed. + */ + if (0) { + string s, p; + + not_defined1(); + not_defined1(s); + not_defined1(s, p); + not_defined2(1, 2, 3, 4); + } +} +#lang tcl +function_1_0 +} -output {foo +f +} + +test function-1.1 {check function call rules error cases} -body { +#lang L --line=1 +int function_1_1_f1; +int function_1_1_f1() { return (0); } // err -- already declared as variable +int function_1_1_f2() { return (0); } +int function_1_1_f2; // err -- already declared as function +int function_1_1_f3() { return (0); } +int function_1_1_f3() { return (0); } // err -- multiply declared function +void +function_1_1() +{ + int i; + float f; + int a[]; + int h{int}; + struct { int i,j; } st; + + /* All illegal because the var isn't a string or poly. */ + i(); + f(); + a(); + h(); + st(); +} +#lang tcl +function_1_1 +} -returnCodes {error} -match regexp -result {.*1: L Error: multiple declaration of global function_1_1_f1 +.*4: L Error: multiple declaration of global function_1_1_f2 +.*6: L Error: function function_1_1_f3 already declared +.*:17: L Error: 'i' is declared but not as a function +.*:18: L Error: 'f' is declared but not as a function +.*:19: L Error: 'a' is declared but not as a function +.*:20: L Error: 'h' is declared but not as a function +.*:21: L Error: 'st' is declared but not as a function +} + +test function-1.2 {check function prototypes} -body { +#lang L --line=1 -nowarn +int function_1_2_f1(); +int function_1_2_f1() { return (1); } + +int function_1_2_f2(); +int function_1_2_f2(); +int function_1_2_f2(); +int function_1_2_f2(); +int function_1_2_f2() { return (1); } + +int function_1_2_f3() { return (1); } +int function_1_2_f3(); + +string function_1_2_f4(int a, string b, float c, int d[], hash e); +string function_1_2_f4(int a, string b, float c, int d[], hash e){ return (b); } + +string function_1_2_f5(int a, string b, float c, int d[], hash e){ return (b); } +string function_1_2_f5(int a, string b, float c, int d[], hash e); + +void +function_1_2() +{ + int a; + string s; + float c; + int d[]; + hash e; + + s = function_1_2_f4(a, "f4", c, d, e); + unless (s eq "f4") puts("bad 1"); + + s = function_1_2_f5(a, "f5", c, d, e); + unless (s eq "f5") puts("bad 2"); + + unless (function_1_2_f10(12) == 12) puts("bad 3"); + unless (function_1_2_f11(13) == 13) puts("bad 4"); + unless (function_1_2_f12(14) == 14) puts("bad 5"); + + /* + * These check that the right parameter-passing mode is + * in the calls to the functions declared later. + */ + + d = {1,2,3,4}; + unless (function_1_2_sum_ref(&d) == 10) puts("bad 6.1"); + unless (length(d) == 3) puts("bad 6.2"); + unless ((d[0] == 9) && (d[1] == 10) && (d[2] == 11)) puts("bad 6.3"); + + d = {1,2,3,4}; + unless (function_1_2_sum_cow(d) == 10) puts("bad 7.1"); + unless (length(d) == 4) puts("bad 7.2"); + unless ((d[0] == 1) && (d[1] == 2)) puts("bad 7.3"); + unless ((d[2] == 3) && (d[3] == 4)) puts("bad 7.4"); +} +function_1_2(); +int function_1_2_f10(int a) { return (a); } +int function_1_2_f11(int a) { return (a); } +int function_1_2_f11(int a); +int function_1_2_f12(int a); +int function_1_2_f12(int a) { return (a); } +int function_1_2_sum_ref(int &a[]) +{ + int i, sum = 0; + + foreach (i in a) sum += i; + a = {9,10,11}; + return (sum); +} +int function_1_2_sum_cow(int a[]) +{ + int i, sum = 0; + + foreach (i in a) sum += i; + a = {9,10,11}; + return (sum); +} +} -output {} + +test function-1.3 {check function prototypes 2} -body { +#lang L --line=1 +void +function_1_3() +{ + /* Call some libl functions correctly. There should be no type errs. */ + + unless (streq("testing", "testing")) puts("bad 1"); + unless (strlen("three") == 5) puts("bad 2"); + unless (strneq("test", "testing", 4)) puts("bad 3"); +} +#lang tcl +function_1_3 +} -output {} + +test function-1.3.2 {check function prototypes 3} -body { +#lang L --line=1 +/* + * Check that a void formal-parameter list is treated exactly like no + * parameters. + */ +void function_1_3_2_f1(); +void function_1_3_2_f2(); +void function_1_3_2_f3(void); +void function_1_3_2_f4(void); +void +function_1_3_2() +{ + function_1_3_2_f1(); + function_1_3_2_f2(); + function_1_3_2_f3(); + function_1_3_2_f4(); +} +function_1_3_2(); +void function_1_3_2_f1() { puts("f1"); } +void function_1_3_2_f2(void) { puts("f2"); } +void function_1_3_2_f3() { puts("f3"); } +void function_1_3_2_f4(void) { puts("f4"); } +} -output {f1 +f2 +f3 +f4 +} + +test function-1.4 {check function prototype errors} -body { +#lang L --line=1 +void +function_1_4() +{ + /* Call a libl function with incorrect args. */ + + streq(); + streq("a"); + streq("a", 2); + streq("a", "b", 2); +} +} -returnCodes {error} -match regexp -result {.*6: L Error: not enough arguments for function streq +.*7: L Error: not enough arguments for function streq +.*8: L Error: parameter 2 has incompatible type +.*9: L Error: too many arguments for function streq +} + +test function-1.5 {check function prototype errors 2} -body { +#lang L --line=1 +void function_1_5_f1(); +int function_1_5_f1() { return (0); } + +int function_1_5_f2() { return (0); } +void function_1_5_f2(); + +void function_1_5_f3(int a); +void function_1_5_f3() { } + +void function_1_5_f4() { } +void function_1_5_f4(int a); + +int function_1_5_f5(int a); +void function_1_5_f5() { } + +void function_1_5_f6() { } +int function_1_5_f6(int a); + +string function_1_5_f7(int a, string b, float c, int d[]); +string function_1_5_f7(int a, string b, float c, int d[], hash e){ return (b); } + +string function_1_5_f8(string b, float c, int d[], hash e); +string function_1_5_f8(int a, string b, float c, int d[], hash e){ return (b); } + +string function_1_5_f9(string b, float c, int d[], hash e); +string function_1_5_f9(string b, ...rest){ return (b); } +} -returnCodes {error} -match regexp -result {.*2: L Error: does not match other declaration of function_1_5_f1 +.*5: L Error: does not match other declaration of function_1_5_f2 +.*8: L Error: does not match other declaration of function_1_5_f3 +.*11: L Error: does not match other declaration of function_1_5_f4 +.*14: L Error: does not match other declaration of function_1_5_f5 +.*17: L Error: does not match other declaration of function_1_5_f6 +.*20: L Error: does not match other declaration of function_1_5_f7 +.*23: L Error: does not match other declaration of function_1_5_f8 +.*26: L Error: does not match other declaration of function_1_5_f9 +} + +test function-1.6 {check function prototype errors 3} -body { +#lang L --line=1 +void function_1_6() +{ + /* + * Check that type checking is done to calls of functions + * declared later. + */ + + function_1_6_v(1); + function_1_6_i(); + function_1_6_i("bad"); +} +void function_1_6_v() {} +void function_1_6_i(int i) { i = 0; } +} -returnCodes {error} -match regexp -result {.*8: L Error: too many arguments for function function_1_6_v +.*9: L Error: not enough arguments for function function_1_6_i +.*10: L Error: parameter 1 has incompatible type +} + +test function-2 {check call to undefined function warnings} -setup { + set file [makeFile { + void fn2_nobody(); + void Fn2_*(); + void main() + { + undeclared_call1(); + undeclared_call2(); + undeclared_call3(); + fn2_nobody(); + Undeclared1_too(); + Undeclared2_hasargs(1,2,3); + Fn2_star(); + } + } function2.l .] +} -constraints { + exec +} -body { + exec [interpreter] --warn-undefined-fns $file +} -returnCodes {error} -match regexp -result {L Warning: function undeclared_call1 not defined +L Warning: function undeclared_call2 not defined +L Warning: function undeclared_call3 not defined +L Warning: function fn2_nobody not defined +L Warning: function undeclared1 not defined +L Warning: function undeclared2 not defined +L Warning: function Fn2_\* not defined +} + +test function-2.1 {check _optional formal-parameter attribute} -body { +#lang L --line=1 +string fn21_foo1(_optional string arg1) +{ + if (arg1) { + return (arg1); + } else { + return ("<undef>"); + } +} +string fn21_foo2(string arg1, _optional string arg2) +{ + if (arg2) { + return (arg1 . arg2); + } else { + return (arg1 . "<undef>"); + } +} +string fn21_foo3(string arg1, string arg2, _optional string arg3) +{ + if (arg3) { + return (arg1 . arg2 . arg3); + } else { + return (arg1 . arg2 . "<undef>"); + } +} +void function_2_1() +{ + unless (fn21_foo1() eq "<undef>") puts("bad 1.1"); + unless (fn21_foo1("one") eq "one") puts("bad 1.2"); + + unless (fn21_foo2("one") eq "one<undef>") puts("bad 2.1"); + unless (fn21_foo2("one", "two") eq "onetwo") puts("bad 2.2"); + + unless (fn21_foo3("1","2") eq "12<undef>") puts("bad 3.1"); + unless (fn21_foo3("1","2","3") eq "123") puts("bad 3.2"); +} +function_2_1(); +} -output {} + +test function-2.2 {check _optional formal-parameter attribute errors} -body { +#lang L --line=1 -nowarn +void fn22_err1(_optional string arg1, _optional string arg2) {} +void fn22_err2(_optional string arg1, string arg2) {} +void fn22_err3(string arg0, _optional string arg1, string arg2) {} +void fn22_err4(...args, _optional string arg1) {} +void fn22_err5(_optional string arg1, ...args) {} +} -returnCodes {error} -match regexp -result {.*1: L Error: _optional parameter must be last +.*2: L Error: _optional parameter must be last +.*3: L Error: _optional parameter must be last +.*4: L Error: Rest parameter must be last +.*5: L Error: _optional parameter must be last +} + +test function-3 {check _attribute error} -body { +#lang L --line=1 +void function3() _attribute (bad) {} +} -returnCodes {error} -match regexp -result {.*1: L Error: illegal attribute 'bad' +} + +test function-4 {check formal-parameter attribute inconsistency checking} -body { +#lang L --line=1 +// Check with and without names for the formals in the proto. +string function4a(string s); +string function4a(_optional string s) +{ + return (s); +} +string function4b(_optional string s); +string function4b(string s) +{ + return (s); +} +string function4c(string); +string function4c(_optional string s) +{ + return (s); +} +string function4d(_optional string); +string function4d(string s) +{ + return (s); +} +string function4e(string); +string function4e(_mustbetype string s) +{ + return (s); +} +string function4f(_mustbetype string); +string function4f(string s) +{ + return (s); +} +string function4g(_mustbetype string); +string function4g(_optional string s) +{ + return (s); +} +} -returnCodes {error} -match regexp -result {.*3: L Error: does not match other declaration of function4a +.*8: L Error: does not match other declaration of function4b +.*13: L Error: does not match other declaration of function4c +.*18: L Error: does not match other declaration of function4d +.*23: L Error: does not match other declaration of function4e +.*28: L Error: does not match other declaration of function4f +.*33: L Error: does not match other declaration of function4g +} + +test initializers-1 {check variable initializer error cases} -body { +#lang L --line=1 +extern int g = 0; +void initializers_1() { + /* + * Externs in local scopes are illegal as well as extern + * initializers, so this is error on two counts. + */ + extern int l = 0; +} +} -returnCodes {error} -match regexp -result {.*1: L Error: extern initializers illegal +.*7: L Error: extern.* +} + +test initializers-2 {check variable initializers} -body { +#lang L --line=1 +struct initializers_2_s1 { + int i; + int j, k; + string s; + string as[]; + string hs{int}; +}; +struct initializers_2_s2 { + int i, j; +}; +typedef struct initializers_2_s2 h_of_s2{int}; + +void initializers_2() +{ + /* + * In addition to the initializers themselves, check various + * number of initializers per declaration. + */ + int i; + int i1 = 11; + int i2 = 0, i3 = 33; + int i4 = 0, i5 = 55, i6 = 0; + int i7 = 0, i8 = 88, i9 = 99, i10 = 111; + string s = "s"; + float f = 3.1, f2 = 3; + string ai[] = { "a", "b", "c" }; + string hs{int} = { 1=>"one", 2=>"two", 3=>"three" }; + struct initializers_2_s1 st = { + 1, + 2, 3, + "s", + { "x", "y", "z" }, + { 3=>"t", 6=>"s" }, // note the trailing comma (legal) + }; + string aempty[] = {}; + h_of_s2 h2 = { 1 => {2,3}, 2 => {4,5} }; + + unless (i1 == 11) puts("bad 1"); + unless (!i2 && !i4 && !i6 && !i7) puts("bad 2"); + unless (i3 == 33) puts("bad 3"); + unless (i5 == 55) puts("bad 4"); + unless (i8 == 88) puts("bad 5"); + unless (i9 == 99) puts("bad 6"); + unless (i10 == 111) puts("bad 7"); + unless (s eq "s") puts("bad 8"); + unless (f == 3.1) puts("bad 9"); + unless (f2 == 3) puts("bad 9.1"); + unless ((ai[0] eq "a") && (ai[1] eq "b")) puts("bad 10"); + unless ((ai[2] eq "c") && !defined(ai[3])) puts("bad 11"); + i = 0; + foreach (s in ai) ++i; + unless (i == 3) puts("bad 12"); + unless ((hs{1} eq "one") && (hs{2} eq "two")) puts("bad 13"); + unless ((hs{3} eq "three")) puts("bad 14"); + i = 0; + foreach (i1 in hs) ++i; + unless (i == 3) puts("bad 15"); + + unless ((st.i == 1) && (st.j == 2) && (st.k == 3)) puts("bad 16"); + unless ((st.s eq "s") && (st.as[0] eq "x")) puts("bad 17"); + unless ((st.as[1] eq "y") && (st.as[2] eq "z")) puts("bad 18"); + i = 0; + foreach (s in st.as) ++i; + unless (i == 3) puts("bad 19"); + unless ((st.hs{3} eq "t") && (st.hs{6} eq "s")) puts("bad 20"); + i = 0; + foreach (i1 in st.hs) ++i; + unless (i == 2) puts("bad 21"); + + if (defined(aempty[0])) puts("bad 30"); + unless ((h2{1}.i == 2) && (h2{1}.j == 3)) puts("bad 31"); + unless ((h2{2}.i == 4) && (h2{2}.j == 5)) puts("bad 32"); +} +#lang tcl +initializers_2 +} -output {} + +test initializers-3 {check variable initializer type errors} -body { +#lang L --line=1 -nowarn +struct initializers_3_s1 { + int i; + int j, k; + string s; + string as[]; + string hs{int}; +}; + +void initializers_3() +{ + int i1 = 1.0; + int i2, i3 = "s"; + int i4, i5 = {3}, i6; + string s = 3.1; + float f = "3.1"; + string ai[] = {"a", 2, "c"}; + + struct initializers_2_s1 st = { + 1, + 2, // err -- omitted initializer for "k" + "s", + { "x", "y", "z" }, + { 3=>"t", 6=>"s" } + }; + string hs2{int} = { 1=>"one", 3 }; +} +} -returnCodes {error} -match regexp -result {.*11: L Error: assignment of incompatible types +.*12: L Error: assignment of incompatible types +.*13: L Error: assignment of incompatible types +.*14: L Error: assignment of incompatible types +.*15: L Error: assignment of incompatible types +.*16: L Error: assignment of incompatible types +.*18: L Error: assignment of incompatible types +.*25: L Error: cannot mix hash and non-hash elements +} + +test initializers-4 {check expressions in variable initializers} -body { +#lang L --line=1 +int init_4_g = 33; +void initializers_4() +{ + /* + * Initializers are full-blown expressions, so they can contain + * variables etc. + */ + int e1 = 11; + int e2 = e1*2; + int a[] = { init_4_g, init_4_g*2, e1, e2, 3 }; + + unless ((e1 == 11) && (e2 == 22)) puts("bad 1"); + unless ((a[0] == 33) && (a[1] == 66) && (a[2] == 11) && + (a[3] == 22) && (a[4] == 3)) puts("bad 2"); + if (defined(a[5])) puts("bad 3"); +} +#lang tcl +initializers_4 +} -output {} + +test initializers-5 {check order of variable initializers} -body { +#lang L --line=1 +void initializers_5() +{ + /* + * This checks the variable initializers are compiled + * top-to-bottom and left-to-right. + */ + int i1 = 2, i2 = i1 * 7, i3 = i1 + i2; + int i4 = i3 * 10; + + unless (i1 == 2) puts("bad 1"); + unless (i2 == 14) puts("bad 2"); + unless (i3 == 16) puts("bad 3"); + unless (i4 == 160) puts("bad 4"); +} +initializers_5(); +} -output {} + +test initializers-6 {check blank initial values} -body { +#lang L --line=1 +void initializers_6() +{ + int i; + float f; + string s; + poly p; + string as[]; + string hs{string}; + struct s1 { + int i; + float f; + string s; + string sa[]; + string hs{string}; + } st; + + if (defined(i)) puts("bad 1"); + if (defined(f)) puts("bad 2"); + if (defined(s)) puts("bad 3"); + if (defined(p)) puts("bad 4"); + if (defined(as)) puts("bad 5"); + if (defined(hs)) puts("bad 6"); + if (defined(st)) puts("bad 7"); +} +initializers_6(); +} -output {} + +test composite-1 {check composite values in expressions 1} -body { +#lang L --line=1 +struct composite_1_s1 { + int i; + int j, k; + string s; + string as[]; + string hs{int}; +}; +int composite_1_g = 33; +void composite_1() +{ + /* + * These are taken from the initializer-* tests above but + * are used in the rhs of expressions instead of in initializers. + */ + + int i, i1; + int e1 = 11; + int e2 = e1*2; + string s; + int a[]; + string ai[]; + string hs{int}; + struct composite_1_s1 st; + string aempty[]; + h_of_s2 h2; + + a = { composite_1_g, composite_1_g*2, e1, e2, 3 }; + + unless ((e1 == 11) && (e2 == 22)) puts("bad 1"); + unless ((a[0] == 33) && (a[1] == 66) && (a[2] == 11) && + (a[3] == 22) && (a[4] == 3)) puts("bad 2"); + if (defined(a[5])) puts("bad 3"); + + ai = { "a", "b", "c" }; + hs = { 1=>"one", 2=>"two", 3=>"three" }; + st = { + 1, + 2, 3, + "s", + { "x", "y", "z" }, + { 3=>"t", 6=>"s" }, // note the trailing comma (legal) + }; + aempty = {}; + h2 = { 1 => {2,3}, 2 => {4,5} }; + + unless ((ai[0] eq "a") && (ai[1] eq "b")) puts("bad 10"); + unless ((ai[2] eq "c") && !defined(ai[3])) puts("bad 11"); + i = 0; + foreach (s in ai) ++i; + unless (i == 3) puts("bad 12"); + unless ((hs{1} eq "one") && (hs{2} eq "two")) puts("bad 13"); + unless ((hs{3} eq "three")) puts("bad 14"); + i = 0; + foreach (i1 in hs) ++i; + unless (i == 3) puts("bad 15"); + + unless ((st.i == 1) && (st.j == 2) && (st.k == 3)) puts("bad 16"); + unless ((st.s eq "s") && (st.as[0] eq "x")) puts("bad 17"); + unless ((st.as[1] eq "y") && (st.as[2] eq "z")) puts("bad 18"); + i = 0; + foreach (s in st.as) ++i; + unless (i == 3) puts("bad 19"); + unless ((st.hs{3} eq "t") && (st.hs{6} eq "s")) puts("bad 20"); + i = 0; + foreach (i1 in st.hs) ++i; + unless (i == 2) puts("bad 21"); + + if (defined(aempty[0])) puts("bad 30"); + unless ((h2{1}.i == 2) && (h2{1}.j == 3)) puts("bad 31"); + unless ((h2{2}.i == 4) && (h2{2}.j == 5)) puts("bad 32"); +} +#lang tcl +composite_1 +} -output {} + +test composite-2 {check composite values in expressions 2} -body { +#lang L --line=1 +string composite_2_join(string[] a) +{ + string s; + string ret = ""; + + foreach (s in a) ret = sprintf("%s%s", ret, s); + return (ret); +} +void composite_2() +{ + /* + * Try more operations with composite values. + */ + + int i; + + unless (composite_2_join({"a","b","c"}) eq "abc") puts("bad 1"); + + for (i = 0; i < 5; ++i) { + unless ({0,1,2,3,4}[i] == i) printf("bad 2 %d\n", i); + } + if (defined({0,1,2,3,4}[5])) puts("bad 3"); + + unless ({1=>"one", 2=>"two", 3=>"three"}{1} eq "one") puts("bad 4"); + unless ({1=>"one", 2=>"two", 3=>"three"}{2} eq "two") puts("bad 5"); + unless ({1=>"one", 2=>"two", 3=>"three"}{3} eq "three") puts("bad 6"); + + unless (((struct { int i,j,k; }){1,2,3}).i == 1) puts("bad 10"); + unless (((struct { int i,j,k; }){1,2,3}).j == 2) puts("bad 11"); + unless (((struct { int i,j,k; }){1,2,3}).k == 3) puts("bad 12"); + + unless ({{1,2},{3,4},{4,5}}[1][0] == 3) puts("bad 20"); +} +#lang tcl +composite_2 +} -output {} + +test composite-2.2 {check hash of array of composite constants} -body { +#lang L --line=1 +void composite_2_2() +{ + /* + * This checks that lists used as array constants need not all + * have the same number of elements to satisfy the type + * checker. + */ + + string h{string}[] = { + "k1" => { "1" }, + "k2" => { "1", "2", "3" }, + "k3" => { "1", "2" } + }; + + unless (length(h) == 3) puts("bad 1.1"); + unless (length(h{"k1"}) == 1) puts("bad 1.2"); + unless (length(h{"k2"}) == 3) puts("bad 1.3"); + unless (length(h{"k3"}) == 2) puts("bad 1.4"); + unless (join(" ", h{"k1"}) eq "1") puts("bad 1.5"); + unless (join(" ", h{"k2"}) eq "1 2 3") puts("bad 1.6"); + unless (join(" ", h{"k3"}) eq "1 2") puts("bad 1.7"); +} +composite_2_2(); +} -output {} + +test composite-2.3 {check list type compatibility in assignment} -body { +#lang L --line=1 +void composite_2_3() +{ + float af[]; + + /* + * This verifies that the type checker gets the compatibility + * test right when checking an array against a list type. The + * opposite, when you try to assign a list of ints and floats + * to an int array, is an error and is checked in a test + * below. + */ + af = { 1.1, 2.2 }; + af = { 1, 2.2 }; + af = { 1.1, 2 }; + af = { 1, 2 }; +} +composite_2_3(); +} -output {} + +test composite-3 {check type errors with composite values} -body { +#lang L --line=1 -nowarn +void composite_3_as(string[] a) {} +void composite_3_ai(int[] a) {} +void composite_3_his(int{string} a) {} +void composite_3_hsi(string{int} a) {} +void composite_3_hss(string{string} a) {} +void composite_3_hii(int{int} a) {} + +void composite_3() +{ + int i[]; + + composite_3_as({1,2,3}); + composite_3_ai({"a","b","c"}); + composite_3_his({1,2,3}); + composite_3_his({1=>2,3=>4}); + composite_3_hsi({1=>2,3=>4}); + composite_3_hss({1=>2,3=>4}); + composite_3_hii({"1"=>2,"3"=>4}); + + i = { 1.1 }; + i = { 1, 2.2 }; +} +} -returnCodes {error} -match regexp -result {.*12: L Error:.*incompatible type.* +.*13: L Error:.*incompatible type.* +.*14: L Error:.*incompatible type.* +.*15: L Error:.*incompatible type.* +.*16: L Error:.*incompatible type.* +.*17: L Error:.*incompatible type.* +.*18: L Error:.*incompatible type.* +.*20: L Error:.*incompatible type.* +.*21: L Error:.*incompatible type.* +} + +test composite-4 {check composite l-values} -body { +#lang L --line=1 +class composite_4 +{ + public string c; + instance { + public string i; + } +} +void composite_4_main() +{ + string a, b, c; + string sa[]; + composite_4 o1, o2, o3; + + a = "bad"; + { a } = { "one" }; + unless (a eq "one") puts("bad 1.1"); + + a = b = "bad"; + { a, b } = { "one", "two" }; + unless ((a eq "one") && (b eq "two")) puts("bad 2.1"); + + a = b = c = "bad"; + { a, b, c } = { "one", "two", "three" }; + unless ((a eq "one") && (b eq "two") && (c eq "three")) puts("bad 3.1"); + + a = "bad"; + { a } = {}; + if (defined(a)) puts("bad 4.1"); + + a = b = "bad"; + { a, b } = {}; + if (defined(a) || defined(b)) puts("bad 5.1"); + + a = b = c = "bad"; + { a, b, c } = {}; + if (defined(a) || defined(b) || defined(c)) puts("bad 6.1"); + + a = b = c = "bad"; + { a, b, c } = { "one" }; + unless (a eq "one") puts("bad 7.1"); + if (defined(b) || defined(c)) puts("bad 7.2"); + + a = b = c = "bad"; + { a, b, c } = { "one", "two" }; + unless ((a eq "one") && (b eq "two")) puts("bad 8.1"); + if (defined(c)) puts("bad 8.2"); + + a = "bad"; + { a } = { "one", "two" }; + unless (a eq "one") puts("bad 9.1"); + + a = "bad"; + { a } = { "one", "two", "three" }; + unless (a eq "one") puts("bad 10.1"); + + a = b = "bad"; + { a, b } = { "one", "two", "three" }; + unless ((a eq "one") && (b eq "two")) puts("bad 11.1"); + + a = "bad"; + { a, undef } = { "one", "two" }; + unless (a eq "one") puts("bad 12.1"); + + a = "bad"; + { a, undef } = { "one" }; + unless (a eq "one") puts("bad 13.1"); + + a = "bad"; + { a, undef, undef } = { "one" }; + unless (a eq "one") puts("bad 14.1"); + + a = "bad"; + { undef, a } = { "one", "two" }; + unless (a eq "two") puts("bad 15.1"); + + a = "bad"; + { undef, a } = { "one", "two", "three" }; + unless (a eq "two") puts("bad 16.1"); + + a = "bad"; + { undef, a, undef } = { "one", "two", "three" }; + unless (a eq "two") puts("bad 17.1"); + + { undef } = {}; + { undef, undef } = {}; + { undef, undef, undef } = {}; + { undef } = { undef }; + + { sa[0] } = { "one" }; + unless (sa[0] eq "one") puts("bad 18.1"); + + { sa[0], sa[1] } = { "one", "two" }; + unless ((sa[0] eq "one") && (sa[1] eq "two")) puts("bad 19.1"); + + { sa[0], sa[1], sa[3] } = { "one", "two", "four" }; + unless ((sa[0] eq "one") && (sa[1] eq "two") && (sa[3] eq "four")) { + puts("bad 20.1"); + } + if (defined(sa[2])) puts("bad 20.2"); + + o1 = composite_4_new(); + o2 = composite_4_new(); + o3 = composite_4_new(); + { o1->i, o2->i, o3->i } = { "one", "two", "three" }; + unless (o1->i eq "one") puts("bad 21.1"); + unless (o2->i eq "two") puts("bad 21.2"); + unless (o3->i eq "three") puts("bad 21.3"); + { composite_4->c } = { "cvar" }; + unless (composite_4->c eq "cvar") puts("bad 21.4"); + composite_4_delete(o1); + composite_4_delete(o2); + composite_4_delete(o3); + + a = b = "bad"; + { a, b } = (poly){ "one", "two" }; + unless ((a eq "one") && (b eq "two")) puts("bad 22.1"); + a = b = "bad"; + { a, b } = (poly){ "one", "two", "three" }; + unless ((a eq "one") && (b eq "two")) puts("bad 22.2"); + a = b = "bad"; + { a } = (poly){ "one", "two", "three" }; + unless ((a eq "one") && (b eq "bad")) puts("bad 22.3"); +} +composite_4_main(); +} -output {} + +test composite-4.1 {check composite l-values with non-constant rhs} -body { +#lang L --line=1 +void composite_4_1() +{ + int ai[], i, j, k; + string as[], a, b, c; + poly ap[]; + struct { + int i; + int j; + string s; + string t; + } st; + + as = { "a", "b", "c" }; + { a, b, c } = as; + unless ((a eq "a") && (b eq "b") && (c eq "c")) puts("bad 1.1"); + + ai = { 1, 2, 3 }; + { i, j, k } = ai; + unless ((i == 1) && (j == 2) && (k == 3)) puts("bad 2.1"); + + st = { 5, 6, "x", "y" }; + { i, j, a, b } = st; + unless ((i == 5) && (j == 6) && (a eq "x") && (b eq "y")) { + puts("bad 3.1"); + } + + { a, b } = split("one two three"); + unless ((a eq "one") && (b eq "two")) puts("bad 4.1"); + + as = { "a" }; + { a, b, c } = as; + unless ((a eq "a") && !defined(b) && !defined(c)) puts("bad 5.1"); + + ap = { 5, 6, "x", "y" }; + { i, j, a, b } = ap; + unless ((i == 5) && (j == 6) && (a eq "x") && (b eq "y")) { + puts("bad 6.1"); + } + ap = { "5", "6", 1, 2 }; + { i, j, a, b } = ap; // poly array, so no type checking + unless ((i == 5) && (j == 6) && (a eq "1") && (b eq "2")) { + puts("bad 6.2"); + } + + /* These are not type errors. */ + i = j = 0; + { a, i, j } = { "s" }; + if (defined(i) || defined(j)) puts("bad 10.1"); + c = ""; i = j = 0; + { i, j, a, b, c, i, j } = st; + if (defined(c) || defined(i) || defined(j)) puts("bad 10.2"); +} +composite_4_1(); +} -output {} + +test composite-5 {check composite l-value errors} -body { +#lang L --line=1 -nowarn +int composite_5_f() { return (0); } +void composite_5() +{ + int a, b; + string s; + + { a, b } += 1; + { a, b } -= 1; + { a, b } *= 1; + { a, b } /= 1; + { a, b } %= 1; + { a, b } &= 1; + { a, b } |= 1; + { a, b } ^= 1; + { a, b } >>= 1; + { a, b } <<= 1; + { a, b } =~ /bad/; + { s } =~ s/bad/bad/; + + { a, b } = 0; + + { 1 } = { 1 }; + { composite_5_f() } = { 1 }; +} +} -returnCodes {error} -match regexp -result {.*7: L Error: arithmetic assignment illegal +.*8: L Error: arithmetic assignment illegal +.*9: L Error: arithmetic assignment illegal +.*10: L Error: arithmetic assignment illegal +.*11: L Error: arithmetic assignment illegal +.*12: L Error: arithmetic assignment illegal +.*13: L Error: arithmetic assignment illegal +.*14: L Error: arithmetic assignment illegal +.*15: L Error: arithmetic assignment illegal +.*16: L Error: arithmetic assignment illegal +.*17: L Error: expected type string or widget but got list in =~ +.*18: L Error: invalid l-value in =~ +.*20: L Error: right-hand side incompatible with composite assign +.*22: L Error: invalid l-value in assignment +.*23: L Error: invalid l-value in assignment +} + +test composite-6 {test composite l-value type errors} -body { +#lang L --line=1 +void composite_6() +{ + string as[], a, b; + int ai[], i, j; + struct { + int i; + string s; + } st; + + { a, i } = as; + { i, a } = ai; + { i, i } = as; + + { a, b } = { "a", 1 }; + { a, b } = { 1, "a" }; + + { a, i } = st; + { i, j } = st; + + { a, b } = { "bad" => "bad" }; +} +} -returnCodes {error} -match regexp -result {.*10: L Error: assignment of incompatible types +.*11: L Error: assignment of incompatible types +.*12: L Error: assignment of incompatible types +.*14: L Error: assignment of incompatible types +.*15: L Error: assignment of incompatible types +.*17: L Error: assignment of incompatible types +.*18: L Error: assignment of incompatible types +.*20: L Error: right-hand side incompatible with composite assign +} + +test lvalue-1 {check indexing hash/struct/array expressions} -body { +#lang L --line=1 +void lvalue_1() +{ + /* + * This checks deep-dive of an expression rather than a + * variable. Set up expressions that have array/struct/hash + * values and then index into them. + */ + string a1[] = { "1", "2", "3" }; + string a2[]; + + unless (split("a x c")[0] eq "a") puts("bad 1"); + unless (split("y b c")[1] eq "b") puts("bad 2"); + unless (split("z b c")[2] eq "c") puts("bad 3"); + + if (defined(a2[0])) puts("bad 4"); + unless ((a2 = a1)[0] eq "1") puts("bad 5"); + unless ((a2 = a1)[1] eq "2") puts("bad 6"); + unless ((a2 = a1)[2] eq "3") puts("bad 7"); + unless ((a2[0] eq "1") && (a2[1] eq "2") && (a2[2] eq "3")) { + puts("bad 8"); + } + if (defined(a2[3])) puts("bad 9"); + + unless ((1 ? a1 : a2)[0] eq "1") puts("bad 10"); + unless ((1 ? a1 : a2)[1] eq "2") puts("bad 11"); + unless ((1 ? a1 : a2)[2] eq "3") puts("bad 12"); +} +#lang tcl +lvalue_1 +} -output {} + +test lvalue-2 {illegal l-value in deep-dive assignments} -body { +#lang L --line=1 +int[] lvalue_2_ints() +{ + int a[] = { 1, 2, 3 }; + return (a); +} +void lvalue_2() +{ + int a1[], a2[]; + string s1[], s2[]; + + lvalue_2_ints()[0] = 0; + lvalue_2_ints()[0] += 1; + ++lvalue_2_ints()[0]; + lvalue_2_ints()[0]--; + split("a","b","c")[0] =~ s/a/b/; + + (a2 = a1)[0] = 0; + (a2 = a1)[0] += 1; + ++(a2 = a1)[0]; + (a2 = a1)[0]--; + (s2 = s1)[0] =~ s/bad/yes-its-still-bad/; +} +#lang tcl +lvalue_2 +} -returnCodes {error} -match regexp -result {.*11: L Error: invalid l-value in assignment +.*12: L Error: invalid l-value in assignment +.*13: L Error: invalid l-value in inc/dec +.*14: L Error: invalid l-value in inc/dec +.*15: L Error: invalid l-value in =~ +.*17: L Error: invalid l-value in assignment +.*18: L Error: invalid l-value in assignment +.*19: L Error: invalid l-value in inc/dec +.*20: L Error: invalid l-value in inc/dec +.*21: L Error: invalid l-value in =~ +} + +test lvalue-3 {invalid l-value in inc/dec operators} -body { +#lang L --line=1 +void lvalue_3() +{ + int i = 0; + + i----; + i++++; + (i++)++; + (i++)--; + (i--)++; + (i--)--; + ++++i; + ----i; + ++(++i); + ++(--i); + --(++i); + --(--i); + --(i--); + --(i++); + ++(i--); + ++(i++); + (--i)--; + (--i)++; + (++i)--; + (++i)++; +} +#lang tcl +lvalue_3 +} -returnCodes {error} -match regexp -result {.*5: L Error: invalid l-value in inc/dec +.*6: L Error: invalid l-value in inc/dec +.*7: L Error: invalid l-value in inc/dec +.*8: L Error: invalid l-value in inc/dec +.*9: L Error: invalid l-value in inc/dec +.*10: L Error: invalid l-value in inc/dec +.*11: L Error: invalid l-value in inc/dec +.*12: L Error: invalid l-value in inc/dec +.*13: L Error: invalid l-value in inc/dec +.*14: L Error: invalid l-value in inc/dec +.*15: L Error: invalid l-value in inc/dec +.*16: L Error: invalid l-value in inc/dec +.*17: L Error: invalid l-value in inc/dec +.*18: L Error: invalid l-value in inc/dec +.*19: L Error: invalid l-value in inc/dec +.*20: L Error: invalid l-value in inc/dec +.*21: L Error: invalid l-value in inc/dec +.*22: L Error: invalid l-value in inc/dec +.*23: L Error: invalid l-value in inc/dec +.*24: L Error: invalid l-value in inc/dec +} + +test lvalue-4 {invalid l-value in assignments} -body { +#lang L --line=1 +int lvalue_4_foo() { return (1); } +void lvalue_4() +{ + int i; + + lvalue_4_foo() = i; + lvalue_4_foo() += i; + lvalue_4_foo() -= i; + lvalue_4_foo() *= i; + lvalue_4_foo() /= i; + lvalue_4_foo() %= i; + lvalue_4_foo() &= i; + lvalue_4_foo() |= i; + lvalue_4_foo() ^= i; + lvalue_4_foo() >>= i; + lvalue_4_foo() <<= i; + lvalue_4_foo() =~ s/bad/dab/; +} +#lang tcl +lvalue_4 +} -returnCodes {error} -match regexp -result {.*6: L Error: invalid l-value in assignment +.*7: L Error: invalid l-value in assignment +.*8: L Error: invalid l-value in assignment +.*9: L Error: invalid l-value in assignment +.*10: L Error: invalid l-value in assignment +.*11: L Error: invalid l-value in assignment +.*12: L Error: invalid l-value in assignment +.*13: L Error: invalid l-value in assignment +.*14: L Error: invalid l-value in assignment +.*15: L Error: invalid l-value in assignment +.*16: L Error: invalid l-value in assignment +.*17: L Error: invalid l-value in =~ +} + +test lvalue-5 {invalid l-value in & operator} -body { +#lang L --line=1 -nowarn +int lvalue_5_foo() { return (1); } +void lvalue_5_bar(int &i) {} +void lvalue_5() +{ + int a[], aa[][]; + + lvalue_5_bar(&lvalue_5_foo()); + lvalue_5_bar(&1); + &1; + &1.1; + &"s"; + &{1,2,3}; + &{1=>1}; + &(1+2); +} +#lang tcl +lvalue_5 +} -returnCodes {error} -match regexp -result {.*7: L Error: illegal operand to & +.*8: L Error: illegal operand to & +.*9: L Error: illegal operand to & +.*10: L Error: illegal operand to & +.*11: L Error: illegal operand to & +.*12: L Error: illegal operand to & +.*13: L Error: illegal operand to & +.*14: L Error: illegal operand to & +} + +test builtin-1 {check keys built-in} -body { +#lang L --line=1 +int[] +builtin_1_isort(int a[]) +{ + int sorted[] = sort(a); + return (sorted); +} +string[] +builtin_1_ssort(string a[]) +{ + string sorted[] = sort(a); + return (sorted); +} +void builtin_1() +{ + int hi{int}; + int hs{string}; + int hp{poly}; + int ki[]; + string ks[]; + poly kp[]; + + hi = { 3=>3, 1=>1, 4=>4, 5=>5, 9=>9 }; + ki = keys(hi); + ki = builtin_1_isort(ki); + unless ((ki[0] == 1) && (ki[1] == 3) && (ki[2] == 4)) puts("bad 1.1"); + unless ((ki[3] == 5) && (ki[4] == 9)) puts("bad 1.2"); + if (defined(ki[5])) puts("bad 1.3"); + + hs = { "3"=>3, "1"=>1, "4"=>4, "5"=>5, "9"=>9 }; + ks = keys(hs); + ks = builtin_1_ssort(ks); + unless ((ks[0] eq "1") && (ks[1] eq "3")) puts("bad 2.1"); + unless ((ks[2] eq "4") && (ks[3] eq "5")) puts("bad 2.2"); + unless (ks[4] eq "9") puts("bad 2.3"); + if (defined(ks[5])) puts("bad 2.4"); + + hp{"3"} = 3; + hp{1} = 1; + hp{"4"} = 4; + hp{5} = 5; + hp{"9"} = 9; + kp = keys(hp); + kp = builtin_1_ssort(kp); + unless ((kp[0] eq "1") && (kp[1] eq "3")) puts("bad 3.1"); + unless ((kp[2] eq "4") && (kp[3] eq "5")) puts("bad 3.2"); + unless (kp[4] eq "9") puts("bad 3.3"); + if (defined(kp[5])) puts("bad 3.4"); +} +builtin_1(); +} -output {} + +test builtin-2 {check errors with keys built-in} -body { +#lang L --line=1 +void builtin_2() +{ + int h{int}; + int k[]; + + k = keys(); + k = keys(k); + k = keys(h, h); + /* + * These test that the compiler does not assert due to keys() + * not getting a type even though the call has an error. + */ + keys() + 1; + keys(k) + 1; +} +} -returnCodes {error} -match regexp -result {.*6: L Error: incorrect # args to keys +.*7: L Error: arg to keys is not a hash +.*8: L Error: incorrect # args to keys +} + +test builtin-3 {check length built-in} -body { +#lang L --line=1 +void builtin_3() +{ + int a[] = {1,2,3,4}; + int h{int} = {1=>1,2=>2,3=>3}; + poly p = {1,2,3,4,5,6}; + widget w = "12345"; + + unless (length("abcde") == 5) puts("bad 1"); + unless (length(a) == 4) puts("bad 2"); + unless (length(p) == 6) puts("bad 4"); + unless (length(h) == 3) puts("bad 5"); + unless (length(w) == 5) puts("bad 6"); + + /* + * length() of anything undef should return 0. + */ + unless (length((string)undef) == 0) puts("bad 10.1"); + unless (length((string[])undef) == 0) puts("bad 10.2"); + unless (length((string{string})undef) == 0) puts("bad 10.3"); + unless (length((poly)undef) == 0) puts("bad 10.4"); +} +builtin_3(); +} -output {} + +test builtin-4 {check errors with length built-in} -body { +#lang L --line=1 +void builtin_4_f() {} +void builtin_4() +{ + length(); + length(1,2); + length(3.14159); + length(builtin_4_f()); + /* + * This tests that the compiler does not assert due to length() + * not getting a type even though the call has an error. + */ + length() + 1; +} +} -returnCodes {error} -match regexp -result {.*4: L Error: incorrect # args to length +.*5: L Error: incorrect # args to length +.*6: L Error: arg to length has illegal type +.*7: L Error: arg to length has illegal type +} + +test builtin-5 {check sort built-in} -body { +#lang L --line=1 +int builtin_5_compar(string a, string b) +{ + int la = length(a); + int lb = length(b); + + if (la < lb) { + return (-1); + } else if (la > lb) { + return (1); + } else { + return (0); + } +} +void builtin_5() +{ + int ui[] = {3, 1, 4, 1, 5, 9, 2}; + int si[]; + string us[] = {"u","n","s","o","r","t","e","d"}; + string ss[]; + float uf[] = {3.1, 1.0, 9.2, -1.0, 5.5}; + float sf[]; + string uc[] = {"1", "22222", "333", "44", "5555"}; + string sc[]; + + ss = sort(us); + unless ((ss[0] eq "d") && (ss[1] eq "e")) puts("bad 1.1"); + unless ((ss[2] eq "n") && (ss[3] eq "o")) puts("bad 1.2"); + unless ((ss[4] eq "r") && (ss[5] eq "s")) puts("bad 1.3"); + unless ((ss[6] eq "t") && (ss[7] eq "u")) puts("bad 1.4"); + + si = sort(ui); + unless ((si[0] == 1) && (si[1] == 1) && (si[2] == 2)) puts("bad 2.1"); + unless ((si[3] == 3) && (si[4] == 4) && (si[5] == 5)) puts("bad 2.2"); + unless (si[6] == 9) puts("bad 2.3"); + + /* + * Exact comparisons with floats don't always work, so if this + * test fails, suspect that first. + */ + sf = sort(uf); + unless ((sf[0] == -1.0) && (sf[1] == 1.0)) puts("bad 3.1"); + unless ((sf[2] == 3.1) && (sf[3] == 5.5)) puts("bad 3.2"); + unless (sf[4] == 9.2) puts("bad 3.3"); + + ss = sort(decreasing:, us); + unless ((ss[7] eq "d") && (ss[6] eq "e")) puts("bad 4.1"); + unless ((ss[5] eq "n") && (ss[4] eq "o")) puts("bad 4.2"); + unless ((ss[3] eq "r") && (ss[2] eq "s")) puts("bad 4.3"); + unless ((ss[1] eq "t") && (ss[0] eq "u")) puts("bad 4.4"); + + sc = sort(command: &builtin_5_compar, uc); + unless ((sc[0] eq "1") && (sc[1] eq "44")) puts("bad 5.1"); + unless ((sc[2] eq "333") && (sc[3] eq "5555")) puts("bad 5.2"); + unless (sc[4] eq "22222") puts("bad 5.3"); +} +builtin_5(); +} -output {} + +test builtin-6 {check sort built-in errors} -body { +#lang L --line=1 +int builtin_6_compar(string a, string b) { return (0); } +void builtin_6() +{ + string s; + + sort(); + sort(1); + /* + * These test that the compiler does not assert due to sort() + * not getting a type even though the call has an error. + */ + sort() + 1; + sort(1) + 1; + + sort(command: builtin_6_compar, {}); + sort(command: &s, {}); + sort(command:, {}); + sort(command:); +} +} -returnCodes {error} -match regexp -result {.*6: L Error: incorrect # args to sort +.*7: L Error: last arg to sort not an array or list +.*12: L Error: incorrect # args to sort +.*13: L Error: last arg to sort not an array or list +.*15: L Error: \'command:\' arg to sort must be \&function +.*16: L Error: \'command:\' arg to sort must be \&function +.*17: L Error: \'command:\' arg to sort must be \&function +.*18: L Error: last arg to sort not an array or list +} + +test builtin-7 {check join built-in} -body { +#lang L --line=1 +void builtin_7() +{ + int ai[] = {1,2,3}; + string as[] = {"a","b","c"}; + string s = "x"; + poly p = "p"; + widget w = "w"; + + unless (join(" ", as) eq "a b c") puts("bad 1"); + unless (join(s, as) eq "axbxc") puts("bad 2"); + unless (join("xyz", as) eq "axyzbxyzc") puts("bad 3"); + unless (join(p, as) eq "apbpc") puts("bad 4"); + unless (join(p,p) eq "p") puts("bad 5"); + unless (join(" ", ai) eq "1 2 3") puts("bad 6"); + unless (join(w, ai) eq "1w2w3") puts("bad 7"); +} +builtin_7(); +} -output {} + +test builtin-8 {check join built-in errors} -body { +#lang L --line=1 +void builtin_8() +{ + int ai[]; + + join(); + join(ai,"s1","s2"); + join(ai, ai); + join(1); + join(1.1); + join("s"); + join("s", 1); + /* + * These test that the compiler does not assert due to join() + * not getting a type even though the call has an error. + */ + join() + 1; + join(ai, ai) + 1; + join("s", 1) + 1; +} +} -returnCodes {error} -match regexp -result {.*5: L Error: incorrect # args to join +.*6: L Error: incorrect # args to join +.*7: L Error: first arg to join not a string +.*8: L Error: incorrect # args to join +.*9: L Error: incorrect # args to join +.*10: L Error: incorrect # args to join +.*11: L Error: second arg to join not an array or list +} + +test builtin-9 {check re-declaration of built-ins} -body { +#lang L --line=1 +void abs() {} +void assert() {} +void die() {} +void join() {} +void keys() {} +void length() {} +void pop() {} +void push() {} +void rename() {} +void sort() {} +void undef() {} +void warn() {} +} -returnCodes {error} -match regexp -result {.*1: L Error: function 'abs' conflicts with built-in +.*2: L Error: function 'assert' conflicts with built-in +.*3: L Error: function 'die' conflicts with built-in +.*4: L Error: function 'join' conflicts with built-in +.*5: L Error: function 'keys' conflicts with built-in +.*6: L Error: function 'length' conflicts with built-in +.*7: L Error: function 'pop' conflicts with built-in +.*8: L Error: function 'push' conflicts with built-in +.*9: L Error: function 'rename' conflicts with built-in +.*10: L Error: function 'sort' conflicts with built-in +.*11: L Error: function 'undef' conflicts with built-in +.*12: L Error: function 'warn' conflicts with built-in +} + +test builtin-10 {check built-ins stack integrity} -body { +#lang L --line=1 +void builtin_10() +{ + /* + * This checks that an ignored return value doesn't leave the + * stack unbalanced (which would cause a crash). + */ + + int a[], i; + int n = 100; + int h{int} = { 1=>1, 2=>2 }; + + for (i = 0; i < n; ++i) { + push(&a, i); + abs(1); + assert(1); + join(" ", {"a","b"}); + keys(h); + length(h); + pop(&a); + push(&a, i); + sort({3,2,1}); + split("x y z"); + undef(h{0}); + } + unless (length(a) == n) puts("bad 1"); +} +builtin_10(); +} -output {} + +test builtin-11 {check push onto class and instance variables} -body { +#lang L --line=1 +class builtin_11 +{ + public int apubl[]; + instance { + public int ainst[]; + } +} +void builtin_11_main() +{ + builtin_11 o = builtin_11_new(); + + push(&builtin_11->apubl, 1); + push(&builtin_11->apubl, 2); + push(&builtin_11->apubl, 3); + unless (length(builtin_11->apubl) == 3) puts("bad 1.1"); + unless (builtin_11->apubl[0] == 1) puts("bad 1.2"); + unless (builtin_11->apubl[1] == 2) puts("bad 1.3"); + unless (builtin_11->apubl[2] == 3) puts("bad 1.4"); + + push(&o->ainst, 1); + push(&o->ainst, 2); + push(&o->ainst, 3); + unless (length(o->ainst) == 3) puts("bad 2.1"); + unless (o->ainst[0] == 1) puts("bad 2.2"); + unless (o->ainst[1] == 2) puts("bad 2.3"); + unless (o->ainst[2] == 3) puts("bad 2.4"); + + builtin_11_delete(o); +} +builtin_11_main(); +} -output {} + +test builtin-11.2 {check push and pop built-in} -body { +#lang L --line=1 +void builtin_11_2() +{ + string aa[][], s; + string ha{string}[]; + struct { + string a[]; + string aaaa[][][][]; + } st; + + aa = undef; + push(&aa[0], "a"); + unless ((tcl)aa[0] eq "a") puts("bad 1.1"); + unless (defined(aa[0])) puts("bad 1.2"); + push(&aa[0], "b"); + unless ((tcl)aa[0] eq "a b") puts("bad 1.3"); + push(&aa[0], "c"); + unless ((tcl)aa[0] eq "a b c") puts("bad 1.4"); + s = pop(&aa[0]); + unless (defined(s) && (s eq "c")) puts("bad 1.5"); + s = pop(&aa[0]); + unless (s eq "b") puts("bad 1.6"); + s = pop(&aa[0]); + unless (s eq "a") puts("bad 1.7"); + s = pop(&aa[0]); + if (defined(s)) puts("bad 1.8"); + s = pop(&aa[0]); + if (defined(s)) puts("bad 1.9"); + + aa[0] = {"x","y"}; + push(&aa[0], "a"); + unless ((tcl)aa[0] eq "x y a") puts("bad 2.1"); + push(&aa[0], "b"); + unless ((tcl)aa[0] eq "x y a b") puts("bad 2.2"); + s = pop(&aa[0]); + unless (defined(s) && (s eq "b")) puts("bad 2.3"); + s = pop(&aa[0]); + unless (s eq "a") puts("bad 2.4"); + s = pop(&aa[0]); + unless (s eq "y") puts("bad 2.5"); + s = pop(&aa[0]); + unless (s eq "x") puts("bad 2.6"); + s = pop(&aa[0]); + if (defined(s)) puts("bad 2.7"); + s = pop(&aa[0]); + if (defined(s)) puts("bad 2.8"); + + ha = undef; + push(&ha{"new"}, "a"); + unless ((tcl)ha{"new"} eq "a") puts("bad 5.1"); + unless (defined(ha{"new"})) puts("bad 5.2"); + push(&ha{"new"}, "b"); + unless ((tcl)ha{"new"} eq "a b") puts("bad 5.3"); + push(&ha{"new"}, "c"); + unless ((tcl)ha{"new"} eq "a b c") puts("bad 5.4"); + s = pop(&ha{"new"}); + unless (defined(s) && (s eq "c")) puts("bad 5.5"); + s = pop(&ha{"new"}); + unless (s eq "b") puts("bad 5.6"); + s = pop(&ha{"new"}); + unless (s eq "a") puts("bad 5.7"); + s = pop(&ha{"new"}); + if (defined(s)) puts("bad 5.8"); + s = pop(&ha{"new"}); + if (defined(s)) puts("bad 5.9"); + + ha{"new"} = {"p","q"}; + push(&ha{"new"}, "a"); + unless ((tcl)ha{"new"} eq "p q a") puts("bad 6.1"); + push(&ha{"new"}, "b"); + unless ((tcl)ha{"new"} eq "p q a b") puts("bad 6.2"); + s = pop(&ha{"new"}); + unless (defined(s) && (s eq "b")) puts("bad 6.3"); + s = pop(&ha{"new"}); + unless (s eq "a") puts("bad 6.4"); + s = pop(&ha{"new"}); + unless (s eq "q") puts("bad 6.5"); + s = pop(&ha{"new"}); + unless (s eq "p") puts("bad 6.6"); + s = pop(&ha{"new"}); + if (defined(s)) puts("bad 6.7"); + s = pop(&ha{"new"}); + if (defined(s)) puts("bad 6.8"); + + st.a = undef; + push(&st.a, "a"); + unless ((tcl)st.a eq "a") puts("bad 10.1"); + unless (defined(st.a)) puts("bad 10.2"); + push(&st.a, "b"); + unless ((tcl)st.a eq "a b") puts("bad 10.3"); + push(&st.a, "c"); + unless ((tcl)st.a eq "a b c") puts("bad 10.4"); + s = pop(&st.a); + unless (defined(s) && (s eq "c")) puts("bad 10.5"); + s = pop(&st.a); + unless (s eq "b") puts("bad 10.6"); + s = pop(&st.a); + unless (s eq "a") puts("bad 10.7"); + s = pop(&st.a); + if (defined(s)) puts("bad 10.8"); + s = pop(&st.a); + if (defined(s)) puts("bad 10.9"); + + st.a = {"r","s"}; + push(&st.a, "a"); + unless ((tcl)st.a eq "r s a") puts("bad 11.1"); + push(&st.a, "b"); + unless ((tcl)st.a eq "r s a b") puts("bad 11.2"); + s = pop(&st.a); + unless (defined(s) && (s eq "b")) puts("bad 11.3"); + s = pop(&st.a); + unless (s eq "a") puts("bad 11.4"); + s = pop(&st.a); + unless (s eq "s") puts("bad 11.5"); + s = pop(&st.a); + unless (s eq "r") puts("bad 11.6"); + s = pop(&st.a); + if (defined(s)) puts("bad 11.7"); + s = pop(&st.a); + if (defined(s)) puts("bad 11.8"); + + push(&st.aaaa[0][1][2], "a"); + unless ((tcl)st.aaaa[0][1][2] eq "a") puts("bad 15.1"); + unless (defined(st.aaaa[0][1][2])) puts("bad 15.2"); + push(&st.aaaa[0][1][2], "b"); + unless ((tcl)st.aaaa[0][1][2] eq "a b") puts("bad 15.2"); + push(&st.aaaa[0][1][2], "c"); + unless ((tcl)st.aaaa[0][1][2] eq "a b c") puts("bad 15.3"); + s = pop(&st.aaaa[0][1][2]); + unless (defined(s) && (s eq "c")) puts("bad 15.4"); + s = pop(&st.aaaa[0][1][2]); + unless (s eq "b") puts("bad 15.5"); + s = pop(&st.aaaa[0][1][2]); + unless (s eq "a") puts("bad 15.6"); + s = pop(&st.aaaa[0][1][2]); + if (defined(s)) puts("bad 15.7"); + s = pop(&st.aaaa[0][1][2]); + if (defined(s)) puts("bad 15.8"); +} +builtin_11_2(); +} -output {} + +test builtin-11.3 {check push built-in with multiple args} -body { +#lang L --line=1 +void builtin_11_3() +{ + int i; + string a[], aa[][]; + + push(&a, "a"); + unless (join("",a) eq "a") puts("bad 1.1"); + unless (length(a) == 1) puts("bad 1.2"); + + push(&a, "b", "c"); + unless (join("",a) eq "abc") puts("bad 2.1"); + unless (length(a) == 3) puts("bad 2.2"); + + push(&a, "d", "e", "f"); + unless (join("",a) eq "abcdef") puts("bad 3.1"); + unless (length(a) == 6) puts("bad 3.2"); + + /* Check that the first arg is evaluated exactly once. */ + undef(a); + i = 0; + push(&aa[i++], "a", "b", "c"); + unless ((i == 1) && eq(aa[0],{"a","b","c"})) puts("bad 4.1"); + unless (length(aa) == 1) puts("bad 4.2"); + if (aa[1]) puts("bad 4.3"); +} +builtin_11_3(); +} -output {} + +test builtin-11.4 {check push built-in with list args} -body { +#lang L --line=1 +void builtin_11_4() +{ + int a[], aa[][], aaa[][][]; + struct { + int a[]; + } st; + string sa[], saa[][]; + + /* Check pushing to a plain variable. */ + + push(&a, 1); + unless (eq(a,{1})) puts("bad 1.1"); + + push(&a, {2}); + unless (eq(a,{1,2})) puts("bad 1.2"); + + push(&a, {3,4}); + unless (eq(a,{1,2,3,4})) puts("bad 1.3"); + + push(&a, {5,6,7}); + unless (eq(a,{1,2,3,4,5,6,7})) puts("bad 1.4"); + + push(&a, 8, {9,10}); + unless (eq(a,{1,2,3,4,5,6,7,8,9,10})) puts("bad 1.5"); + + push(&a, {11,12}, 13); + unless (eq(a,{1,2,3,4,5,6,7,8,9,10,11,12,13})) puts("bad 1.6"); + + push(&a, 14, {15}, 16, {17,18}); + unless (eq(a,{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18})) { + puts("bad 1.7"); + } + + /* Check pushing to a struct member (deep dive). */ + + push(&st.a, 1); + unless (eq(st.a,{1})) puts("bad 2.1"); + + push(&st.a, {2}); + unless (eq(st.a,{1,2})) puts("bad 2.2"); + + push(&st.a, {3,4}); + unless (eq(st.a,{1,2,3,4})) puts("bad 2.3"); + + push(&st.a, {5,6,7}); + unless (eq(st.a,{1,2,3,4,5,6,7})) puts("bad 2.4"); + + push(&st.a, 8, {9,10}); + unless (eq(st.a,{1,2,3,4,5,6,7,8,9,10})) puts("bad 2.5"); + + push(&st.a, {11,12}, 13); + unless (eq(st.a,{1,2,3,4,5,6,7,8,9,10,11,12,13})) puts("bad 2.6"); + + push(&st.a, 14, {15}, 16, {17,18}); + unless (eq(st.a,{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18})) { + puts("bad 2.7"); + } + + /* + * If you push to a type[], you can push a type or a type[], + * and you can mix and match in one push. Check that these + * are done correctly. + */ + + push(&aa, {1,1}); // should push a single element {1,1} + unless (length(aa) == 1) puts("bad 3.0"); + unless (eq(aa, { {1,1} })) puts("bad 3.1"); + push(&aa, {2,2}); + unless (eq(aa, { {1,1}, {2,2} })) puts("bad 3.2"); + push(&aa, { {3,3} }); // should push {3,3} + unless (eq(aa, { {1,1}, {2,2}, {3,3} })) puts("bad 3.3"); + push(&aa, { {4,4},{5,5} }); // should push {4,4} and {5,5} + unless (eq(aa, { {1,1}, {2,2}, {3,3}, {4,4}, {5,5} })) puts("bad 3.4"); + undef(aa); + push(&aa, {1,1}, {{2,2}}, {{3,3},{4,4}}, {5,5}); + unless (eq(aa, { {1,1}, {2,2}, {3,3}, {4,4}, {5,5} })) puts("bad 3.5"); + + push(&aaa[0], {1,1}); // should push a single element {1,1} + unless (length(aaa[0]) == 1) puts("bad 3.10"); + unless (eq(aaa[0], { {1,1} })) puts("bad 3.11"); + push(&aaa[0], {2,2}); + unless (eq(aaa[0], { {1,1}, {2,2} })) puts("bad 3.12"); + push(&aaa[0], { {3,3} }); // should push {3,3} + unless (eq(aaa[0], { {1,1}, {2,2}, {3,3} })) puts("bad 3.13"); + push(&aaa[0], { {4,4},{5,5} }); // should push {4,4} and {5,5} + unless (eq(aaa[0], { {1,1}, {2,2}, {3,3}, {4,4}, {5,5} })) { + puts("bad 3.14"); + } + undef(aaa[0]); + push(&aaa[0], {1,1}, {{2,2}}, {{3,3},{4,4}}, {5,5}); + unless (eq(aaa[0], { {1,1}, {2,2}, {3,3}, {4,4}, {5,5} })) { + puts("bad 3.15"); + } + + /* + * Check that things are appended as list elements and not via + * string concat. + */ + + undef(sa); + push(&sa, "a b"); + unless (length(sa) == 1) puts("bad 4.1"); + unless (sa[0] == "a b") puts("bad 4.2"); + undef(sa); + push(&sa, {"a b"}); + unless (length(sa) == 1) puts("bad 4.3"); + unless (sa[0] == "a b") puts("bad 4.4"); + + undef(saa[0]); + push(&saa[0], "a b"); + unless (length(saa[0]) == 1) puts("bad 5.1"); + unless (saa[0][0] == "a b") puts("bad 5.2"); + undef(saa[0]); + push(&saa[0], {"a b"}); + unless (length(saa[0]) == 1) puts("bad 5.3"); + unless (saa[0][0] == "a b") puts("bad 5.4"); +} +builtin_11_4(); +} -output {} + +test builtin-11.5 {check insert built-in} -body { +#lang L --line=1 +void builtin_11_5() +{ + int a[], i; + struct { + int a[]; + } st; + + /* Check inserting into a plain variable, scalar args. */ + + a = {}; + insert(&a, 0, 1); + unless (eq(a, {1})) puts("bad 1.1"); + insert(&a, 0, 2); + unless (eq(a, {2,1})) puts("bad 1.2"); + insert(&a, 0, 3, 4); + unless (eq(a, {3,4,2,1})) puts("bad 1.3"); + insert(&a, 0, 5, 6, 7); + unless (eq(a, {5,6,7,3,4,2,1})) puts("bad 1.4"); + + /* Check inserting into a struct member (deep dive), scalar args. */ + + st.a = {}; + insert(&st.a, 0, 1); + unless (eq(st.a, {1})) puts("bad 2.1"); + insert(&st.a, 1, 2); + unless (eq(st.a, {1,2})) puts("bad 2.2"); + insert(&st.a, 1, 3, 4); + unless (eq(st.a, {1,3,4,2})) puts("bad 2.3"); + insert(&st.a, 0, 5, 6, 7); + unless (eq(st.a, {5,6,7,1,3,4,2})) puts("bad 2.4"); + insert(&st.a, 2, 8); + unless (eq(st.a, {5,6,8,7,1,3,4,2})) puts("bad 2.5"); + insert(&st.a, 0, 9); + unless (eq(st.a, {9,5,6,8,7,1,3,4,2})) puts("bad 2.6"); + + /* Check inserting into a plain variable, scalar and list args. */ + + a = {}; + insert(&a, 0, 1); + unless (eq(a, {1})) puts("bad 3.1"); + insert(&a, 0, {2}); + unless (eq(a, {2,1})) puts("bad 3.2"); + insert(&a, 0, 3, {4,5}); + unless (eq(a, {3,4,5,2,1})) puts("bad 3.3"); + insert(&a, 0, {5,6,7}, 8, {9,10}); + unless (eq(a, {5,6,7,8,9,10,3,4,5,2,1})) puts("bad 3.4 ${a}"); + + /* Check with a struct member (deep dive), scalar and list args. */ + + st.a = {}; + insert(&st.a, 0, 1); + unless (eq(st.a, {1})) puts("bad 4.1"); + insert(&st.a, 0, {2}); + unless (eq(st.a, {2,1})) puts("bad 4.2"); + insert(&st.a, 0, 3, {4,5}); + unless (eq(st.a, {3,4,5,2,1})) puts("bad 4.3"); + insert(&st.a, 0, {5,6,7}, 8, {9,10}); + unless (eq(st.a, {5,6,7,8,9,10,3,4,5,2,1})) puts("bad 4.4 ${a}"); + + /* Check with an expression as the index arg. */ + + a = {}; + i = 0; + insert(&a, i, 1); + unless (eq(a, {1})) puts("bad 5.1"); + insert(&a, i, 2); + unless (eq(a, {2,1})) puts("bad 5.2"); + insert(&a, i+1, 3); + unless (eq(a, {2,3,1})) puts("bad 5.3"); + insert(&a, --i, 5); // try a side effect in the index arg + unless (eq(a, {2,3,1,5})) puts("bad 5.4"); + insert(&a, i+1, 6); + unless (eq(a, {6,2,3,1,5})) puts("bad 5.5"); +} +builtin_11_5(); +} -output {} + +test builtin-11.6 {check unshift built-in} -body { +#lang L --line=1 +void builtin_11_6() +{ + int a[]; + struct { + int a[]; + } st; + + /* Check unshifting into a plain variable, scalar args. */ + + a = {}; + unshift(&a, 0); + unless (eq(a, {0})) puts("bad 1.1"); + unshift(&a, 1); + unless (eq(a, {1,0})) puts("bad 1.2"); + unshift(&a, 2, 3); + unless (eq(a, {2,3,1,0})) puts("bad 1.3"); + unshift(&a, 4, 5, 6); + unless (eq(a, {4,5,62,3,1,0})) puts("bad 1.4"); + + /* Check unshifting into a struct member (deep dive), scalar args. */ + + st.a = {}; + unshift(&st.a, 1); + unless (eq(st.a, {1})) puts("bad 2.1"); + unshift(&st.a, 2); + unless (eq(st.a, {2,1})) puts("bad 2.2"); + unshift(&st.a, 3, 4); + unless (eq(st.a, {3,4,2,1})) puts("bad 2.3"); + unshift(&st.a, 5, 6, 7); + unless (eq(st.a, {5,6,7,3,4,2,1})) puts("bad 2.4"); + unshift(&st.a, 8); + unless (eq(st.a, {8,5,6,7,3,4,2,1})) puts("bad 2.5"); + unshift(&st.a, 9); + unless (eq(st.a, {9,8,6,7,8,3,4,2,1})) puts("bad 2.6"); + + /* Check unshifting into a plain variable, scalar and list args. */ + + a = {}; + unshift(&a, 1); + unless (eq(a, {1})) puts("bad 3.1"); + unshift(&a, {2}); + unless (eq(a, {2,1})) puts("bad 3.2"); + unshift(&a, 3, {4,5}); + unless (eq(a, {3,4,5,2,1})) puts("bad 3.3"); + unshift(&a, {5,6,7}, 8, {9,10}); + unless (eq(a, {5,6,7,8,9,10,3,4,5,2,1})) puts("bad 3.4 ${a}"); + + /* Check with a struct member (deep dive), scalar and list args. */ + + st.a = {}; + unshift(&st.a, 1); + unless (eq(st.a, {1})) puts("bad 4.1"); + unshift(&st.a, {2}); + unless (eq(st.a, {2,1})) puts("bad 4.2"); + unshift(&st.a, 3, {4,5}); + unless (eq(st.a, {3,4,5,2,1})) puts("bad 4.3"); + unshift(&st.a, {5,6,7}, 8, {9,10}); + unless (eq(st.a, {5,6,7,8,9,10,3,4,5,2,1})) puts("bad 4.4 ${a}"); +} +} -output {} + + +test builtin-11.7 {check shift built-in} -body { +#lang L --line=1 +void builtin_11_7() +{ + int a[]; + struct { + int a[]; + } st; + + a = { 1,2,3,4,5 }; + unless (shift(&a) == 1) puts("bad 1.1"); + unless (eq(a, {2,3,4,5})) puts("bad 1.2"); + unless (shift(&a) == 2) puts("bad 1.3"); + unless (eq(a, {3,4,5})) puts("bad 1.4"); + unless (shift(&a) == 3) puts("bad 1.5"); + unless (eq(a, {4,5})) puts("bad 1.6"); + unless (shift(&a) == 4) puts("bad 1.7"); + unless (eq(a, {5})) puts("bad 1.8"); + unless (shift(&a) == 5) puts("bad 1.9"); + unless (eq(a, {})) puts("bad 1.10"); + unless (defined(a)) puts("bad 1.11"); + if (defined(shift(&a))) puts("bad 1.12"); + unless (eq(a, {})) puts("bad 1.13"); + unless (defined(a)) puts("bad 1.14"); + + st.a = { 1,2,3,4,5 }; + unless (shift(&st.a) == 1) puts("bad 2.1"); + unless (eq(st.a, {2,3,4,5})) puts("bad 2.2"); + unless (shift(&st.a) == 2) puts("bad 2.3"); + unless (eq(st.a, {3,4,5})) puts("bad 2.4"); + unless (shift(&st.a) == 3) puts("bad 2.5"); + unless (eq(st.a, {4,5})) puts("bad 2.6"); + unless (shift(&st.a) == 4) puts("bad 2.7"); + unless (eq(st.a, {5})) puts("bad 2.8"); + unless (shift(&st.a) == 5) puts("bad 2.9"); + unless (eq(st.a, {})) puts("bad 2.10"); + unless (defined(st.a)) puts("bad 2.11"); + if (defined(shift(&st.a))) puts("bad 2.12"); + unless (eq(st.a, {})) puts("bad 2.13"); + unless (defined(st.a)) puts("bad 2.14"); +} +builtin_11_7(); +} -output {} + +test builtin-14 {check errors in push and pop built-ins} -body { +#lang L --line=1 +int[] builtin_14_array() { return {1,2,3}; } +void builtin_14() +{ + int i; + string s; + + /* The first arg has array type, but it's not an l-value. */ + push(&(builtin_14_array()), 0); + pop(&(builtin_14_array())); + + pop(&3) + 1; // not an array reference + pop(&i) + 1; // not an array reference + pop(&s) + 1; // not an array reference + pop() + 1; // bad # args + pop(1,2) + 1; // bad # args + /* + * We add 1 above to test that the compiler does not assert + * due to pop() not getting a type even though there is an + * error. + */ +} +} -returnCodes {error} -match regexp -result {.*8: L Error: invalid l-value in push +.*9: L Error: invalid l-value in pop +.*11: L Error: arg to pop not an array reference.* +.*12: L Error: arg to pop not an array reference.* +.*13: L Error: arg to pop not an array reference.* +.*14: L Error: incorrect # arguments to pop +.*15: L Error: incorrect # arguments to pop +} + +test builtin-14.2 {check errors in insert built-in} -body { +#lang L --line=1 +int[] builtin_14_2_array() { return {1,2,3}; } +void builtin_14_2() +{ + int i, a[]; + string s; + + /* The first arg has array type, but it's not an l-value. */ + insert(&(builtin_14_2_array()), 0, 0); + + insert(&3, 0, 0) + 1; // 1st arg not an array reference + insert(&i, 0, 0) + 1; // 1st arg not an array reference + insert(&s, 0, 0) + 1; // 1st arg not an array reference + insert(&a, "s", 0) + 1; // 2nd arg not an int + insert(&a, 1.0, 0) + 1; // 2nd arg not an int + insert(&a, a, 0) + 1; // 2nd arg not an int + insert(&a, &i, 0) + 1; // 2nd arg not an int + insert() + 1; // too few args + insert(&a, 0) + 1; // too few args + /* + * We add 1 above to test that the compiler does not assert + * due to insert() not getting a type even though there is an + * error. + */ +} +} -returnCodes {error} -match regexp -result {.*8: L Error: invalid l-value in insert +.*10: L Error: first arg to insert not an array reference.* +.*11: L Error: first arg to insert not an array reference.* +.*12: L Error: first arg to insert not an array reference.* +.*13: L Error: second arg to insert not an int +.*14: L Error: second arg to insert not an int +.*15: L Error: second arg to insert not an int +.*16: L Error: second arg to insert not an int +.*17: L Error: too few arguments to insert +.*18: L Error: too few arguments to insert +} + +test builtin-14_3 {check errors in unshift built-in} -body { +#lang L --line=1 +int[] builtin_14_3_array() { return {1,2,3}; } +void builtin_14_3() +{ + int i, a[]; + string s; + + /* The first arg has array type, but it's not an l-value. */ + unshift(&(builtin_14_3_array()), 0); + + unshift(&3, 0) + 1; // 1st arg not an array reference + unshift(&i, 0) + 1; // 1st arg not an array reference + unshift(&s, 0) + 1; // 1st arg not an array reference + unshift(&a, "s") + 1; // 2nd arg not an int + unshift(&a, 1.0) + 1; // 2nd arg not an int + unshift(&a, &i) + 1; // 2nd arg not an int + unshift() + 1; // too few args + /* + * We add 1 above to test that the compiler does not assert + * due to pop() not getting a type even though there is an + * error. + */ +} +} -returnCodes {error} -match regexp -result {.*8: L Error: invalid l-value in unshift +.*10: L Error: first arg to unshift not an array reference.* +.*11: L Error: first arg to unshift not an array reference.* +.*12: L Error: first arg to unshift not an array reference.* +.*13: L Error: arg #2 to unshift has type incompatible with array +.*14: L Error: arg #2 to unshift has type incompatible with array +.*15: L Error: arg #2 to unshift has type incompatible with array +.*16: L Error: too few arguments to unshift +} + +test builtin-14_4 {check errors in shift built-in} -body { +#lang L --line=1 +int[] builtin_14_4_array() { return {1,2,3}; } +void builtin_14_4() +{ + int i; + string s; + + /* The first arg has array type, but it's not an l-value. */ + shift(&(builtin_14_array())); + + shift(&3) + 1; // not an array reference + shift(&i) + 1; // not an array reference + shift(&s) + 1; // not an array reference + shift() + 1; // bad # args + shift(1,2) + 1; // bad # args + /* + * We add 1 above to test that the compiler does not assert + * due to pop() not getting a type even though there is an + * error. + */ +} +} -returnCodes {error} -match regexp -result {.*8: L Error: invalid l-value in shift +.*10: L Error: arg to shift not an array reference.* +.*11: L Error: arg to shift not an array reference.* +.*12: L Error: arg to shift not an array reference.* +.*13: L Error: incorrect # arguments to shift +.*14: L Error: incorrect # arguments to shift +} + +test builtin-15 {check abs built-in} -body { +#lang L --line=1 +void builtin_15() +{ + poly p; + + unless (abs(1) == 1) puts("bad 1.1"); + unless (abs(0) == 0) puts("bad 1.2"); + unless (abs(-1) == 1) puts("bad 1.3"); + + unless (abs(1.1) == 1.1) puts("bad 2.1"); + unless (abs(0.0) == 0.0) puts("bad 2.2"); + unless (abs(-1.1) == 1.1) puts("bad 2.3"); + + p = -1; + unless (abs(p) == 1) puts("bad 3.1"); + p = -1.1; + unless (abs(p) == 1.1) puts("bad 3.2"); +} +builtin_15(); +} -output {} + +test builtin-16 {check abs built-in errors} -body { +#lang L --line=1 +void builtin_16() +{ + abs(); + abs(1, 1); + abs(1.1, 1.1); + abs("bad"); + /* + * This tests that the compiler does not assert due to abs() + * not getting a type even though the call has an error. + */ + abs() + 1; +} +} -returnCodes {error} -match regexp -result {.*3: L Error: incorrect # args to abs +.*4: L Error: incorrect # args to abs +.*5: L Error: incorrect # args to abs +.*6: L Error: must pass int or float to abs +} + +test builtin-17 {check typeof built-in} -body { +#lang L --line=1 +class builtin_17_cls {} +typedef int builtin_17_type1; +typedef builtin_17_type1 builtin_17_type2; +void builtin_17() +{ + int i; + string s; + poly p; + widget w; + int a[]; + string h{string}; + struct { int i; } str; + builtin_17_type1 v1; + builtin_17_type2 v2; + builtin_17_cls c; + + unless (typeof(i) eq "int") puts("bad 1"); + unless (typeof(s) eq "string") puts("bad 2"); + unless (typeof(p) eq "poly") puts("bad 3"); + unless (typeof(w) eq "widget") puts("bad 4"); + unless (typeof(a) eq "array") puts("bad 5"); + unless (typeof(h) eq "hash") puts("bad 6"); + unless (typeof(str) eq "struct") puts("bad 7"); + unless (typeof(c) eq "builtin_17_cls") puts("bad 8"); + unless (typeof(v1) eq "builtin_17_type1") puts("bad 9"); + unless (typeof(v2) eq "builtin_17_type2") puts("bad 10"); + unless (typeof(builtin_17) eq "function") puts("bad 11"); +} +builtin_17(); +} -output {} + +test builtin-18 {check typeof built-in errors} -body { +#lang L --line=1 -nowarn +void builtin_18() +{ + int i = 0; + + typeof("bad"); + typeof(i+0); + typeof((string)i); +} +} -returnCodes {error} -match regexp -result {.*5: L Error: argument to typeof\(\) not a variable +.*6: L Error: argument to typeof\(\) not a variable +.*7: L Error: argument to typeof\(\) not a variable +} + +test builtin-19.1 {check min/max built-ins} -body { +#lang L --line=1 +void builtin_19_1() +{ + unless (min(-1, 1) == -1) puts("bad 1"); + unless (min(2, 1) == 1) puts("bad 2"); + + unless (min(-1.0, 1.0) == -1.0) puts("bad 3"); + unless (min(2.0, 1.0) == 1.0) puts("bad 4"); +} +builtin_19_1(); +} -output {} + +test builtin-19.2 {check min/max built-in errors} -body { +#lang L --line=1 +void builtin_19_2() +{ + min(); + min(1); + min(1,2,3); + max(); + max(1); + max(1,2,3); + min("bad","bad"); + max("bad","bad"); +} +} -returnCodes {error} -match regexp -result {.*3: L Error: incorrect # args to min +.*4: L Error: incorrect # args to min +.*5: L Error: incorrect # args to min +.*6: L Error: incorrect # args to max +.*7: L Error: incorrect # args to max +.*8: L Error: incorrect # args to max +.*9: L Error: expected type int or float but got string in min/max +.*10: L Error: expected type int or float but got string in min/max +} + +test builtin-20 {check (expand) operator in built-ins} -body { +#lang L --line=1 +void builtin_20() +{ + string res[]; + string sa[] = { "123", "3", "987" }; + string opts[] = { "-decreasing", "-integer" }; + + res = sort((expand)opts, sa); + unless (eq(res, {"3","123","987"})) puts("bad 1.1"); +} +builtin_20(); +} -returnCodes {error} -match regexp -result {.*7: L Error: \(expand\) illegal with this function +} + +test line-file-1 {test __LINE__ and __FILE__} -body { +#lang L --line=1 +void line_file_1() +{ + unless(basename(__FILE__) eq "l-core.test") puts("bad 1.1"); + unless(__LINE__ == 4) puts("bad 1.2"); + unless(__LINE__ == 5) puts("bad 1.3"); + unless(__LINE__ == 6) puts("bad 1.4"); + unless(__FUNC__ eq "line_file_1") puts("bad 1.5"); +} +line_file_1(); +} -output {} + +test line-file-2 {test __LINE__, __FILE__, and __FUNC__ errors} -body { +#lang L --line=1 +void line_file_2_s(string &s) { s = "bad"; } +void line_file_2_i(int &i) { i = 1; } +void line_file_2() +{ + __FILE__ = "bad"; + __LINE__ = 1; + __FUNC__ = "bad"; + line_file_2_s(&__FILE__); + line_file_2_i(&__LINE__); + line_file_2_i(&__FUNC__); +} +} -returnCodes {error} -match regexp -result {.*5: L Error: invalid l-value in assignment +.*6: L Error: invalid l-value in assignment +.*7: L Error: invalid l-value in assignment +.*8: L Error: illegal operand to & +.*9: L Error: illegal operand to & +.*10: L Error: illegal operand to & +} + +test line-file-3 {test __FUNC__} -body { +#lang L --line=1 +unless (__FUNC__ =~ /\d+%l_toplevel/) puts("bad 10.1"); +void line_file_3b() +{ + unless (__FUNC__ eq "line_file_3b") puts("bad 1"); +} +void line_file_3() +{ + unless (__FUNC__ eq "line_file_3") puts("bad 2"); + line_file_3b(); +} +unless (__FUNC__ =~ /\d+%l_toplevel/) puts("bad 10.2"); +line_file_3(); +} -output {} + +test lregex-1 {test a trivial regex} -body { +#lang L --line=1 +int lregex_1(void) { + if ("x" =~ /x+/) { return(1); } else { return(0); } +} +#lang tcl +lregex_1; +} -result {1} + +test class-1.1 {test basic class functionality} -body { +#lang L --line=1 +int class_1_1_inits = 0; +int class_1_1_frees = 0; +int class_1_1_foos = 0; +int class_1_1_privs = 0; +class class_1_1 +{ + public int cvar1 = 123; + public int cvar2 = cvar1 * 2; + instance { + public string inst = "initial"; + } + private void priv(); + constructor class_1_1_init(string s) + { + unless (inst eq "initial") puts("bad c1"); + inst = s; + ++class_1_1_inits; + } + destructor class_1_1_free(class_1_1 self) + { + ++class_1_1_frees; + } + void class_1_1_foo(class_1_1 self) + { + ++class_1_1_foos; + priv(); + } + string class_1_1_inst(class_1_1 self) + { + return (inst); + } + int class_1_1_cvar1(class_1_1 self) + { + return (cvar1); + } + int class_1_1_cvar2(class_1_1 self) + { + return (cvar2); + } + private void priv() + { + ++class_1_1_privs; + } +} +void class_1_1_main() +{ + class_1_1 o = class_1_1_init("constructed"); + + unless (class_1_1_inst(o) eq "constructed") puts("bad 1.1"); + unless (class_1_1_cvar1(o) == 123) puts("bad 1.2"); + unless (class_1_1_cvar2(o) == 246) puts("bad 1.3"); + unless (class_1_1_inits == 1) puts("bad 1.4"); + unless (class_1_1_frees == 0) puts("bad 1.5"); + unless (class_1_1_foos == 0) puts("bad 1.6"); + unless (class_1_1_privs == 0) puts("bad 1.7"); + + class_1_1_foo(o); + unless (class_1_1_inits == 1) puts("bad 2.1"); + unless (class_1_1_frees == 0) puts("bad 2.2"); + unless (class_1_1_foos == 1) puts("bad 2.3"); + unless (class_1_1_privs == 1) puts("bad 2.4"); + + class_1_1_foo(o); + unless (class_1_1_inits == 1) puts("bad 3.1"); + unless (class_1_1_frees == 0) puts("bad 3.2"); + unless (class_1_1_foos == 2) puts("bad 3.3"); + unless (class_1_1_privs == 2) puts("bad 3.4"); + + unless (class_1_1_inst(o) eq "constructed") puts("bad 4.1"); + unless (class_1_1_inits == 1) puts("bad 4.1"); + unless (class_1_1_frees == 0) puts("bad 4.2"); + unless (class_1_1_foos == 2) puts("bad 4.3"); + unless (class_1_1_privs == 2) puts("bad 4.4"); + + class_1_1_free(o); + unless (class_1_1_inits == 1) puts("bad 5.1"); + unless (class_1_1_frees == 1) puts("bad 5.2"); + unless (class_1_1_foos == 2) puts("bad 5.3"); + unless (class_1_1_privs == 2) puts("bad 5.4"); +} +class_1_1_main(); +} -output {} + +test class-1.2 {test multiple object instances} -body { +#lang L --line=1 +class class_1_2 +{ + instance { + public int n; + } + constructor class_1_2_init(int i) { n = i; } + destructor class_1_2_free(class_1_2 self) {} + int class_1_2_inst(class_1_2 self) { return (n); } +} +void class_1_2_main() +{ + int i, j; + class_1_2 o[]; + + for (i = 0; i < 10; ++i) { + o[i] = class_1_2_init(i); + unless (class_1_2_inst(o[i]) == i) printf("bad 1 i=%d\n", i); + } + for (i = 0; i < 10; ++i) { + unless (class_1_2_inst(o[i]) == i) printf("bad 2 i=%d\n", i); + } + for (i = 0; i < 10; ++i) { + class_1_2_free(o[i]); + for (j = i+1; j < 10; ++j) { + unless (class_1_2_inst(o[j]) == j) { + printf("bad 3 j=%d\n", j); + } + } + } +} +class_1_2_main(); +} -output {} + +test class-1.3 {test class variables} -body { +#lang L --line=1 +class class_1_3 +{ + public string cls_var = "first"; + constructor class_1_3_init() {} + destructor class_1_3_free(class_1_3 self) {} + void class_1_3_set(class_1_3 self, string s) + { + cls_var = s; + } + string class_1_3_get(class_1_3 self) + { + return (cls_var); + } +} +void class_1_3_main() +{ + int i, j; + class_1_3 o[]; + + /* As we init objects, cls_var should not change. */ + for (i = 0; i < 10; ++i) { + o[i] = class_1_3_init(); + for (j = 0; j <= i; ++j) { + unless (class_1_3_get(o[j]) eq "first") { + printf("bad 1 j=%d\n", j); + } + } + } + /* All objects should see the change to "second". */ + class_1_3_set(o[5], "second"); + for (j = 0; i < 10; ++i) { + unless (class_1_3_get(o[i]) eq "second") { + printf("bad 2 i=%d\n", i); + } + } + /* Deleting one object shouldn't mess up cls_var. */ + class_1_3_free(o[5]); + for (j = 0; i < 10; ++i) { + if (i == 5) continue; + unless (class_1_3_get(o[i]) eq "second") { + printf("bad 2 i=%d\n", i); + } + } +} +class_1_3_main(); +} -output {} + +test class-1.4 {test no class instance variables} -body { +#lang L --line=1 +class class_1_4 +{ + public int cvar = 123; + constructor class_1_4_new() + { + unless (cvar == 123) puts ("bad c1"); + } + destructor class_1_4_delete(class_1_4 self) + { + unless (cvar == 123) puts ("bad d1"); + } +} +void class_1_4_main() +{ + class_1_4 o = class_1_4_new(); + class_1_4_delete(o); +} +class_1_4_main(); +} -output {} + +test class-1.5 {test no class variables} -body { +#lang L --line=1 +class class_1_5 +{ + instance { + public int inst = 123; + } + constructor class_1_5_new() + { + unless (inst == 123) puts ("bad c1"); + } + destructor class_1_5_delete(class_1_5 self) + { + unless (inst == 123) puts ("bad d1"); + } +} +void class_1_5_main() +{ + class_1_5 o = class_1_5_new(); + class_1_5_delete(o); +} +class_1_5_main(); +} -output {} + +test class-1.6 {test "->" as member variable selection} -body { +#lang L --line=1 +class class_1_6 +{ + public string cvar = "cvar"; + instance { + public string ivar = "ivar"; + } +} +void class_1_6_main() +{ + /* Check that -> works ("." is not allowed). */ + + class_1_6 o = class_1_6_new(); + + unless (class_1_6->cvar eq "cvar") puts("bad 1.1"); + unless (o->ivar eq "ivar") puts("bad 2.1"); + + class_1_6_delete(o); +} +class_1_6_main(); +} -output {} + +test class-1.7 {test indexing errors on class instance variables} -body { +#lang L --line=1 +class class_1_7 +{ + public string cvar = "cvar"; + instance { + public string ivar = "ivar"; + } +} +void class_1_7_main() +{ + /* Check that any index other than -> is caught as an error. */ + + class_1_7 o = class_1_7_new(); + + o.ivar; + o{"bad"}; + o[0]; +} +} -returnCodes {error} -match regexp -result {.*14: L Error: must access object only with -> +.*15: L Error: must access object only with -> +.*16: L Error: must access object only with -> +} + +test class-1.8 {check calling private member functions} -body { +#lang L --line=1 +/* + * Check that private member functions can be called from the + * constructor and destructor, whether they are declared before or + * after the call site. + */ +private int cnt1 = 0; +private int cnt2 = 0; +class class_1_8 +{ + private void p1() { ++cnt1; } + constructor class_1_8_new() + { + p1(); + p2(); + } + destructor class_1_8_delete(class_1_8 self) + { + p1(); + p2(); + } + public void class_1_8_foo(class_1_8 self) + { + p1(); + p2(); + } + private void p2() { ++cnt2; } +} +void class_1_8_main() +{ + class_1_8 o = class_1_8_new(); + unless (cnt1 == 1) puts("bad 1.1"); + unless (cnt2 == 1) puts("bad 1.2"); + class_1_8_foo(o); + unless (cnt1 == 2) puts("bad 2.1"); + unless (cnt2 == 2) puts("bad 2.2"); + class_1_8_delete(o); + unless (cnt1 == 3) puts("bad 3.1"); + unless (cnt2 == 3) puts("bad 3.2"); +} +class_1_8_main(); +} -output {} + +test class-1.9 {check calling class member fns before they are declared} -body { +#lang L --line=1 +/* + * Check the error cases to make sure that the proto is being + * processed before the call site even though it comes after. + */ +class class_1_9 +{ + void class_1_9_f1(class_1_9 self) + { + class_1_9 o = class_1_9_new(123); // error -- too many args + class_1_9_f2(o, 123); // error + } + constructor class_1_9_new() + { + class_1_9_f2(self, 123); // error + class_1_9_free(self, 123); // error + } + destructor class_1_9_free(class_1_9 self) + { + class_1_9_f2(self, 123); // error + } + void class_1_9_f2(class_1_9 self) + { + } +} +} -returnCodes {error} -match regexp -result {.*14: L Error: too many arguments for function class_1_9_f2 +.*15: L Error: too many arguments for function class_1_9_free +.*19: L Error: too many arguments for function class_1_9_f2 +.*9: L Error: too many arguments for function class_1_9_new +.*10: L Error: too many arguments for function class_1_9_f2 +} + +test class-1.10 {check forward class declarations} -body { +#lang L --line=1 +class class_1_10a +{ + constructor class_1_10a_new() {} +} +class class_1_10a; // ok -- class_1_10a already declared +class class_1_10a; // ok -- class_1_10a already declared +class class_1_10b; // forward declaration +private class_1_10a obj_a; +private class_1_10b obj_b; +class class_1_10b +{ + constructor class_1_10b_new() {} +} +void class_1_10_main() +{ + obj_a = class_1_10a_new(); + obj_b = class_1_10b_new(); +} +class_1_10_main(); +} -output {} + +test class-1.11 {check forward class declaration errors} -body { +#lang L --line=1 +class class_1_11a {} +class class_1_11a {} // error -- already declared +typedef int class_1_11_t; +class class_1_11_t; // error -- not a class type +} -returnCodes {error} -match regexp -result {.*2: L Error: redeclaration of class_1_11a +.*4: L Error: class_1_11_t not a class type +} + +test class-1.12 {check returns from class destructor} -body { +#lang L --line=1 +/* + * Check that an explicit return from with the class destructor does + * not bypass the code to delete the namespace instance. + */ +class class_1_12 { + destructor class_1_12_delete(class_1_12 self) + { + return; + } +} +void class_1_12_main() +{ + string parent; + class_1_12 obj; + + /* Creating a new object creates a new namespace under ::L. */ + obj = class_1_12_new(); + if (::catch("set parent [::namespace parent $obj]")) puts("bad 1"); + unless (parent eq "::L") puts("bad 2"); + + /* After this delete, the namepsace should be gone. */ + class_1_12_delete(obj); + unless (::catch("set parent [::namespace parent $obj]")) puts("bad 3"); +} +class_1_12_main(); +} -output {} + +test class-2.1 {check missing class constructor} -body { +#lang L --line=1 +class class_2_1 +{ + instance { + public int inst = 123; + } + destructor class_2_1_delete(class_2_1 self) + { + unless (inst == 123) puts("bad 1"); + } +} +void class_2_1_main() +{ + class_2_1 o = class_2_1_new(); + class_2_1_delete(o); +} +class_2_1_main(); +} -output {} + +test class-2.2 {check class missing destructor} -body { +#lang L --line=1 +class class_2_2 +{ + instance { + public int inst = 123; + } + constructor class_2_2_new() + { + unless (inst == 123) puts("bad 1"); + } +} +void class_2_2_main() +{ + class_2_2 o = class_2_2_new(); + class_2_2_delete(o); +} +class_2_2_main(); +} -output {} + +test class-2.2.1 {check class missing constructor and destructor} -body { +#lang L --line=1 +class class_2_2_1 +{ + instance { + public int inst = 123; + } + int class_2_2_1_get(class_2_2_1 self) { return inst; } +} +void class_2_2_1_main() +{ + class_2_2_1 o = class_2_2_1_new(); + unless (class_2_2_1_get(o) == 123) puts("bad 1"); + class_2_2_1_delete(o); +} +class_2_2_1_main(); +} -output {} + +test class-2.3 {check multiple class constructors and destructors} -body { +#lang L --line=1 +class class_2_3 +{ + public int n = 0; + instance { + public int inst = n + 100; + } + constructor class_2_3_new1() + { + ++n; + return (self); + } + constructor class_2_3_new2(int i) + { + n += i; + return (self); + } + destructor class_2_3_delete1(class_2_3 self) + { + --n; + } + destructor class_2_3_delete2(class_2_3 self, int i) + { + n -= i; + } +} +void class_2_3_main() +{ + class_2_3 o1, o2; + + o1 = class_2_3_new1(); + unless (class_2_3->n == 1) puts("bad 1.1"); + unless (o1->inst == 100) puts("bad 1.2"); + o2 = class_2_3_new2(10); + unless (class_2_3->n == 11) puts("bad 2.1"); + unless (o2->inst == 101) puts("bad 2.2"); + class_2_3_delete1(o2); + unless (class_2_3->n == 10) puts("bad 3.1"); + class_2_3_delete2(o1, 10); + unless (class_2_3->n == 0) puts("bad 4.1"); +} +class_2_3_main(); +} -output {} + +test class-2.5 {check missing self argument in class destructor 1} -body { +#lang L --line=1 +class class_2_5 +{ + constructor class_2_5_init() {} + destructor class_2_5_free() {} +} +} -returnCodes {error} -match regexp -result {.*4: L Error: class public member function lacks 'self' as first arg +} + +test class-2.6 {check missing self argument in class destructor 2} -body { +#lang L --line=1 -nowarn +class class_2_6 +{ + constructor class_2_6_init() {} + destructor class_2_6_free(string bad) {} +} +} -returnCodes {error} -match regexp -result {.*4: L Error: class public member function lacks 'self' as first arg +} + +test class-2.7 {check missing self argument in class destructor 3} -body { +#lang L --line=1 -nowarn +class class_2_7 +{ + constructor class_2_7_init() {} + destructor class_2_7_free(string bad, class_2_7 self) {} +} +} -returnCodes {error} -match regexp -result {.*4: L Error: class public member function lacks 'self' as first arg +} + +test class-2.8 {check missing self argument in public class member fn} -body { +#lang L --line=1 -nowarn +class class_2_8 +{ + constructor class_2_8_init() {} + destructor class_2_8_free(class_2_8 self) {} + void class_2_8_foo1() {} + void class_2_8_foo2(string bad) {} + void class_2_8_foo3(string bad, class_2_8 self) {} +} +} -returnCodes {error} -match regexp -result {.*5: L Error: class public member function lacks 'self' as first arg +.*6: L Error: class public member function lacks 'self' as first arg +.*7: L Error: class public member function lacks 'self' as first arg +} + +test class-2.9 {check use of self argument in class member fn} -body { +#lang L --line=1 +class class_2_9 +{ + constructor class_2_9_init() {} + destructor class_2_9_free(class_2_9 self) {} + void class_2_9_foo1(class_2_9 self) {} + void class_2_9_foo2(class_2_9 self, class_2_9 self) {} + void class_2_9_foo3(class_2_9 self, string self) {} +} +} -returnCodes {error} -match regexp -result {.*6: L Error: multiple declaration of local self +.*7: L Error: multiple declaration of local self +} + +test class-2.10 {check declaration of local named self in class} -body { +#lang L --line=1 +class class_2_10 +{ + constructor class_2_10_init() + { + int self; + } + destructor class_2_10_free(class_2_10 self) + { + class_2_10 self; + } + void class_2_10_foo(class_2_10 self) + { + int self; + } + private void class_2_10_priv() + { + int self; + } +} +} -returnCodes {error} -match regexp -result {.*5: L Error: multiple declaration.* +.*9: L Error: multiple declaration.* +.*13: L Error: multiple declaration.* +.*17: L Error: multiple declaration.* +} + +test class-2.11 {check return stmt in class destructor 1} -body { +#lang L --line=1 +class class_2_11 +{ + destructor class_2_11_delete(class_2_11 self) + { + return; // legal -- return type of void + } +} +void class_2_11_main() +{ + class_2_11 o = class_2_11_new(); + class_2_11_delete(o); +} +class_2_11_main(); +} -output {} + +test class-2.12 {check return stmt in class destructor 2} -body { +#lang L --line=1 +class class_2_12 +{ + destructor class_2_12_delete(class_2_12 self) + { + return ("bad"); // err -- return type is void + } +} +} -returnCodes {error} -match regexp -result {.*5: L Error: void function cannot return value +} + +test class-2.12.1 {check return stmt in class constructor 1} -body { +#lang L --line=1 +class class_2_12_1 +{ + instance { public int inst = 123; } + constructor class_2_12_1_new() + { + return (self); + } + int class_2_12_1_get(class_2_12_1 self) { return (inst); } +} +void class_2_12_1_main() +{ + class_2_12_1 o = class_2_12_1_new(); + unless (class_2_12_1_get(o) == 123) puts("bad 1"); + class_2_12_1_delete(o); +} +class_2_12_1_main(); +} -output {} + +test class-2.12.2 {check return stmt in class constructor 2} -body { +#lang L --line=1 +class class_2_12_2 +{ + constructor class_2_12_2_new() + { + return ("bad"); // err -- bad return type + } +} +} -returnCodes {error} -match regexp -result {.*5: L Error: incompatible return type +} + +test class-2.13 {check name clash with class constructor 1} -body { +#lang L --line=1 +class class_2_13 +{ + constructor class_2_13_new() {} + void class_2_13_new(class_2_13 self) {} // err + private void class_2_13_new(class_2_13 self) {} // err +} +} -returnCodes {error} -match regexp -result {.*3: L Error: does not match other declaration of class_2_13_new +.*5: L Error: function class_2_13_new already declared +} + +test class-2.14 {check name clash with class constructor 2} -body { +#lang L --line=1 +class class_2_14 +{ + void class_2_14_new(class_2_14 self) {} // err + private void class_2_14_new(class_2_14 self) {} // err +} +} -returnCodes {error} -match regexp -result {.*1: L Error: does not match other declaration of class_2_14_new +.*4: L Error: function class_2_14_new already declared +} + +test class-2.15 {check name clash with class destructor 1} -body { +#lang L --line=1 +class class_2_15 +{ + destructor class_2_15_delete(class_2_15 self) {} + void class_2_15_delete(class_2_15 self) {} // err + private void class_2_15_delete(class_2_15 self) {} // err +} +} -returnCodes {error} -match regexp -result {.*4: L Error: function class_2_15_delete already declared +.*5: L Error: function class_2_15_delete already declared +} + +test class-2.16 {check name clash with class destructor 2} -body { +#lang L --line=1 +class class_2_16 +{ + void class_2_16_delete(class_2_16 self) {} // err + private void class_2_16_delete(class_2_16 self) {} // err +} +} -returnCodes {error} -match regexp -result {.*3: L Error: function class_2_16_delete already declared +.*4: L Error: function class_2_16_delete already declared +} + +test class-2.17 {check illegal self parameter in class constructor 1} -body { +#lang L --line=1 +class class_2_17 +{ + constructor class_2_17_new(class_2_17 self) {} +} +} -returnCodes {error} -match regexp -result {.*3: L Error: 'self' parameter illegal in class constructor +} + +test class-2.18 {check illegal self parameter in class constructor 2} -body { +#lang L --line=1 -nowarn +class class_2_18 +{ + constructor class_2_18_new(int a, class_2_17 self) {} +} +} -returnCodes {error} -match regexp -result {.*3: L Error: 'self' parameter illegal in class constructor +} + +test class-2.20 {check class public member fn with arg without name} -body { +#lang L --line=1 -nowarn +class class_2_20 +{ + /* + * This is syntactically legal and the compiler should check + * for this error. + */ + public void class_2_20_foo(class_2_20) {} +} +} -returnCodes {error} -match regexp -result {.*7: L Error: class public member function lacks 'self' as first arg +} + +test class-2.21 {check class member function use before declare} -body { +#lang L --line=1 +class class_2_21 +{ + public int class_2_21_foo(class_2_21 self, int arg) + { + return (priv(arg) + class_2_21_pub(self, arg)); + } + private int priv(int arg) + { + return (arg); + } + public int class_2_21_pub(class_2_21 self, int arg) + { + return (-arg); + } +} +void class_2_21_main() +{ + class_2_21 o; + + o = class_2_21_new(); + unless (class_2_21_foo(o, 13) == 0) puts("bad 1"); +} +class_2_21_main(); +} -output {} + +test class-2.22 {check self in private member function} -body { +#lang L --line=1 +class class_2_22 { + constructor class_2_22_init() { + some_method(self); + } + private void some_method(class_2_22 self) {} + private void some_method2(int ok, class_2_22 self) {} +} +} -returnCodes {error} -match regexp -result {.*5: L Error: 'self' parameter illegal in private function +.*6: L Error: 'self' parameter illegal in private function +} + +test class-3.1 {check scoping of class vars and class instance vars 1} -body { +#lang L --line=1 +class class_3_1 +{ + /* + * Class variables and instance variables should both be at + * class scope, so a name clash should be an error. Note that + * because the instance var always get compiled first, we + * don't check for line #'s in the error messages. + */ + instance { + public int x; + } + public int x; + private int x; + public int x; + constructor class_3_1_init() {} + destructor class_3_1_free(class_3_1 self) {} +} +} -returnCodes {error} -match regexp -result {.*: L Error: multiple declaration of x +.*: L Error: multiple declaration of x +.*: L Error: multiple declaration of x +} + +test class-3.2 {check scoping of class vars and class instance vars 2} -body { +#lang L --line=1 +class class_3_2 +{ + /* + * Like the class_3_1 test but with multiple instance declarations. + * Note that because the instance var always get compiled + * first, we don't check for line #'s in the error messages. + */ + instance { + public int x; + private int x; + public int x; + } + public int x; + constructor class_3_2_init() {} + destructor class_3_2_free(class_3_2 self) {} +} +} -returnCodes {error} -match regexp -result {.*: L Error: multiple declaration of x +.*: L Error: multiple declaration of x +.*: L Error: multiple declaration of x +} + +test class-3.3 {check empty class instance variable section} -body { +#lang L --line=1 +class class_3_3 +{ + instance {} +} +} -result {} + +test class-3.3.1 {check completely empty class declaration} -body { +#lang L --line=1 +class class_3_3_1 {} +void class_3_3_1_main() +{ + class_3_3_1 o = class_3_3_1_new(); + class_3_3_1_delete(o); +} +class_3_3_1_main(); +} -output {} + +test class-3.4 {check scoping of class vars and class instance vars 4} -body { +#lang L --line=1 +class class_3_4 +{ + /* + * Like the class_3_3 test but with var decls in the reverse order. + * Note that because the instance var always get compiled first, + * we don't check for line #'s in the error messages. + */ + public int x; + private int x; + instance { + public int x; + private int x; + } + constructor class_3_4_init() {} + destructor class_3_4_free(class_3_4 self) {} +} +} -returnCodes {error} -match regexp -result {.*: L Error: multiple declaration of x +.*: L Error: multiple declaration of x +.*: L Error: multiple declaration of x +} + +test class-3.5 {check scoping of class vars and class instance vars 5} -body { +#lang L --line=1 +class class_3_5 +{ + /* + * Like the class_3_2 test but with private and public function + * declarations of the same name as the variables. Note that + * because the instance var always get compiled first, we + * don't check for all line #'s in the error messages. + */ + instance { + public int class_3_5_x; + public int class_3_5_x; // err -- multiply declared + } + public int class_3_5_x; // err -- multiply declared + public int class_3_5_x; // err -- multiply declared + private void class_3_5_x() {} // err -- already declared as a variable + void class_3_5_x() {} // err -- already declared as a variable + public void class_3_5_x() {} // err -- already declared as a variable + constructor class_3_5_init() {} + destructor class_3_5_free(class_3_5 self) {} +} +} -returnCodes {error} -match regexp -result {.*: L Error: multiple declaration of class_3_5_x +.*: L Error: multiple declaration of class_3_5_x +.*: L Error: multiple declaration of class_3_5_x +.*15: L Error: class_3_5_x already declared as a variable +.*16: L Error: class_3_5_x already declared as a variable +.*17: L Error: class_3_5_x already declared as a variable +} + +test class-3.6 {check scoping of class vars and class instance vars 6} -body { +#lang L --line=1 +class class_3_6 +{ + /* + * Like the class_3_5 test but with only a public function + * declaration of the same name as the variables. Note that + * because the instance var always get compiled first, we + * don't check for all line #'s in the error messages. + */ + instance { + public int class_3_6_x; + public int class_3_6_x; // err -- multiply declared + } + public int class_3_6_x; // err -- multiply declared + public int class_3_6_x; // err -- multiply declared + void class_3_6_x() {} // err -- already declared as a variable + constructor class_3_6_init() {} + destructor class_3_6_free(class_3_6 self) {} +} +} -returnCodes {error} -match regexp -result {.*: L Error: multiple declaration of class_3_6_x +.*: L Error: multiple declaration of class_3_6_x +.*: L Error: multiple declaration of class_3_6_x +.*15: L Error: class_3_6_x already declared as a variable +} + +test class-3.7 {check variable visibility in class member functions} -body { +#lang L --line=1 +/* + * Ensure class and instance variables are visible and work + * inside of all class member functions. + */ +class class_3_7 +{ + public string publ_cvar = "publ_cvar"; + private string priv_cvar = "priv_cvar"; + instance { + public string publ_ivar = "publ_ivar"; + private string priv_ivar = "priv_ivar"; + } + constructor class_3_7_init() + { + unless (publ_cvar eq "publ_cvar") puts("bad c1"); + unless (priv_cvar eq "priv_cvar") puts("bad c2"); + unless (publ_cvar eq "publ_cvar") puts("bad c3"); + unless (priv_ivar eq "priv_ivar") puts("bad c4"); + } + destructor class_3_7_free(class_3_7 self) + { + unless (publ_cvar eq "publ_cvar") puts("bad d1"); + unless (priv_cvar eq "priv_cvar") puts("bad d2"); + unless (publ_ivar eq "publ_ivar") puts("bad d3"); + unless (priv_ivar eq "priv_ivar") puts("bad d4"); + } + private void priv() + { + unless (publ_cvar eq "publ_cvar") puts("bad p1"); + unless (priv_cvar eq "priv_cvar") puts("bad p2"); + unless (publ_ivar eq "publ_ivar") puts("bad p3"); + unless (priv_ivar eq "priv_ivar") puts("bad p4"); + } + void class_3_7_foo(class_3_7 self) + { + unless (publ_cvar eq "publ_cvar") puts("bad f1"); + unless (priv_cvar eq "priv_cvar") puts("bad f2"); + unless (publ_ivar eq "publ_ivar") puts("bad f3"); + unless (priv_ivar eq "priv_ivar") puts("bad f4"); + priv(); + } +} +void class_3_7_main() +{ + class_3_7 o = class_3_7_init(); + class_3_7_foo(o); + class_3_7_free(o); +} +class_3_7_main(); +} -output {} + +test class-3.8 {check missing public/private qualifiers on class vars} -body { +#lang L --line=1 +class class_3_8 +{ + int bad1, bad2; + int bad3; + instance { + int ibad1, ibad2; + int ibad3; + } +} +} -returnCodes {error} -match regexp -result {.*3: L Error: class variable bad1 not declared public or private +.*3: L Error: class variable bad2 not declared public or private +.*4: L Error: class variable bad3 not declared public or private +.*6: L Error: class instance variable ibad1 not declared public or private +.*6: L Error: class instance variable ibad2 not declared public or private +.*7: L Error: class instance variable ibad3 not declared public or private +} + +test class-3.9 {check expressions in class and instance variable intializers} -body { +#lang L --line=1 +class class_3_9 +{ + /* + * These initializers check that the declarations get compiled + * top-to-bottom and left-to-right. + */ + private int c1 = 1; + private int c2 = c1 * 2, c3 = c2 + 3; + instance { + /* These get evaluated when the constructor runs. */ + private int i1 = c1; + private int i2 = c2 * 2, i3 = i2 + 3; + } + constructor class_3_9_new() + { + unless (c1 == 1) puts("bad c1"); + unless (c2 == (c1 * 2)) puts("bad c2"); + unless (c3 == (c2 + 3)) puts("bad c3"); + unless (i1 == c1) puts("bad c4"); + unless (i2 == (c2 * 2)) puts("bad c5"); + unless (i3 == (i2 + 3)) puts("bad c6"); + } +} +void class_3_9_main() +{ + class_3_9 o = class_3_9_new(); + class_3_9_delete(o); +} +class_3_9_main(); +} -output {} + +test class-3.10 {check dereferncing struct type name like a class name} -body { +#lang L --line=1 +/* + * This used to assert: declare a typedef for a struct and then + * use the struct name like a class name to dereference a class + * variable. + */ +typedef struct { + int x; +} class_3_10_var; +void class_3_10_main() +{ + class_3_10_var->x; +} +class_3_10_main(); +} -returnCodes {error} -match regexp -result {.*11: L Error: can dereference only class types +} + +test class-4.1 {check scoping of private names in classes} -body { +#lang L --line=1 +/* + * Check that per-class variables are defined in the class scope, + * meaning that two classes can have the same variable names and the + * same names as global variables. + */ +int class_4_1_global_var = 100; +int class_4_1_global_var2 = 101; +void class_4_1_global_func() {} +class class_4_1_1 +{ + public int class_4_1_global_var = 411; // OK -- shadows the global + instance { + public int class_4_1_global_var2 = 811; // also OK + } + + constructor class_4_1_1_init() {} + destructor class_4_1_1_free(class_4_1_1 self) {} + private int priv() { return (class_4_1_global_var); } + int class_4_1_1_get(class_4_1_1 self) + { + unless (class_4_1_global_var2 == 811) puts("bad c1"); + return (priv()); + } +} +class class_4_1_2 +{ + public int class_4_1_global_var = 412; // OK -- shadows the global + instance { + public int class_4_1_global_var2 = 812; // also OK + } + + constructor class_4_1_2_init() {} + destructor class_4_1_2_free(class_4_1_2 self) {} + private int priv() { return (class_4_1_global_var); } + int class_4_1_2_get(class_4_1_2 self) + { + unless (class_4_1_global_var2 == 812) puts("bad c2"); + return (priv()); + } +} +void class_4_1() +{ + class_4_1_1 o411 = class_4_1_1_init(); + class_4_1_2 o412 = class_4_1_2_init(); + + unless (class_4_1_global_var == 100) puts("bad 1"); + unless (class_4_1_1_get(o411) == 411) puts("bad 2"); + unless (class_4_1_2_get(o412) == 412) puts("bad 3"); + unless (class_4_1_global_var == 100) puts("bad 4"); +} +class_4_1(); +} -output {} + +test class-4.2 {check typedef and struct type scoping in classes 1} -body { +#lang L --line=1 +/* + * Check that typedef and struct names declared inside a class get + * defined at the global scope, not at the class scope. This test + * checks that a re-declaration of a global type name inside class + * scope is an error. + */ +typedef int class_4_2_type; +struct class_4_2_struct { + int i; + string s; +}; +class class_4_2 +{ + public class_4_2_type i; + public struct class_4_2_struct st; + + typedef string class_4_2_type; // err -- already defined + struct class_4_2_struct { // err -- already defined + int a[]; + }; + + constructor class_4_2_init() {} + destructor class_4_2_free(class_4_2_1 self) {} +} +} -returnCodes {error} -match regexp -result {.*17: L Error: Cannot redefine type class_4_2_type +.*19: L Error: multiple declaration of struct class_4_2_struct +} + +test class-4.3 {check typedef and struct type scoping in classes 2} -body { +#lang L --line=1 -nowarn +/* + * Check that typedef and struct names declared inside a class get + * defined at the global scope, not at the class scope. This test + * checks that a declaration of a global type name inside class scope + * is visible outside that scope. + */ +class class_4_3_1 +{ + typedef string class_4_3_type; + struct class_4_3_struct { + string s; + }; + + public class_4_3_type s = "431"; + public struct class_4_3_struct st = { "431" }; + + constructor class_4_3_1_init() + { + unless (s eq "431") puts("bad c1.1"); + unless (st.s eq "431") puts("bad c1.2"); + } + destructor class_4_3_1_free(class_4_3_1 self) {} +} + +class_4_3_type gs = "g43"; +struct class_4_3_struct gst = { "g43" }; + +class class_4_3_2 +{ + public class_4_3_type s = "432"; + public struct class_4_3_struct st = { "432" }; + + constructor class_4_3_2_init() + { + unless (s eq "432") puts("bad c2.1"); + unless (st.s eq "432") puts("bad c2.2"); + } + destructor class_4_3_2_free(class_4_3_2 self) {} +} +void class_4_3_main() +{ + class_4_3_1 o431 = class_4_3_1_init(); + class_4_3_2 o432 = class_4_3_2_init(); + + unless (gs eq "g43") puts("bad 1"); + unless (gst.s eq "g43") puts("bad 2"); +} +class_4_3_main(); +} -output {} + +test class-5.1 {check class object type checking} -body { +#lang L --line=1 -nowarn +class class_5_1_1 +{ + constructor class_5_1_1_init() {} + destructor class_5_1_1_free(class_5_1_1 self) {} + void class_5_1_1_foo(class_5_1_1 self, int a) {} +} +class class_5_1_2 +{ + constructor class_5_1_2_init() {} + destructor class_5_1_2_free(class_5_1_2 self) {} + void class_5_1_2_foo(class_5_1_2 self, int a) {} +} +void class_5_1() +{ + class_5_1_1 o511; + class_5_1_2 o512; + + /* These are all type errors (wrong class). */ + o511 = class_5_1_2_init(); + o512 = class_5_1_1_init(); + class_5_1_1_foo(o512, 0); + class_5_1_2_foo(o511, 0); + class_5_1_1_free(o512); + class_5_1_2_free(o511); +} +} -returnCodes {error} -match regexp -result {.*19: L Error: assignment of incompatible types +.*20: L Error: assignment of incompatible types +.*21: L Error: parameter 1 has incompatible type +.*22: L Error: parameter 1 has incompatible type +.*23: L Error: parameter 1 has incompatible type +.*24: L Error: parameter 1 has incompatible type +} + +test class-5.2 {check wrong object type in class member fn declarations} -body { +#lang L --line=1 +class class_5_2_1 +{ + constructor class_5_2_1_init() {} + destructor class_5_2_1_free(class_5_2_1 self) {} +} +class class_5_2_2 +{ + constructor class_5_2_2_init() {} + /* These have the wrong class as the arg type. */ + destructor class_5_2_2_free(class_5_2_1 self) {} + void class_5_2_2_foo(class_5_2_1 self) {} +} +} -returnCodes {error} -match regexp -result {.*10: L Error: 'self' parameter must be of class type +.*11: L Error: 'self' parameter must be of class type +} + +test class-5.3 {check that class member fn args get type checked 1} -body { +#lang L --line=1 -nowarn +/* + * This test checks that class member function arguments are + * type checked. There should be no type errors in this example. + */ +typedef string myhash{int}; +class class_5_3 { + constructor class_5_3_init(int a, string b, myhash c) {} + destructor class_5_3_free(class_5_3 self) {} + private void priv(myhash a, int b, int c) {} + string class_5_3_foo(class_5_3 self, string a, int b) { + myhash h; + priv(h, 3, 4); + return(a); + } +} +void class_5_3_main() +{ + myhash h; + class_5_3 o = class_5_3_init(1, "str", h); + unless (class_5_3_foo(o, "foo", 3) eq "foo") puts("bad 1"); +} +class_5_3_main(); +} -output {} + +test class-5.4 {check that class member fn args get type checked 2} -body { +#lang L --line=1 -nowarn +/* + * This test checks that class member function arguments are + * type checked. This example has type errors. + */ +typedef string myhash{int}; +class class_5_4 { + constructor class_5_4_init(int a, string b, myhash c) {} + destructor class_5_4_free(class_5_4 self) {} + private void priv(myhash a, int b, int c) {} + string class_5_4_foo(class_5_4 self, string a, int b) { + myhash h; + priv(3, h, 4); // args 1,2 backwards + return(b); // bad return type + } +} +void class_5_4_main() +{ + int i; + myhash h; + class_5_4 o = class_5_4_init(1, h, "str"); // args 2,3 backwards + + i = class_5_4_foo(o, 3, "foo"); // args 2,3 backwards +} +class_5_4_main(); +} -returnCodes {error} -match regexp -result {.*12: L Error: parameter 1 has incompatible type +.*12: L Error: parameter 2 has incompatible type +.*13: L Error: incompatible return type +.*20: L Error: parameter 2 has incompatible type +.*20: L Error: parameter 3 has incompatible type +.*22: L Error: parameter 2 has incompatible type +.*22: L Error: parameter 3 has incompatible type +.*22: L Error: assignment of incompatible types +} + +test class-6.1 {check class variable access from outside class} -body { +#lang L --line=1 +void class_6_1_str(string &s, string new) +{ + s = new; +} +void class_6_1_hash(string &h{int}, int k, string v) +{ + h{k} = v; +} +void class_6_1_arr(int &a[][], int i, int j, int v) +{ + a[i][j] = v; +} +class class_6_1 +{ + public string s = "cvar"; + public string h{int} = { 1=>"one", 2=>"two" }; + public string a[] = { "zero", "one", "two" }; + public int aa[][] = { {1,2}, {3,4} }; +} +void class_6_1_main() +{ + /* + * This test also checks the use of complex class variables + * as well as class variables as reference parameters. + */ + + unless (class_6_1->s eq "cvar") puts("bad 1.1"); + unless (class_6_1->h{1} eq "one") puts("bad 1.2"); + unless (class_6_1->h{2} eq "two") puts("bad 1.3"); + unless (class_6_1->a[0] eq "zero") puts("bad 1.4"); + unless (class_6_1->a[1] eq "one") puts("bad 1.5"); + unless (class_6_1->a[2] eq "two") puts("bad 1.6"); + unless (class_6_1->aa[0][0] == 1) puts("bad 1.10"); + unless (class_6_1->aa[0][1] == 2) puts("bad 1.11"); + unless (class_6_1->aa[1][0] == 3) puts("bad 1.12"); + unless (class_6_1->aa[1][1] == 4) puts("bad 1.13"); + + class_6_1->s = "new"; + unless (class_6_1->s eq "new") puts("bad 2.1"); + + class_6_1->h = { 3=>"three" }; + unless (class_6_1->h{3} eq "three") puts("bad 3.1"); + unless (length(class_6_1->h) == 1) puts("bad 3.2"); + + class_6_1->a = { "just-one" }; + unless (class_6_1->a[0] eq "just-one") puts("bad 4.1"); + unless (length(class_6_1->a) == 1) puts("bad 4.2"); + + class_6_1->aa = { {5} }; + unless (class_6_1->aa[0][0] == 5) puts("bad 5.1"); + unless (length(class_6_1->aa) == 1) puts("bad 5.2"); + unless (length(class_6_1->aa[0]) == 1) puts("bad 5.3"); + + class_6_1_str(&class_6_1->s, "new-s"); + unless (class_6_1->s eq "new-s") puts("bad 6.1"); + + class_6_1->h = {}; + class_6_1_hash(&class_6_1->h, 4, "four"); + unless (class_6_1->h{4} eq "four") puts("bad 7.1"); + unless (length(class_6_1->h) == 1) puts("bad 7.2"); + if (defined(class_6_1->h{5})) puts("bad 7.3"); + + class_6_1->aa = {}; + class_6_1_arr(&class_6_1->aa, 0, 0, 11); + class_6_1_arr(&class_6_1->aa, 0, 1, 12); + class_6_1_arr(&class_6_1->aa, 1, 0, 13); + class_6_1_arr(&class_6_1->aa, 1, 1, 14); + unless (class_6_1->aa[0][0] == 11) puts("bad 8.1"); + unless (class_6_1->aa[0][1] == 12) puts("bad 8.2"); + unless (class_6_1->aa[1][0] == 13) puts("bad 8.3"); + unless (class_6_1->aa[1][1] == 14) puts("bad 8.4"); + unless (length(class_6_1->aa) == 2) puts("bad 8.5"); + unless (length(class_6_1->aa[0]) == 2) puts("bad 8.6"); + unless (length(class_6_1->aa[1]) == 2) puts("bad 8.7"); + if (defined(class_6_1->aa[2])) puts("bad 8.8"); +} +class_6_1_main(); +} -output {} + +test class-6.2 {check class variable access errors from outside class} -body { +#lang L --line=1 -nowarn +class class_6_2 +{ + private string s = "cvar"; +} +void class_6_2_main() +{ + string bad = class_6_2->s; // error +} +} -returnCodes {error} -match regexp -result {.*7: L Error: s is not a public variable of class class_6_2 +} + +test class-6.3 {check class variable access from inside class} -body { +#lang L --line=1 +class class_6_3 +{ + public string cpubl = "publ-cvar"; + private string cpriv = "priv-cvar"; + constructor class_6_3_new() + { + unless (cpubl eq "publ-cvar") puts("bad c1"); + unless (cpriv eq "priv-cvar") puts("bad c2"); + unless (class_6_3->cpubl eq "publ-cvar") puts("bad c3"); + unless (class_6_3->cpriv eq "priv-cvar") puts("bad c4"); + } + public void class_6_3_foo(class_6_3 self) + { + unless (cpubl eq "publ-cvar") puts("bad foo.1"); + unless (cpriv eq "priv-cvar") puts("bad foo.2"); + unless (class_6_3->cpubl eq "publ-cvar") puts("bad foo.3"); + unless (class_6_3->cpriv eq "priv-cvar") puts("bad foo.4"); + } + destructor class_6_3_delete(class_6_3 self) + { + unless (cpubl eq "publ-cvar") puts("bad d1"); + unless (cpriv eq "priv-cvar") puts("bad d2"); + unless (class_6_3->cpubl eq "publ-cvar") puts("bad d3"); + unless (class_6_3->cpriv eq "priv-cvar") puts("bad d4"); + } +} +void class_6_3_main() +{ + class_6_3 o = class_6_3_new(); + class_6_3_foo(o); + class_6_3_delete(o); +} +class_6_3_main(); +} -output {} + +test class-6.4 {check erroneous class instance var access via class name} -body { +#lang L --line=1 +class class_6_4 +{ + instance { + public string ipubl; + private string ipriv; + } + constructor class_6_4_new() + { + string s; + s = class_6_4->ipubl; // err + s = class_6_4->ipriv; // err + } +} +void class_6_4_main() +{ + string s; + class_6_4 o = class_6_4_new(); + + s = class_6_4->ipubl; // err + s = class_6_4->ipriv; // err + + class_6_4_delete(o); +} +class_6_4_main(); +} -returnCodes {error} -match regexp -result {.*10: L Error: ipubl is not a class variable of class class_6_4 +.*11: L Error: ipriv is not a class variable of class class_6_4 +.*19: L Error: ipubl is not a class variable of class class_6_4 +.*20: L Error: ipriv is not a class variable of class class_6_4 +} + +test class-6.5 {check class instance var access from outside class} -body { +#lang L --line=1 +class class_6_5 +{ + instance { + public string ivar1; + public string ivar2; + } + constructor class_6_5_new(string s1, string s2) + { + ivar1 = s1; + ivar2 = s2; + } +} +void class_6_5_main() +{ + class_6_5 o1 = class_6_5_new("a", "b"); + class_6_5 o2 = class_6_5_new("c", "d"); + class_6_5 o3 = class_6_5_new("e", "f"); + + unless (o1->ivar1 eq "a") puts("bad 1"); + unless (o1->ivar2 eq "b") puts("bad 2"); + unless (o2->ivar1 eq "c") puts("bad 3"); + unless (o2->ivar2 eq "d") puts("bad 4"); + unless (o3->ivar1 eq "e") puts("bad 5"); + unless (o3->ivar2 eq "f") puts("bad 6"); + + class_6_5_delete(o1); + class_6_5_delete(o2); + class_6_5_delete(o3); +} +class_6_5_main(); +} -output {} + +test class-6.6 {check class instance var access errs from outside class} -body { +#lang L --line=1 +class class_6_6 +{ + instance { + private string ivar1; + public string ivar2; + } +} +void class_6_6_main() +{ + string s; + class_6_6 o = class_6_6_new(); + + s = o->ivar1; // err +} +} -returnCodes {error} -match regexp -result {.*13: L Error: ivar1 is not a public variable of class class_6_6 +} + +test class-6.7 {check class instance var access from inside class} -body { +#lang L --line=1 +class class_6_7 +{ + instance { + public string ivar1; + public string ivar2; + } + constructor class_6_7_new(string s1, string s2) + { + ivar1 = s1; + ivar2 = s2; + } + public void class_6_7_chk(class_6_7 self, string s1, string s2) + { + unless (ivar1 eq s1) puts("bad chk.1"); + unless (ivar2 eq s2) puts("bad chk.2"); + unless (self->ivar1 eq s1) puts("bad chk.3"); + unless (self->ivar2 eq s2) puts("bad chk.4"); + } + private void chkother(class_6_7 other, string s1, string s2) + { + unless (other->ivar1 eq s1) puts("bad priv.chkother.1"); + unless (other->ivar2 eq s2) puts("bad priv.chkother.2"); + } + public void class_6_7_chkother(class_6_7 self, class_6_7 other, + string s1, string s2) + { + unless (other->ivar1 eq s1) puts("bad chkother.1"); + unless (other->ivar2 eq s2) puts("bad chkother.2"); + chkother(other, s1, s2); + } +} +void class_6_7_main() +{ + class_6_7 o1 = class_6_7_new("a", "b"); + class_6_7 o2 = class_6_7_new("c", "d"); + class_6_7 o3 = class_6_7_new("e", "f"); + + class_6_7_chk(o1, "a", "b"); + class_6_7_chk(o2, "c", "d"); + class_6_7_chk(o3, "e", "f"); + + class_6_7_chkother(o2, o1, "a", "b"); + class_6_7_chkother(o1, o2, "c", "d"); + class_6_7_chkother(o1, o3, "e", "f"); + + class_6_7_delete(o1); + class_6_7_delete(o2); + class_6_7_delete(o3); +} +class_6_7_main(); +} -output {} + +test class-6.8 {check class variable access errors} -body { +#lang L --line=1 +class class_6_8 +{ + public string cpubl; + private string cpriv; +} +void class_6_8_main() +{ + string s; + class_6_8 o = class_6_8_new(); + + s = o->cpubl; // err + s = o->cpriv; // err +} +} -returnCodes {error} -match regexp -result {.*11: L Error: cpubl is not an instance variable of class class_6_8 +.*12: L Error: cpriv is not an instance variable of class class_6_8 +} + +test class-7.1 {check object erroneously declared with same name as class} -body { +#lang L --line=1 -nowarn +class class_7_1 {} +void class_7_1_main() +{ + class_7_1 class_7_1; // err +} +} -returnCodes {error} -match regexp -result {.*4: L Error: cannot declare object with same name as class +} + +test class-8.1 {check class variables as l-values} -body { +#lang L --line=1 +class class_8_1 +{ + public string s; + public int i; + + public void class_8_1_chk(class_8_1 self) + { + class_8_1->s = "abcd"; + unless (class_8_1->s eq "abcd") puts("bad c1.1"); + + class_8_1->s[0] = "xyz"; + unless (class_8_1->s eq "xyzbcd") puts("bad c1.2"); + + class_8_1->s[END+1] = "pdq"; + unless (class_8_1->s eq "xyzbcdpdq") puts("bad c1.3"); + + unless (class_8_1->s =~ /bcd/) puts("bad c1.4"); + + class_8_1->s =~ s/bcd/dcb/; + unless (class_8_1->s eq "xyzdcbpdq") puts("bad c1.5"); + + class_8_1->s[0] =~ s/x/0/; + unless (class_8_1->s eq "0yzdcbpdq") puts("bad c1.6"); + + class_8_1->i = 2; + unless (class_8_1->i == 2) puts("bad c2.1"); + + class_8_1->i += 2; + unless (class_8_1->i == 4) puts("bad c2.2"); + + class_8_1->i += class_8_1->i; + unless (class_8_1->i == 8) puts("bad c2.3"); + } +} +void class_8_1_main() +{ + class_8_1 o = class_8_1_new(); + + class_8_1_chk(o); + + class_8_1->s = "abcd"; + unless (class_8_1->s eq "abcd") puts("bad 1.1"); + + class_8_1->s[0] = "xyz"; + unless (class_8_1->s eq "xyzbcd") puts("bad 1.2"); + + class_8_1->s[END+1] = "pdq"; + unless (class_8_1->s eq "xyzbcdpdq") puts("bad 1.3"); + + unless (class_8_1->s =~ /bcd/) puts("bad 1.4"); + + class_8_1->s =~ s/bcd/dcb/; + unless (class_8_1->s eq "xyzdcbpdq") puts("bad 1.5"); + + class_8_1->s[0] =~ s/x/0/; + unless (class_8_1->s eq "0yzdcbpdq") puts("bad 1.6"); + + class_8_1->i = 2; + unless (class_8_1->i == 2) puts("bad 2.1"); + + class_8_1->i += 2; + unless (class_8_1->i == 4) puts("bad 2.2"); + + class_8_1->i += class_8_1->i; + unless (class_8_1->i == 8) puts("bad 2.3"); + + class_8_1_chk(o); +} +class_8_1_main(); +} -output {} + +test class-8.1.5 {check class and class instance variables used in nested scopes} -body { +#lang L --line=1 +class class_8_1_5 +{ + private int n = 0; + public int cnum = -1; + instance { public int num = n++; } + constructor class_8_1_5_new() { ++cnum; } +} +void class_8_1_5_main() +{ + /* + * This test checks that the compiler-generated temps used for + * accessing class and instance variables are allocated + * properly in the presence of nested scopes. There was a + * prior compiler bug where duplicate temps could be created. + */ + + int i, j; + int n = 10; + class_8_1_5 o1, o2, o3, o4, o[]; + + o1 = class_8_1_5_new(); + unless ((o1->num == 0) && (class_8_1_5->cnum == 0)) puts("bad 1"); + o2 = class_8_1_5_new(); + unless ((o2->num == 1) && (class_8_1_5->cnum == 1)) puts("bad 2"); + + for (i = 0; i < n; ++i) { + o[i] = class_8_1_5_new(); + unless (o[i]->num == (i+2)) puts("bad 3.1"); + unless (class_8_1_5->cnum == (i+2)) puts("bad 3.2"); + for (j = 0; j < i; ++j) { + unless (o[j]->num == (j+2)) puts("bad 4.1"); + } + } + for (i = 0; i < n; ++i) { + unless (o[i]->num == (i+2)) puts("bad 5.1"); + } + o3 = class_8_1_5_new(); + unless (o3->num == (n+2)) puts("bad 6.1"); + unless (class_8_1_5->cnum == (n+2)) puts("bad 6.2"); + o4 = class_8_1_5_new(); + unless (o4->num == (n+3)) puts("bad 7.1"); + unless (class_8_1_5->cnum == (n+3)) puts("bad 7.2"); +} +class_8_1_5_main(); +} -output {} + +test class-8.2 {check class instance variables as l-values} -body { +#lang L --line=1 +class class_8_2 +{ + instance { + public string s; + public int i; + } + constructor class_8_2_new() + { + self->s = "abcd"; + unless (self->s eq "abcd") puts("bad 1.1"); + + self->s[0] = "xyz"; + unless (self->s eq "xyzbcd") puts("bad 1.2"); + + self->s[END+1] = "pdq"; + unless (self->s eq "xyzbcdpdq") puts("bad 1.3"); + + unless (self->s =~ /bcd/) puts("bad 1.4"); + + self->s =~ s/bcd/dcb/; + unless (self->s eq "xyzdcbpdq") puts("bad 1.5"); + + self->s[0] =~ s/x/0/; + unless (self->s eq "0yzdcbpdq") puts("bad 1.6"); + + self->i = 2; + unless (self->i == 2) puts("bad 2.1"); + + self->i += 2; + unless (self->i == 4) puts("bad 2.2"); + + self->i += self->i; + unless (self->i == 8) puts("bad 2.3"); + } + public void class_8_2_chk(class_8_2 self, class_8_2 other) + { + other->s = "abcd"; + unless (other->s eq "abcd") puts("bad 1.1"); + + other->s[0] = "xyz"; + unless (other->s eq "xyzbcd") puts("bad 1.2"); + + other->s[END+1] = "pdq"; + unless (other->s eq "xyzbcdpdq") puts("bad 1.3"); + + unless (other->s =~ /bcd/) puts("bad 1.4"); + + other->s =~ s/bcd/dcb/; + unless (other->s eq "xyzdcbpdq") puts("bad 1.5"); + + other->s[0] =~ s/x/0/; + unless (other->s eq "0yzdcbpdq") puts("bad 1.6"); + + other->i = 2; + unless (other->i == 2) puts("bad 2.1"); + + other->i += 2; + unless (other->i == 4) puts("bad 2.2"); + + other->i += other->i; + unless (other->i == 8) puts("bad 2.3"); + } +} +void class_8_2_main() +{ + class_8_2 o = class_8_2_new(); + + class_8_2_chk(o, o); + + o->s = "abcd"; + unless (o->s eq "abcd") puts("bad 1.1"); + + o->s[0] = "xyz"; + unless (o->s eq "xyzbcd") puts("bad 1.2"); + + o->s[END+1] = "pdq"; + unless (o->s eq "xyzbcdpdq") puts("bad 1.3"); + + unless (o->s =~ /bcd/) puts("bad 1.4"); + + o->s =~ s/bcd/dcb/; + unless (o->s eq "xyzdcbpdq") puts("bad 1.5"); + + o->s[0] =~ s/x/0/; + unless (o->s eq "0yzdcbpdq") puts("bad 1.6"); + + o->i = 2; + unless (o->i == 2) puts("bad 2.1"); + + o->i += 2; + unless (o->i == 4) puts("bad 2.2"); + + o->i += o->i; + unless (o->i == 8) puts("bad 2.3"); +} +class_8_2_main(); +} -output {} + +test class-8.3 {check class instance variables as reference parameters} -body { +#lang L --line=1 +void class_8_3_str(string &s, string new) +{ + s = new; +} +void class_8_3_hash(string &h{int}, int k, string v) +{ + h{k} = v; +} +void class_8_3_arr(int &a[][], int i, int j, int v) +{ + a[i][j] = v; +} +class class_8_3 +{ + instance { + public string s = "cvar"; + public string h{int} = { 1=>"one", 2=>"two" }; + public string a[] = { "zero", "one", "two" }; + public int aa[][] = { {1,2}, {3,4} }; + } +} +void class_8_3_main() +{ + /* + * Note that test class-6.1 checked class variables as + * reference parameters. This test is basically that test but + * it checks instance variables instead. + */ + + class_8_3 o = class_8_3_new(); + + unless (o->s eq "cvar") puts("bad 1.1"); + unless (o->h{1} eq "one") puts("bad 1.2"); + unless (o->h{2} eq "two") puts("bad 1.3"); + unless (o->a[0] eq "zero") puts("bad 1.4"); + unless (o->a[1] eq "one") puts("bad 1.5"); + unless (o->a[2] eq "two") puts("bad 1.6"); + unless (o->aa[0][0] == 1) puts("bad 1.10"); + unless (o->aa[0][1] == 2) puts("bad 1.11"); + unless (o->aa[1][0] == 3) puts("bad 1.12"); + unless (o->aa[1][1] == 4) puts("bad 1.13"); + + o->s = "new"; + unless (o->s eq "new") puts("bad 2.1"); + + o->h = { 3=>"three" }; + unless (o->h{3} eq "three") puts("bad 3.1"); + unless (length(o->h) == 1) puts("bad 3.2"); + + o->a = { "just-one" }; + unless (o->a[0] eq "just-one") puts("bad 4.1"); + unless (length(o->a) == 1) puts("bad 4.2"); + + o->aa = { {5} }; + unless (o->aa[0][0] == 5) puts("bad 5.1"); + unless (length(o->aa) == 1) puts("bad 5.2"); + unless (length(o->aa[0]) == 1) puts("bad 5.3"); + + class_8_3_str(&o->s, "new-s"); + unless (o->s eq "new-s") puts("bad 6.1"); + + o->h = {}; + class_8_3_hash(&o->h, 4, "four"); + unless (o->h{4} eq "four") puts("bad 7.1"); + unless (length(o->h) == 1) puts("bad 7.2"); + if (defined(o->h{5})) puts("bad 7.3"); + + o->aa = {}; + class_8_3_arr(&o->aa, 0, 0, 11); + class_8_3_arr(&o->aa, 0, 1, 12); + class_8_3_arr(&o->aa, 1, 0, 13); + class_8_3_arr(&o->aa, 1, 1, 14); + unless (o->aa[0][0] == 11) puts("bad 8.1"); + unless (o->aa[0][1] == 12) puts("bad 8.2"); + unless (o->aa[1][0] == 13) puts("bad 8.3"); + unless (o->aa[1][1] == 14) puts("bad 8.4"); + unless (length(o->aa) == 2) puts("bad 8.5"); + unless (length(o->aa[0]) == 2) puts("bad 8.6"); + unless (length(o->aa[1]) == 2) puts("bad 8.7"); + if (defined(o->aa[2])) puts("bad 8.8"); +} +class_8_3_main(); +} -output {} + +test class-8.4 {check objects in complex variables} -body { +#lang L --line=1 +class class_8_4_1 +{ + instance { + public class_8_4_1 o; + public string s; + } +} +class class_8_4_2 +{ + instance { + public class_8_4_1 o; + public string s; + } +} +void class_8_4_foo(class_8_4_1 &o, string s) +{ + o->s = s; +} +void class_8_4_str(string &s1, string s2) +{ + s1 = s2; +} +void class_8_4_main() +{ + class_8_4_1 a[] = { class_8_4_1_new(), class_8_4_1_new() }; + class_8_4_1 o841 = class_8_4_1_new(); + class_8_4_2 o842 = class_8_4_2_new(); + + o841->s = "841"; + o842->s = "842"; + unless ((o841->s eq "841") && (o842->s eq "842")) puts("bad 1.1"); + + o841->o = class_8_4_1_new(); + o841->o->s = "841 in 841"; + unless (o841->o->s eq "841 in 841") puts("bad 2.1"); + + o842->o = class_8_4_1_new(); + o842->o->s = "841 in 842"; + unless (o842->o->s eq "841 in 842") puts("bad 3.1"); + + o842->o->o = class_8_4_1_new(); + o842->o->o->s = "841 in 841 in 842"; + unless (o842->o->o->s eq "841 in 841 in 842") puts("bad 4.1"); + + class_8_4_foo(&o842->o->o, "new"); + unless (o842->o->o->s eq "new") puts("bad 5.1"); + + class_8_4_1_delete(o841->o); + class_8_4_1_delete(o841); + class_8_4_1_delete(o842->o->o); + class_8_4_1_delete(o842->o); + class_8_4_2_delete(o842); + + unless (length(a) == 2) puts("bad 10.0"); + a[0]->s = "0-841"; + a[1]->s = "1-841"; + unless (a[0]->s eq "0-841") puts("bad 10.1"); + unless (a[1]->s eq "1-841") puts("bad 10.2"); + a[0]->o = class_8_4_1_new(); + a[0]->o->s = "0-841 in 841"; + unless (a[0]->o->s eq "0-841 in 841") puts("bad 10.3"); + class_8_4_foo(&a[0]->o, "new"); + unless (a[0]->o->s eq "new") puts("bad 10.4"); + class_8_4_str(&a[0]->o->s, "new2"); + unless (a[0]->o->s eq "new2") puts("bad 10.5"); +} +class_8_4_main(); +} -output {} + +test class-8.5 {check objects as reference parameters} -body { +#lang L --line=1 +class class_8_5 +{ + private int n = 0; + instance { public int num = n++; } +} +void class_8_5_create_1(class_8_5 &o) +{ + o = class_8_5_new(); +} +void class_8_5_create_n(class_8_5 &o[], int n) +{ + int i; + + for (i = 0; i < n; ++i) o[i] = class_8_5_new(); +} +void class_8_5_check_n(class_8_5 o[], class_8_5 &oref[], int n) +{ + int i; + + for (i = 0; i < n; ++i) { + unless (o[i]->num == (i+2)) puts("bad chk.1"); + unless (oref[i]->num == (i+2)) puts("bad chk.2"); + } +} +void class_8_5_main() +{ + int n = 10; + class_8_5 o1, o2; + class_8_5 o[]; + + class_8_5_create_1(&o1); + class_8_5_create_1(&o2); + unless (o1->num == 0) puts("bad 1"); + unless (o2->num == 1) puts("bad 2"); + class_8_5_delete(o1); + class_8_5_delete(o2); + + class_8_5_create_n(&o, n); + class_8_5_check_n( o, &o, n); +} +class_8_5_main(); +} -output {} + +test class-9.1 {check class and instance variables in comma expression} -body { +#lang L --line=1 +class class_9_1 +{ + public string cvar = "cvar"; + instance { + public string ivar = "ivar"; + } +} +void class_9_1_main() +{ + /* + * This checks an obscure case to ensure that a class or + * instance variable whose value is discarded -- the first + * expression in a comma expression -- is compiled properly. + * These are run in a loop as a way to check that the + * run-time stack remains balanced. + */ + + int i; + int n = 100; + class_9_1 o = class_9_1_new(); + + for (i = 0; i < n; ++i) { + unless (class_9_1->cvar,"val" eq "val") puts("bad 1.1"); + unless (o->ivar,"val" eq "val") puts("bad 1.2"); + } +} +class_9_1_main(); +} -output {} + +test goto-1 {check goto statement} -body { +#lang L --line=1 +/* + * Test gotos at global scope. None of these labels should clash with + * those in goto_1a() or goto_1b() below. + */ + goto L1; + puts("bad"); + L1: puts("L1"); + goto L2; + +/* Now test at proc scope. */ +void goto_1a() +{ + int i; + + /* Use before define. */ + goto L1; + puts("bad 1"); + L1: puts("L1"); + + /* Use after define. */ + i = 0; + L2: if (++i == 2) goto L3; + puts("L2"); + goto L2; + L3: puts("L3"); + + /* Multiple uses before define. */ + for (i = 0; i < 4; ++i) { + if (i == 0) goto L4; + if (i == 1) goto L4; + if (i == 2) goto L4; + if (i == 3) goto L4; + continue; + L4: puts("L4"); + } + + /* Multiple uses after define. */ + for (i = 0; i < 4; ++i) { + goto L6; + puts("bad"); + L5: puts("L5"); + continue; + L6: if (i == 0) goto L5; + if (i == 1) goto L5; + if (i == 2) goto L5; + if (i == 3) goto L5; + } + + /* Multiple labels per statement. */ + for (i = 0; i < 4; ++i) { + if (i == 0) goto L7; + if (i == 1) goto L8; + if (i == 2) goto L9; + if (i == 3) goto L10; + continue; + L7: + L8: + L9: + L10: + puts("L7-10"); + } + + /* Label without statement. */ + do { + goto L11; + puts("bad"); + L11: + } while(0); + + /* Multiple labels without statement. */ + for (i = 0; i < 4; ++i) { + if (i == 0) goto L12; + if (i == 1) goto L13; + if (i == 2) goto L14; + puts("i == 3"); + L12: + L13: + L14: + } while(0); + + /* + * Label on a single statement (bizarre perhaps, but allowed + * by the grammar). + */ + + goto L15; + puts("bad"); + while (0) L15: puts("L15"); + + goto L16; + puts("bad"); + do L16: puts("L16"); while(0); + + goto L17; + puts("bad"); + for (; 0; ) L17: puts("L17"); + + goto L18; + puts("bad"); + for (; 0; 0) L18: puts("L18"); + + /* Labels in nested scopes. */ + + i = 0; + goto L19; + puts("bad"); + do { + puts("bad"); + L19: puts("L19"); + } while (0); + if (i++ == 0) goto L19; + + i = 0; + goto L20; + puts("bad"); + do { + puts("bad"); + do { + puts("bad"); + L20: puts("L20"); + } + while (0); + } while (0); + if (i++ == 0) goto L20; + + do { + goto L21; // jump out of the scope + puts("bad"); + } while (0); + L21: puts("L21"); +} +void goto_1b() +{ + /* + * Goto labels should be per proc scope, so none of these labels + * should clash with those in goto_1a(). + */ + + goto L1; + puts("bad"); + L1: puts("L1"); +} +L2: +goto_1a(); +goto_1b(); +} -output {L1 +L1 +L2 +L3 +L4 +L4 +L4 +L4 +L5 +L5 +L5 +L5 +L7-10 +L7-10 +L7-10 +L7-10 +i == 3 +L15 +L16 +L17 +L18 +L19 +L19 +L20 +L20 +L21 +L1 +} + +test goto-2 {check gotos with labels in enclosing scopes} -body { +#lang L --line=1 +goto L1; +L2: puts("global L2"); +return; +void goto_2() +{ + goto L2; // should go to goto_2()'s L2, NOT the L2 at global scope + puts("bad"); + L2: puts("L2"); +} +L1: +goto_2(); +goto L2; // should go to the L2 at global scope, NOT goto_2()'s L2 +} -output {L2 +global L2 +} + +test goto-3 {check goto statement errors} -body { +#lang L --line=1 +void goto_3() +{ + goto L1; + L1: + L1: + L2: + L2: + L2: + + L3: + do { + L3: + } while (0); + + goto L4; + goto L6; // error even though an L6 is defined at global scope +} +goto L5; +L6: +} -returnCodes error -match regexp -result {.*: L Error: label L1 already defined +.*: L Error: label L2 already defined +.*: L Error: label L3 already defined +.*: L Error: label L4 referenced but not defined +.*: L Error: label L6 referenced but not defined +.*: L Error: label L5 referenced but not defined +} + +test goto-4 {check goto with label on first statement in the scope} -body { +#lang L --line=1 +void goto_4() +{ + int i = 0; + + /* + * This is a regression test for a parser bug where a labeled + * stmt that was first in the stmt list wasn't being reversed, + * causing the label to get the wrong offset. With that bug + * this test would find i == 1. + */ + if (1) { + L: unless (i++) goto L; + } + unless (i == 2) puts("bad"); +} +goto_4(); +} -output {} + +test fntrace-1 {check function tracing, pragma syntax} -body { +#lang L --line=1 +// These are all legal syntax. +#pragma fntrace=on +unless (__LINE__ == 3) puts("bad 1"); +#pragma fntrace=on, fnhook=myhook +unless (__LINE__ == 5) puts("bad 2"); +#pragma fntrace=on, fnhook=def +unless (__LINE__ == 7) puts("bad 3"); +#pragma fntrace=off +unless (__LINE__ == 9) puts("bad 4"); +#pragma fntrace=off, fnhook=myhook +unless (__LINE__ == 11) puts("bad 5"); +#pragma fntrace=off, fnhook=def +unless (__LINE__ == 13) puts("bad 6"); +#pragma fntrace +} -output {} + +test fntrace-2 {check function trace, default hooks} -body { +#lang L --line=1 -nowarn +#pragma fntrace=on +string fntrace_2_3(string a1, string a2) +{ + fprintf(stderr, "in fntrace_2_3\n"); + return ("this is the ret value"); +} +void fntrace_2_2(string a1) +{ + fprintf(stderr, "in fntrace_2_2 before\n"); + fntrace_2_3(a1, "arg2"); + fprintf(stderr, "in fntrace_2_2 after\n"); +} +void fntrace_2_1() +{ + fprintf(stderr, "in fntrace_2_1 before\n"); + fntrace_2_2("arg1"); + fprintf(stderr, "in fntrace_2_1 after\n"); +} +void fntrace_2() +{ + fprintf(stderr, "in fntrace_2 before\n"); + fntrace_2_1(); + fprintf(stderr, "in fntrace_2 after\n"); +} +fntrace_2(); +} -match regexp -errorOutput {\d+: enter fntrace_2 +in fntrace_2 before +\d+: enter fntrace_2_1 +in fntrace_2_1 before +\d+: enter fntrace_2_2 'arg1' +in fntrace_2_2 before +\d+: enter fntrace_2_3 'arg1' 'arg2' +in fntrace_2_3 +\d+: exit fntrace_2_3 'arg1' 'arg2' ret 'this is the ret value' +in fntrace_2_2 after +\d+: exit fntrace_2_2 'arg1' ret '' +in fntrace_2_1 after +\d+: exit fntrace_2_1 ret '' +in fntrace_2 after +\d+: exit fntrace_2 ret '' +} + +test fntrace-3.1 {check function trace, private user hook fn} -body { +#lang L --line=1 -nowarn +#pragma fntrace=on, fnhook=fn31_myhook +private void fn31_myhook(int pre, string av[], string ret) +{ + int i; + int ac = length(av); + + printf("myhook %s: %s %d args:", pre?"pre":"post", av[0], ac-1); + for (i = 1; i < ac; ++i) { + printf(" '%s'", av[i]); + } + unless (pre) printf(" ret: '%s'", ret); + printf("\n"); +} +string fntrace_3_1_3(string a1, string a2) +{ + printf("in fntrace_3_1_3\n"); + return ("this is the ret value"); +} +void fntrace_3_1_2(string a1) +{ + printf("in fntrace_3_1_2 before\n"); + fntrace_3_1_3(a1, "arg2"); + printf("in fntrace_3_1_2 after\n"); +} +void fntrace_3_1_1() +{ + printf("in fntrace_3_1_1 before\n"); + fntrace_3_1_2("arg1"); + printf("in fntrace_3_1_1 after\n"); +} +void fntrace_3_1() +{ + printf("in fntrace_3_1 before\n"); + fntrace_3_1_1(); + printf("in fntrace_3_1 after\n"); +} +fntrace_3_1(); +#pragma fnhook=def +} -output {myhook pre: fntrace_3_1 0 args: +in fntrace_3_1 before +myhook pre: fntrace_3_1_1 0 args: +in fntrace_3_1_1 before +myhook pre: fntrace_3_1_2 1 args: 'arg1' +in fntrace_3_1_2 before +myhook pre: fntrace_3_1_3 2 args: 'arg1' 'arg2' +in fntrace_3_1_3 +myhook post: fntrace_3_1_3 2 args: 'arg1' 'arg2' ret: 'this is the ret value' +in fntrace_3_1_2 after +myhook post: fntrace_3_1_2 1 args: 'arg1' ret: '' +in fntrace_3_1_1 after +myhook post: fntrace_3_1_1 0 args: ret: '' +in fntrace_3_1 after +myhook post: fntrace_3_1 0 args: ret: '' +} + +test fntrace-3.2 {check function trace, public user hook fn} -body { +#lang L --line=1 -nowarn +#pragma fntrace=on, fnhook=fntr32_myhook +void fntr32_myhook(int pre, string av[], string ret) +{ + int i; + int ac = length(av); + + printf("myhook %s: %s %d args:", pre?"pre":"post", av[0], ac-1); + for (i = 1; i < ac; ++i) { + printf(" '%s'", av[i]); + } + unless (pre) printf(" ret: '%s'", ret); + printf("\n"); +} +string fntrace_3_2_3(string a1, string a2) +{ + printf("in fntrace_3_2_3\n"); + return ("this is the ret value"); +} +void fntrace_3_2_2(string a1) +{ + printf("in fntrace_3_2_2 before\n"); + fntrace_3_2_3(a1, "arg2"); + printf("in fntrace_3_2_2 after\n"); +} +void fntrace_3_2_1() +{ + printf("in fntrace_3_2_1 before\n"); + fntrace_3_2_2("arg1"); + printf("in fntrace_3_2_1 after\n"); +} +void fntrace_3_2() +{ + printf("in fntrace_3_2 before\n"); + fntrace_3_2_1(); + printf("in fntrace_3_2 after\n"); +} +fntrace_3_2(); +#pragma fnhook=def +} -output {myhook pre: fntrace_3_2 0 args: +in fntrace_3_2 before +myhook pre: fntrace_3_2_1 0 args: +in fntrace_3_2_1 before +myhook pre: fntrace_3_2_2 1 args: 'arg1' +in fntrace_3_2_2 before +myhook pre: fntrace_3_2_3 2 args: 'arg1' 'arg2' +in fntrace_3_2_3 +myhook post: fntrace_3_2_3 2 args: 'arg1' 'arg2' ret: 'this is the ret value' +in fntrace_3_2_2 after +myhook post: fntrace_3_2_2 1 args: 'arg1' ret: '' +in fntrace_3_2_1 after +myhook post: fntrace_3_2_1 0 args: ret: '' +in fntrace_3_2 after +myhook post: fntrace_3_2 0 args: ret: '' +} + +test fntrace-4 {check pragma errors} -body { +#lang L --line=1 +#pragma unknown1=on +#pragma unknown2 +} -returnCodes error -match regexp -result {.*1: L Error: illegal attribute 'unknown1' +.*2: L Error: illegal attribute 'unknown2' +} + +test fntrace-5 {check switching hooks and enabling/disabling fntrace} -body { +#lang L --line=1 +#pragma fntrace=off +void myhook5(int pre, string av[], string ret) +{ + int i; + int ac = length(av); + + fprintf(stderr, "5: %s: %s %d args:", pre?"pre":"post", av[0], ac-1); + for (i = 1; i < ac; ++i) { + fprintf(stderr, " '%s'", av[i]); + } + unless (pre) fprintf(stderr, " ret: '%s'", ret); + fprintf(stderr, "\n"); +} +#pragma fntrace=on, fnhook=def +// default trace hooks in effect now +void fntrace_5_def() +{ + fprintf(stderr, "in fntrace_5_def\n"); +} +#pragma fntrace=on, fnhook=myhook5 +// myhook in effect now +void fntrace_5_myhook() +{ + fprintf(stderr, "in fntrace_5_myhook before\n"); + fntrace_5_def(); + fprintf(stderr, "in fntrace_5_myhook after\n"); +} +#pragma fntrace=off +// function tracing disabled now +void fntrace_5_off() +{ + fprintf(stderr, "in fntrace_5_off before\n"); + fntrace_5_myhook(); + fprintf(stderr, "in fntrace_5_off after\n"); +} +#pragma fntrace=on, fnhook=def +// back to default hooks +void fntrace_5() +{ + fprintf(stderr, "in fntrace_5 before\n"); + fntrace_5_off(); + fprintf(stderr, "in fntrace_5 after\n"); +} +fntrace_5(); +} -match regexp -errorOutput {\d+: enter fntrace_5 +in fntrace_5 before +in fntrace_5_off before +5: pre: fntrace_5_myhook 0 args: +in fntrace_5_myhook before +\d+: enter fntrace_5_def +in fntrace_5_def +\d+: exit fntrace_5_def ret '' +in fntrace_5_myhook after +5: post: fntrace_5_myhook 0 args: ret: '' +in fntrace_5_off after +in fntrace_5 after +\d+: exit fntrace_5 ret '' +} + +test fntrace-6 {check that tracing does not munge function return value} -body { +#lang L --line=1 +#pragma fntrace=on +private int myfunc(int a) +{ + return (a + 2); +} +void fntrace_6() +{ + unless (myfunc(2) == 4) puts("bad 1"); +} +fntrace_6(); +} -output {} + +test fntrace-7 {test function tracing in classes} -body { +#lang L --line=1 +#pragma fntrace=off +class fntrace_7_cls +{ +#pragma fntrace=on + private void traced() { fprintf(stderr, "traced\n"); } + constructor fntrace_7_cls_new() + { + fprintf(stderr, "constructor\n"); + traced(); + not_traced(); + return (self); + } +#pragma fntrace=off + private void not_traced() { fprintf(stderr, "not_traced\n"); } + destructor fntrace_7_cls_delete(fntrace_7_cls self) + { + fprintf(stderr, "destructor\n"); + traced(); + not_traced(); + } +#pragma fntrace=on +} +void fntrace_7() +{ + fntrace_7_cls o = fntrace_7_cls_new(); + fntrace_7_cls_delete(o); +} +fntrace_7(); +} -match regexp -errorOutput {\d+: enter fntrace_7 +\d+: enter fntrace_7_cls_new +constructor +\d+: enter traced +traced +\d+: exit traced ret '' +not_traced +\d+: exit fntrace_7_cls_new ret '::L::_instance_fntrace_7_cls1' +destructor +\d+: enter traced +traced +\d+: exit traced ret '' +not_traced +\d+: exit fntrace_7 ret '' +} + +test fntrace-8 {test max depth in function tracing} -body { +#lang L --line=1 +#pragma fntrace=on, trace_depth=3 +int fn8_d = 0; +void fn8(int max) +{ + ++fn8_d; + if (fn8_d < max) fn8(max); + --fn8_d; +} +void fntrace_8() +{ + fn8(2); + fn8(3); + fn8(4); + fn8(100); +} +fntrace_8(); +} -match regexp -errorOutput {\d+: enter fntrace_8 +\d+: enter fn8 '2' +\d+: enter fn8 '2' +\d+: exit fn8 '2' ret '' +\d+: exit fn8 '2' ret '' +\d+: enter fn8 '3' +\d+: enter fn8 '3' +\d+: exit fn8 '3' ret '' +\d+: exit fn8 '3' ret '' +\d+: enter fn8 '4' +\d+: enter fn8 '4' +\d+: exit fn8 '4' ret '' +\d+: exit fn8 '4' ret '' +\d+: enter fn8 '100' +\d+: enter fn8 '100' +\d+: exit fn8 '100' ret '' +\d+: exit fn8 '100' ret '' +\d+: exit fntrace_8 ret '' +} + +test fntrace-9 {test entry only or exit only function tracing hooks} -body { +#lang L --line=1 +#pragma fntrace=entry +void fntrace_9_entry() {} +#pragma fntrace=exit +void fntrace_9_exit() {} +#pragma fntrace=on +void fntrace_9() +{ + fntrace_9_entry(); + fntrace_9_exit(); +} +fntrace_9(); +} -match regexp -errorOutput {\d+: enter fntrace_9 +\d+: enter fntrace_9_entry +\d+: exit fntrace_9_exit ret '' +\d+: exit fntrace_9 ret '' +} + +test fntrace-10.1 {test L_TRACE environment variable, output to file} -setup { + set fname [makeFile { +#pragma fntrace=on + void main() {} + } fntrace101.l] +} -body { +#lang L --line=1 +void fntrace_10_1() +{ + int ret; + FILE f; + string tclsh = eval("interpreter"); + + unlink("fntrace10_1.out"); + putenv("L_TRACE=fntrace10_1.out"); + ret = system({tclsh, "fntrace101.l"}, undef, undef, undef); + unless (ret == 0) puts("bad ret ${ret}"); + + unless (f = fopen("fntrace10_1.out", "r")) puts("bad 1"); + unless (<f> =~ /enter main/) puts("bad 2"); + unless (<f> =~ /exit main/) puts("bad 3"); + fclose(f); + + putenv("L_TRACE="); + unset("::env(L_TRACE)"); + unlink("fntrace10_1.out"); +} +fntrace_10_1(); +} -cleanup { + removeFile $fname +} -output {} + +test fntrace-10.2 {test L_TRACE environment variable, output to socket} -setup { + set fname1 [makeFile { +#pragma fntrace=on + void main() {} + } fntrace102.l] + set fname2 [makeFile { + void cb(FILE sock, _argused string host, _argused int port) + { + unless ((<sock> =~ /enter main/) && + (<sock> =~ /exit main/)) { + FILE f = fopen("fntrace_10_bad", "w"); + fclose(f); + } + fclose(sock); + exit(0); + } + void main() + { + FILE sock = socket(server: "cb", 0); + puts(fconfigure(sock, sockname:)[2]); + vwait("forever"); + } + } fntrace102_server.l] +} -body { +#lang L --line=1 +void fntrace_10_2() +{ + int port, ret; + FILE f; + string tclsh = eval("interpreter"); + + f = popen("'${tclsh}' fntrace102_server.l 2>fntrace102_err", "r"); + unless (f) { + puts("bad server ${stdio_lasterr}"); + return; + } + port = (int)<f>; + putenv("L_TRACE=localhost:${port}"); + unlink("fntrace_10_bad"); + ret = system({tclsh, "fntrace102.l"}, undef, undef, undef); + unless (ret == 0) puts("bad ret ${ret}"); + if (exists("fntrace_10_bad")) puts("bad"); + unlink("fntrace_10_bad"); + unlink("fntrace102_err"); + pclose(f); + putenv("L_TRACE="); + unset("::env(L_TRACE)"); +} +fntrace_10_2(); +} -output {} + +test fntrace-10.3 {test L_TRACE_FILES and --trace-files} -setup { + set fname1 [makeFile { + void fntrace_10_3_a() {} + } fntrace_10_3_a.l] + set fname2 [makeFile { + void fntrace_10_3_b() {} + } fntrace_10_3_b.l] + set fname3 [makeFile { +// #includes have to start at col 1 +#include "fntrace_10_3_a.l" +#include "fntrace_10_3_b.l" + void main() + { + fntrace_10_3_a(); + fntrace_10_3_b(); + } + } fntrace_10_3_c.l] +} -body { +#lang L --line=1 +void fntrace_10_3() +{ + int ret; + string err[]; + string tclsh = eval("interpreter"); + + /* First trace only fntrace_10_3_c.l */ + + putenv("L_TRACE_FILES=fntrace_10_3_c.l"); + ret = system({tclsh, "fntrace_10_3_c.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 1.1"); + unless (err[0] =~ /enter main/) puts("bad 1.2"); + unless (err[1] =~ /exit main/) puts("bad 1.3"); + if (err[2]) puts("bad 1.4"); + + putenv("L_TRACE_FILES="); + unset("::env(L_TRACE_FILES)"); + ret = system( + {tclsh, "--trace-files=fntrace_10_3_c.l", "fntrace_10_3_c.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 1.11"); + unless (err[0] =~ /enter main/) puts("bad 1.12"); + unless (err[1] =~ /exit main/) puts("bad 1.13"); + if (err[2]) puts("bad 1.14"); + + // Env var should take precedence over cmd line. + putenv("L_TRACE_FILES=fntrace_10_3_c.l"); + ret = system({tclsh, "--trace-files=*", "fntrace_10_3_c.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 1.21"); + unless (err[0] =~ /enter main/) puts("bad 1.22"); + unless (err[1] =~ /exit main/) puts("bad 1.23"); + if (err[2]) puts("bad 1.24"); + + /* Now trace fntrace_10_3_[ab].l */ + + putenv("L_TRACE_FILES=fntrace_10_3_[ab].l"); + ret = system({tclsh, "fntrace_10_3_c.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 2.1"); + unless (err[0] =~ /enter fntrace_10_3_a/) puts("bad 2.2"); + unless (err[1] =~ /exit fntrace_10_3_a/) puts("bad 2.3"); + unless (err[2] =~ /enter fntrace_10_3_b/) puts("bad 2.4"); + unless (err[3] =~ /exit fntrace_10_3_b/) puts("bad 2.5"); + if (err[4]) puts("bad 2.6"); + + putenv("L_TRACE_FILES="); + unset("::env(L_TRACE_FILES)"); + ret = system( + {tclsh, "--trace-files=fntrace_10_3_[ab].l","fntrace_10_3_c.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 2.21"); + unless (err[0] =~ /enter fntrace_10_3_a/) puts("bad 2.22"); + unless (err[1] =~ /exit fntrace_10_3_a/) puts("bad 2.23"); + unless (err[2] =~ /enter fntrace_10_3_b/) puts("bad 2.24"); + unless (err[3] =~ /exit fntrace_10_3_b/) puts("bad 2.25"); + if (err[4]) puts("bad 2.26"); + + // Env var should take precedence over cmd line. + putenv("L_TRACE_FILES=fntrace_10_3_[ab].l"); + ret = system({tclsh, "--trace-files=*","fntrace_10_3_c.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 2.31"); + unless (err[0] =~ /enter fntrace_10_3_a/) puts("bad 2.32"); + unless (err[1] =~ /exit fntrace_10_3_a/) puts("bad 2.33"); + unless (err[2] =~ /enter fntrace_10_3_b/) puts("bad 2.34"); + unless (err[3] =~ /exit fntrace_10_3_b/) puts("bad 2.35"); + if (err[4]) puts("bad 2.36"); + + /* Now trace them all. */ + + putenv("L_TRACE_FILES=*.l"); + ret = system({tclsh, "fntrace_10_3_c.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 3.1"); + unless (err[0] =~ /enter main/) puts("bad 3.2"); + unless (err[1] =~ /enter fntrace_10_3_a/) puts("bad 3.3"); + unless (err[2] =~ /exit fntrace_10_3_a/) puts("bad 3.4"); + unless (err[3] =~ /enter fntrace_10_3_b/) puts("bad 3.5"); + unless (err[4] =~ /exit fntrace_10_3_b/) puts("bad 3.6"); + unless (err[5] =~ /exit main/) puts("bad 3.7"); + if (err[6]) puts("bad 3.8"); + + putenv("L_TRACE_FILES="); + unset("::env(L_TRACE_FILES)"); + ret = system({tclsh, "--trace-files=*", "fntrace_10_3_c.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 3.11"); + unless (err[0] =~ /enter main/) puts("bad 3.12"); + unless (err[1] =~ /enter fntrace_10_3_a/) puts("bad 3.13"); + unless (err[2] =~ /exit fntrace_10_3_a/) puts("bad 3.14"); + unless (err[3] =~ /enter fntrace_10_3_b/) puts("bad 3.15"); + unless (err[4] =~ /exit fntrace_10_3_b/) puts("bad 3.16"); + unless (err[5] =~ /exit main/) puts("bad 3.17"); + if (err[6]) puts("bad 3.18"); + + // Env var should take precedence over cmd line. + putenv("L_TRACE_FILES=*.l"); + ret = system( + {tclsh, "--trace-files=fntrace_10_3_c.l", "fntrace_10_3_c.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 3.21"); + unless (err[0] =~ /enter main/) puts("bad 3.22"); + unless (err[1] =~ /enter fntrace_10_3_a/) puts("bad 3.23"); + unless (err[2] =~ /exit fntrace_10_3_a/) puts("bad 3.24"); + unless (err[3] =~ /enter fntrace_10_3_b/) puts("bad 3.25"); + unless (err[4] =~ /exit fntrace_10_3_b/) puts("bad 3.26"); + unless (err[5] =~ /exit main/) puts("bad 3.27"); + if (err[6]) puts("bad 3.28"); + + /* Try -fntrace_10_3_b.l */ + + putenv("L_TRACE_FILES=*.l:-fntrace_10_3_b.l"); + ret = system({tclsh, "fntrace_10_3_c.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 4.1"); + unless (err[0] =~ /enter main/) puts("bad 4.2"); + unless (err[1] =~ /enter fntrace_10_3_a/) puts("bad 4.3"); + unless (err[2] =~ /exit fntrace_10_3_a/) puts("bad 4.4"); + unless (err[3] =~ /exit main/) puts("bad 4.5"); + if (err[4]) puts("bad 4.6"); + + putenv("L_TRACE_FILES="); + unset("::env(L_TRACE_FILES)"); +} +fntrace_10_3(); +} -output {} + +test fntrace-10.4 {test L_TRACE_FUNCS and --trace-funcs} -setup { + set fname [makeFile { + void fntrace_10_4_a() {} + void fntrace_10_4_b() {} + void fntrace_10_4() + { + fntrace_10_4_a(); + fntrace_10_4_b(); + } + fntrace_10_4(); + } fntrace_10_4.l] +} -body { +#lang L --line=1 +void fntrace_10_4() +{ + int ret; + string err[]; + string tclsh = eval("interpreter"); + + putenv("L_TRACE_FUNCS=fntrace_10_4_a"); + ret = system({tclsh, "fntrace_10_4.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 1.1"); + unless (err[0] =~ /enter fntrace_10_4_a/) puts("bad 1.2"); + unless (err[1] =~ /exit fntrace_10_4_a/) puts("bad 1.3"); + if (err[2]) puts("bad 1.4"); + + putenv("L_TRACE_FUNCS="); + unset("::env(L_TRACE_FUNCS)"); + ret = system({tclsh, "--trace-funcs=fntrace_10_4_a", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 1.11"); + unless (err[0] =~ /enter fntrace_10_4_a/) puts("bad 1.12"); + unless (err[1] =~ /exit fntrace_10_4_a/) puts("bad 1.13"); + if (err[2]) puts("bad 1.14"); + + // Env var should take precedence over cmd line. + putenv("L_TRACE_FUNCS=fntrace_10_4_a"); + ret = system({tclsh, "--trace-funcs=*", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 1.21"); + unless (err[0] =~ /enter fntrace_10_4_a/) puts("bad 1.22"); + unless (err[1] =~ /exit fntrace_10_4_a/) puts("bad 1.23"); + if (err[2]) puts("bad 1.24"); + + + putenv("L_TRACE_FUNCS=fntrace_10_4_[ab]"); + ret = system({tclsh, "fntrace_10_4.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 2.1"); + unless (err[0] =~ /enter fntrace_10_4_a/) puts("bad 2.2"); + unless (err[1] =~ /exit fntrace_10_4_a/) puts("bad 2.3"); + unless (err[2] =~ /enter fntrace_10_4_b/) puts("bad 2.4"); + unless (err[3] =~ /exit fntrace_10_4_b/) puts("bad 2.5"); + if (err[4]) puts("bad 2.6"); + + putenv("L_TRACE_FUNCS="); + unset("::env(L_TRACE_FUNCS)"); + ret = system({tclsh, "--trace-funcs=fntrace_10_4_[ab]", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 2.11"); + unless (err[0] =~ /enter fntrace_10_4_a/) puts("bad 2.12"); + unless (err[1] =~ /exit fntrace_10_4_a/) puts("bad 2.13"); + unless (err[2] =~ /enter fntrace_10_4_b/) puts("bad 2.14"); + unless (err[3] =~ /exit fntrace_10_4_b/) puts("bad 2.15"); + if (err[4]) puts("bad 2.16"); + + // Env var should take precedence over cmd line. + putenv("L_TRACE_FUNCS=fntrace_10_4_[ab]"); + ret = system({tclsh, "--trace-funcs=*", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 2.21"); + unless (err[0] =~ /enter fntrace_10_4_a/) puts("bad 2.22"); + unless (err[1] =~ /exit fntrace_10_4_a/) puts("bad 2.23"); + unless (err[2] =~ /enter fntrace_10_4_b/) puts("bad 2.24"); + unless (err[3] =~ /exit fntrace_10_4_b/) puts("bad 2.25"); + if (err[4]) puts("bad 2.26"); + + + putenv("L_TRACE_FUNCS=*"); + ret = system({tclsh, "fntrace_10_4.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 3.1"); + unless (err[0] =~ /enter fntrace_10_4/) puts("bad 3.2"); + unless (err[1] =~ /enter fntrace_10_4_a/) puts("bad 3.3"); + unless (err[2] =~ /exit fntrace_10_4_a/) puts("bad 3.4"); + unless (err[3] =~ /enter fntrace_10_4_b/) puts("bad 3.5"); + unless (err[4] =~ /exit fntrace_10_4_b/) puts("bad 3.6"); + unless (err[5] =~ /exit fntrace_10_4/) puts("bad 3.7"); + if (err[6]) puts("bad 3.8"); + + putenv("L_TRACE_FUNCS="); + unset("::env(L_TRACE_FUNCS)"); + ret = system({tclsh, "--trace-funcs=*", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 3.11"); + unless (err[0] =~ /enter fntrace_10_4/) puts("bad 3.12"); + unless (err[1] =~ /enter fntrace_10_4_a/) puts("bad 3.13"); + unless (err[2] =~ /exit fntrace_10_4_a/) puts("bad 3.14"); + unless (err[3] =~ /enter fntrace_10_4_b/) puts("bad 3.15"); + unless (err[4] =~ /exit fntrace_10_4_b/) puts("bad 3.16"); + unless (err[5] =~ /exit fntrace_10_4/) puts("bad 3.17"); + if (err[6]) puts("bad 3.18"); + + // Env var should take precedence over cmd line. + putenv("L_TRACE_FUNCS=*"); + ret = system({tclsh, "--trace-funcs=fntrace_10_4_a", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 3.21"); + unless (err[0] =~ /enter fntrace_10_4/) puts("bad 3.22"); + unless (err[1] =~ /enter fntrace_10_4_a/) puts("bad 3.23"); + unless (err[2] =~ /exit fntrace_10_4_a/) puts("bad 3.24"); + unless (err[3] =~ /enter fntrace_10_4_b/) puts("bad 3.25"); + unless (err[4] =~ /exit fntrace_10_4_b/) puts("bad 3.26"); + unless (err[5] =~ /exit fntrace_10_4/) puts("bad 3.27"); + if (err[6]) puts("bad 3.28"); + + + putenv("L_TRACE_FUNCS=*:-fntrace_10_4b"); + ret = system({tclsh, "fntrace_10_4.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 4.1"); + unless (err[0] =~ /enter fntrace_10_4/) puts("bad 4.2"); + unless (err[1] =~ /enter fntrace_10_4_a/) puts("bad 4.3"); + unless (err[2] =~ /exit fntrace_10_4_a/) puts("bad 4.4"); + unless (err[5] =~ /exit fntrace_10_4/) puts("bad 4.5"); + if (err[6]) puts("bad 4.6"); + + putenv("L_TRACE_FUNCS="); + unset("::env(L_TRACE_FUNCS)"); + ret = system({tclsh, "--trace-funcs=*:-fntrace_10_4b", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 4.11"); + unless (err[0] =~ /enter fntrace_10_4/) puts("bad 4.12"); + unless (err[1] =~ /enter fntrace_10_4_a/) puts("bad 4.13"); + unless (err[2] =~ /exit fntrace_10_4_a/) puts("bad 4.14"); + unless (err[5] =~ /exit fntrace_10_4/) puts("bad 4.15"); + if (err[6]) puts("bad 4.16"); + + // Env var should take precedence over cmd line. + putenv("L_TRACE_FUNCS=*:-fntrace_10_4b"); + ret = system({tclsh, "--trace-funcs=*", "fntrace_10_4.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 4.21"); + unless (err[0] =~ /enter fntrace_10_4/) puts("bad 4.22"); + unless (err[1] =~ /enter fntrace_10_4_a/) puts("bad 4.23"); + unless (err[2] =~ /exit fntrace_10_4_a/) puts("bad 4.24"); + unless (err[5] =~ /exit fntrace_10_4/) puts("bad 4.25"); + if (err[6]) puts("bad 4.26"); + + putenv("L_TRACE_FUNCS="); + unset("::env(L_TRACE_FUNCS)"); +} +fntrace_10_4(); +} -output {} + +test fntrace-10.5 {test L_TRACE_SCRIPT and --trace-script, script} -setup { + set fname [makeFile { + void foo(_argused int a) {} + void main() + { + foo(123); + } + } fntrace_10_5.l] +} -body { +#lang L --line=1 +void fntrace_10_5() +{ + int ret; + string out[]; + string tclsh = eval("interpreter"); + + /* Test a trace-hook script in L_TRACE_SCRIPT. */ + putenv("L_TRACE_ALL=on"); + putenv("L_TRACE_SCRIPT=puts(av)"); + ret = system({tclsh, "fntrace_10_5.l"}, undef, &out, undef); + unless (ret == 0) puts("bad 1.1"); + unless (out[0] == "main") puts("bad 1.2"); + unless (out[1] == "foo 123") puts("bad 1.3"); + unless (out[2] == "foo 123") puts("bad 1.4"); + unless (out[3] == "main") puts("bad 1.5"); + if (out[4]) puts("bad 1.6"); + putenv("L_TRACE_ALL="); + putenv("L_TRACE_SCRIPT="); + unset("::env(L_TRACE_ALL)"); + unset("::env(L_TRACE_SCRIPT)"); + + /* Test a trace-hook script in --trace-script. */ + ret = system( + {tclsh, "--fntrace=on", "--trace-script=puts(av)", "fntrace_10_5.l"}, + undef, &out, undef); + unless (ret == 0) puts("bad 1.11"); + unless (out[0] == "main") puts("bad 1.12"); + unless (out[1] == "foo 123") puts("bad 1.13"); + unless (out[2] == "foo 123") puts("bad 1.14"); + unless (out[3] == "main") puts("bad 1.15"); + if (out[4]) puts("bad 1.16"); + + /* Try both. Env variable should take precedence. */ + putenv("L_TRACE_ALL=on"); + putenv("L_TRACE_SCRIPT=puts(av)"); + ret = system( + {tclsh, "--fntrace=on --trace-script=puts(33)", "fntrace_10_5.l"}, + undef, &out, undef); + unless (ret == 0) puts("bad 1.21"); + unless (out[0] == "main") puts("bad 1.22"); + unless (out[1] == "foo 123") puts("bad 1.23"); + unless (out[2] == "foo 123") puts("bad 1.24"); + unless (out[3] == "main") puts("bad 1.25"); + if (out[4]) puts("bad 1.26"); + + putenv("L_TRACE_ALL="); + putenv("L_TRACE_SCRIPT="); + /* Needed since L's putenv does not really unset the env var. */ + unset("::env(L_TRACE_ALL)"); + unset("::env(L_TRACE_SCRIPT)"); +} +fntrace_10_5(); +} -output {} + +test fntrace-10.6 {test L_TRACE_SCRIPT and --trace-script, file} -setup { + set fname1 [makeFile { + int foo(int a) + { + return (a+1); + } + int main() + { + foo(123); + return (0); + } + } fntrace_10_6.l] + set fname2 [makeFile { +#pragma fnhook=myhook + void myhook(int pre, string av[], string ret) + { + fprintf(stderr, "my: %d %s %s\n", pre, av, ret); + } + } fntrace_10_6_hooks.l] +} -body { +#lang L --line=1 +void fntrace_10_6() +{ + int ret; + string err[]; + string tclsh = eval("interpreter"); + + /* Test a trace filename in L_TRACE_SCRIPT. */ + putenv("L_TRACE_ALL=on"); + putenv("L_TRACE_SCRIPT=fntrace_10_6_hooks.l"); + ret = system({tclsh, "fntrace_10_6.l"}, undef, undef, &err); + unless (ret == 0) puts("bad 1.1"); + unless (err[0] == "my: 1 main 0") puts("bad 1.2"); + unless (err[1] == "my: 1 foo 123 0") puts("bad 1.3"); + unless (err[2] == "my: 0 foo 123 124") puts("bad 1.4"); + unless (err[3] == "my: 0 main 0") puts("bad 1.5"); + if (err[4]) puts("bad 1.6"); + putenv("L_TRACE_ALL="); + putenv("L_TRACE_SCRIPT="); + unset("::env(L_TRACE_ALL)"); + unset("::env(L_TRACE_SCRIPT)"); + + /* Test a trace filename in --trace-script. */ + ret = system( + {tclsh, "--fntrace=on", "--trace-script=fntrace_10_6_hooks.l", + "fntrace_10_6.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 1.11"); + unless (err[0] == "my: 1 main 0") puts("bad 1.12"); + unless (err[1] == "my: 1 foo 123 0") puts("bad 1.13"); + unless (err[2] == "my: 0 foo 123 124") puts("bad 1.14"); + unless (err[3] == "my: 0 main 0") puts("bad 1.15"); + if (err[4]) puts("bad 1.16"); + + /* Try both. Env variable should take precedence. */ + putenv("L_TRACE_ALL=on"); + putenv("L_TRACE_SCRIPT=fntrace_10_6_hooks.l"); + ret = system({tclsh, "--trace-script=puts(22)", "fntrace_10_6.l"}, + undef, undef, &err); + unless (ret == 0) puts("bad 1.21"); + unless (err[0] == "my: 1 main 0") puts("bad 1.22"); + unless (err[1] == "my: 1 foo 123 0") puts("bad 1.23"); + unless (err[2] == "my: 0 foo 123 124") puts("bad 1.24"); + unless (err[3] == "my: 0 main 0") puts("bad 1.25"); + if (err[4]) puts("bad 1.26"); + + putenv("L_TRACE_SCRIPT="); + /* Needed since L's putenv does not really unset the env var. */ + unset("::env(L_TRACE_ALL)"); + unset("::env(L_TRACE_SCRIPT)"); +} +fntrace_10_6(); +} -output {} + +test fntrace-10.7 {test L_TRACE_SCRIPT and --trace-script errors} -setup { + set fname [makeFile { + void main() {} + } fntrace_10_7.l] +} -body { +#lang L --line=1 +void fntrace_10_7() +{ + int ret; + string err[]; + string tclsh = eval("interpreter"); + + putenv("L_TRACE_SCRIPT=bad-does-not-exist.l"); + ret = system({tclsh, "fntrace_10_7.l"}, undef, undef, &err); + unless (ret == 1) puts("bad 1.1"); + unless (err[0] =~ /couldn.t open "bad-does-not-exist.l"/) { + puts("bad 1.2"); + } + putenv("L_TRACE_SCRIPT="); + unset("::env(L_TRACE_SCRIPT)"); + + ret = system({tclsh, "--trace-script=bad.l", "fntrace_10_7.l"}, + undef, undef, &err); + unless (ret == 1) puts("bad 1.11"); + unless (err[0] =~ /couldn.t open "bad.l"/) { + puts("bad 1.12"); + } + + putenv("L_TRACE_SCRIPT="); + /* Needed since L's putenv does not really unset the env var. */ + unset("::env(L_TRACE_SCRIPT)"); +} +fntrace_10_7(); +} -output {} + +test fntrace-11 {test that a hook fn does not get traced} -body { +#lang L --line=1 +#pragma fntrace=on, fnhook=fntrace_11_hook +void fntrace_11_hook(int pre, _argused poly av[], _argused poly ret) +{ + printf("%s %s\n", pre ? "entry" : "exit", av[0]); +} +void fntrace_11() +{ +} +fntrace_11(); +} -output {entry fntrace_11 +exit fntrace_11 +} + +test fntrace-12.1 {test fn _attributes for tracing} -body { +#lang L --line=1 +void fntrace_12_1_f1() _attribute (fntrace=on) {} +void fntrace_12_1_f2() {} +void fntrace_12_1_f3() _attribute (fntrace=off) {} +void fntrace_12_1() +{ + fntrace_12_1_f1(); + fntrace_12_1_f2(); + fntrace_12_1_f3(); +} +fntrace_12_1(); +} -match regexp -errorOutput {\d+: enter fntrace_12_1_f1 +\d+: exit fntrace_12_1_f1 ret '' +} + +test fntrace-12.2 {test more fn _attributes for tracing} -body { +#lang L --line=1 --trace-out=stdout +#pragma fnhook=def +void fntrace_12_2_hook(int pre, _argused poly av[], _argused poly ret) +{ + printf("%s %s\n", pre ? "entry" : "exit", av[0]); +} +void fntrace_12_2_f1() _attribute (fntrace=on, fnhook=fntrace_12_2_hook) {} +void fntrace_12_2_f2() {} +void fntrace_12_2_f3() _attribute (fntrace=off) {} +void fntrace_12_2_f4() _attribute (fntrace=on) {} +void fntrace_12_2() +{ + fntrace_12_2_f1(); + fntrace_12_2_f2(); + fntrace_12_2_f3(); + fntrace_12_2_f4(); +} +fntrace_12_2(); +} -match regexp -output {entry fntrace_12_2_f1 +exit fntrace_12_2_f1 +\d+: enter fntrace_12_2_f4 +\d+: exit fntrace_12_2_f4 ret '' +} + +test fntrace-13.1 {test run-time function tracing control} -body { +#lang L --line=1 +#pragma fntrace=off +int fn13_d = 0; +void fn13(int max) +{ + ++fn13_d; + if (fn13_d < max) fn13(max); + --fn13_d; +} +void fntrace_13_1_f1() {} +void fntrace_13_1_f2() {} +void fntrace_13_1() +{ + FILE f; + + fntrace_13_1_f1(); + Ltrace({"fntrace" => "on", "trace_depth" => 3, "trace_out" => stdout}); + fntrace_13_1_f1(); + fn13(100); + Ltrace({"fntrace" => "entry", "trace_out" => "fn13.out"}); + fntrace_13_1_f1(); + Ltrace({"trace_out" => stdout}); + Ltrace({"fntrace" => "off"}); + fntrace_13_1_f2(); + Ltrace({"trace_funcs" => "fntrace_13_1_f2"}); + fntrace_13_1_f2(); + Ltrace({"fntrace" => "off"}); + + unless (f = fopen("fn13.out", "r")) puts("bad 1"); + unless (<f> =~ /\d+: enter fntrace_13_1_f1/) puts("bad 2"); + if (<f>) puts("bad 3"); + unlink("fn13.out"); +} +fntrace_13_1(); +} -match regexp -output {\d+: enter fntrace_13_1_f1 +\d+: exit fntrace_13_1_f1 ret '' +\d+: enter fn13 '100' +\d+: enter fn13 '100' +\d+: exit fn13 '100' ret '' +\d+: exit fn13 '100' ret '' +\d+: enter fntrace_13_1_f2 +\d+: exit fntrace_13_1_f2 ret '' +} + +test fntrace-13.2 {test run-time disabling of entry or exit traces} -body { +#lang L --line=1 +#pragma fntrace=on +void fntrace_13_2_f(poly arg) +{ + Ltrace(arg); +} +void fntrace_13_2() _attribute(fntrace=off) +{ + fntrace_13_2_f({}); + fntrace_13_2_f({"fntrace" => "off"}); + // This next one won't get us exit traces because Tcl won't call + // the trace of a function if you turn it on while inside that + // function. + fntrace_13_2_f({"fntrace" => "on"}); + fntrace_13_2_f({"fntrace" => "entry"}); + fntrace_13_2_f({"fntrace" => "exit"}); + fntrace_13_2_f({"fntrace" => "off"}); +} +fntrace_13_2(); +} -match regexp -output {\d+: enter fntrace_13_2_f '' +\d+: exit fntrace_13_2_f '' ret '' +\d+: enter fntrace_13_2_f 'fntrace off' +\d+: enter fntrace_13_2_f 'fntrace entry' +\d+: enter fntrace_13_2_f 'fntrace exit' +\d+: exit fntrace_13_2_f 'fntrace exit' ret '' +} + +test try-1 {test try/catch} -body { +#lang L +void try_1() +{ + string err; + int caught; + + caught = 0; + try { + puts(0/0); + puts("bad 1.1"); + } catch(&err) { + ++caught; + unless (err == "divide by zero") puts("bad 1.2"); + } + unless (caught == 1) puts("bad 1.3"); + + caught = 0; + try { + puts(0/0); + puts("bad 2.1"); + } catch { + ++caught; + } + unless (caught == 1) puts("bad 2.2"); + + puts("got here"); // to verify that we executed code after the catches +} +try_1(); +} -output "got here\n" + +test try-2 {test nested try/catch} -body { +#lang L +void try_2() +{ + string err1, err2; + int caught1, caught2; + + caught1 = caught2 = 0; + try { + puts(0/0); + puts("bad 1.1"); + } catch(&err1) { + ++caught1; + unless (err1 == "divide by zero") puts("bad 1.2"); + try { + puts(0/0); + puts("bad 1.3"); + } catch(&err2) { + ++caught2; + unless (err2 == "divide by zero") puts("bad 1.4"); + } + ++caught2; + } + unless (caught1 == 1) puts("bad 1.5"); + unless (caught2 == 2) puts("bad 1.6"); + puts("got here"); // to verify that we executed code after the catch +} +try_2(); +} -output "got here\n" + +test try-3 {test try/catch errors} -body { +#lang L --line=1 +void try_3() +{ + string err; + + try { + puts(0/0); + } catch (err) {} // should be &err + + try { + puts(0/0); + } catch (&3) {} + + /* + * A call to Tcl's catch() isn't allowed by L (have to use ::catch()). + */ + catch("puts bad"); +} +try_3(); +} -returnCodes error -match regexp -result {.*7: L Error: expected catch\(\&variable\) +.*11: L Error: illegal operand to \& +.*16: L Error: catch\(\) is reserved for try/catch; use ::catch\(\) for Tcl\'s catch +} + +::tcltest::cleanupTests +return diff --git a/tests/l-leak.test b/tests/l-leak.test new file mode 100644 index 0000000..3eff659 --- /dev/null +++ b/tests/l-leak.test @@ -0,0 +1,686 @@ +# Test the L language. +# Copyright (c) 2007 BitMover, Inc. + +# +# Tests in this file look for leaks in L core; they are only functional in +# builds with -DTCL_MEM_DEBUG (--enable-symbols=mem or all) +# + + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* + testConstraint exec [llength [info commands exec]] +} + +set haveMem [llength [info commands memory]] +testConstraint memory $haveMem + +#lang L +int getbytes() +{ + return ((int)(split(split(/\n/, Memory_info())[3])[3])); +} +#lang tcl + +# This causes L to keep running L code even after a compile error. +set ::env(_L_TEST) 1 + +# This tells L to run in a backwards compatibility mode for +# the old eq/ne/le/lt/ge/gt string-comparison operators. +set ::env(_L_ALLOW_EQ_OPS) 1 + +test leak-1.1 {leaks in a simple L-loop} -body { +#lang L --line=1 + void leak_1_1() { + int tmp, end, i, j; + + end = getbytes(); + for(i=0; i<5;i++) { + j=i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_1_1(); +} -constraints memory -output "0 4\n" + +test leak-1.2 {leaks in L-func called in a loop} -body { +#lang L --line=1 + int leak_1_2_foo (int v) { + int k; + k = v; + return k; + } + void leak_1_2() { + int tmp, end, i, j; + + end = getbytes(); + for(i=0; i<5;i++) { + j=leak_1_2_foo(i); + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_1_2(); +} -constraints memory -output "0 4\n" + +test leak-1.3 {leaks in L-func called in a tcl-loop} -body { +#lang L --line=1 + int leak_1_3_foo (int v) { + int k; + k = v; + return k; + } +#lang tcl + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set j [leak_1_3_foo $i] + set tmp $end + set end [getbytes] + } + puts [list [expr {$end - $tmp}] $j] +} -constraints memory -output "0 4\n" + +test leak-2.0 {leaks in array reading} -body { +#lang L --line=1 + void leak_2_0() { + int tmp, end, i, j[2], k, l; + j[0]=1; + j[1]=2; + + end = getbytes(); + for(i=0; i<5;i++) { + k = j[0]; + l = j[1]; + tmp=end; + end = getbytes(); + } + puts(end-tmp); + } + leak_2_0(); +} -constraints memory -output "0\n" + +test leak-2.1 {leaks in array initializers} -body { +#lang L --line=1 + void leak_2_1() { + int tmp, end, i, k[2]; + + end = getbytes(); + for(i=0; i<5;i++) { + int j[2]; + k = j; + tmp=end; + end = getbytes(); + } + puts(end-tmp); + } + leak_2_1(); +} -constraints memory -output "0\n" + +test leak-2.2.0 {leaks in arrays} -body { +#lang L --line=1 + void leak_2_2_0() { + int tmp, end, i, j[2] = {0,0}; + + end = getbytes(); + for(i=0; i<5;i++) { + j[0]=i; + j[1]=2*j[0]+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_2_2_0(); +} -constraints memory -output "0 {4 12}\n" + +test leak-2.2.1 {leaks in arrays} -body { +#lang L --line=1 + void leak_2_2_1() { + int tmp, end, i, k[2], j[2]; + j=k; + end = getbytes(); + for(i=0; i<5;i++) { + j[0]=i; + j[1]=2*j[0]+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_2_2_1(); +} -constraints memory -output "0 {4 12}\n" + +test leak-2.3 {leaks in arrays} -body { +#lang L --line=1 + int leak_2_3_foo (int v) { + int k[2]; + k[0] = v; + k[1] = 2*k[0]+v; + return k[1]; + } + void leak_2_3() { + int tmp, end, i, j; + + end = getbytes(); + for(i=0; i<5;i++) { + j=leak_2_3_foo(i); + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_2_3(); +} -constraints memory -output "0 12\n" + +test leak-2.4 {leaks in arrays} -body { +#lang L --line=1 + void leak_2_4() { + int tmp, end, i, j[2][2]; + + end = getbytes(); + for(i=0; i<5;i++) { + j[0][0]=i; + j[0][1]=2*j[0][0]+i; + j[1][0]=j[0][0]+j[0][1]; + j[1][1]=2*j[1][0]+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_2_4(); +} -constraints memory -output "0 {{4 12} {16 36}}\n" + +test leak-2.5 {leaks in arrays} -body { +#lang L --line=1 + void leak_2_5() { + int tmp, end, i, t, j[2][2][2]; + + end = getbytes(); + for(i=0; i<5;i++) { + for (t=0; t < 2; t++) { + j[0][i%2][t]=i+t; + j[1][i%2][t]=i*i+t; + } + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_2_5(); +} -constraints memory -output "0 {{{4 5} {3 4}} {{16 17} {9 10}}}\n" + +test leak-3.0 {leaks in hash initializers} -body { +#lang L --line=1 + void leak_3_0() { + int tmp, end, i; + hash k = {"1" => "foo"}; + end = getbytes(); + for(i=0; i<5;i++) { + hash j = {"1" => "moo"}; + k = j; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, k)); + } + leak_3_0(); +} -constraints memory -output "0 {1 moo}\n" + +test leak-3.1.0 {leaks in hashes} -body { +#lang L --line=1 + void leak_3_1_0() { + int tmp, end, i; + hash j; + + end = getbytes(); + for(i=0; i<5;i++) { + j{"0"}=i; + j{"1"}=2*(int)j{"0"}+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j{"1"})); + } + leak_3_1_0(); +} -constraints memory -output "0 12\n" + +test leak-3.1.1 {leaks in hashes} -body { +#lang L --line=1 + void leak_3_1_1() { + int tmp, end, i; + hash j = {"u" => 0}; + + end = getbytes(); + for(i=0; i<5;i++) { + j{"0"}=i; + j{"1"}=2*(int)j{"0"}+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j{"1"})); + } + leak_3_1_1(); +} -constraints memory -output "0 12\n" + +test leak-3.1.2 {leaks in hashes} -body { +#lang L --line=1 + void leak_3_1_2() { + int tmp, end, i; + hash j, k = {"u" => 0}; + + j = k; + end = getbytes(); + for(i=0; i<5;i++) { + j{"0"}=i; + j{"1"}=2*(int)j{"0"}+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j{"1"})); + } + leak_3_1_2(); +} -constraints memory -output "0 12\n" + +test leak-3.2.0 {leaks in hashes} -body { +#lang L --line=1 + hash leak_3_2_0_foo (int v) { + hash k; + k{"0"} = v; + k{"1"} = 2*(int)k{"0"}+v; + return k; + } + void leak_3_2_0() { + int tmp, end, i; + hash j; + + end = getbytes(); + for(i=0; i<5;i++) { + j=leak_3_2_0_foo(i); + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j{"1"})); + } + leak_3_2_0(); +} -constraints memory -output "0 12\n" + +test leak-3.2.1 {leaks in hashes} -body { +#lang L --line=1 + hash leak_3_2_1_foo (int v) { + hash k = {"a" => "b"}; + k{"0"} = v; + k{"1"} = 2*(int)k{"0"}+v; + return k; + } + void leak_3_2_1() { + int tmp, end, i; + hash j; + + end = getbytes(); + for(i=0; i<5;i++) { + j=leak_3_2_1_foo(i); + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j{"1"})); + } + leak_3_2_1(); +} -constraints memory -output "0 12\n" + +test leak-3.3 {leaks in nested hashes} -body { +#lang L --line=1 + void leak_3_3() { + int tmp, end, i; + int j{string}{string}; + + end = getbytes(); + for(i=0; i<5;i++) { + j{"0"}{"0"}=i; + j{"0"}{"1"}=2*(int)j{"0"}{"0"}+i; + j{"1"}{"0"}=2*i + 1 + (int)j{"0"}{"1"}; + j{"1"}{"1"}=2*(int)j{"1"}{"0"}+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j{"1"}{"1"})); + } + leak_3_3(); +} -constraints memory -output "0 46\n" + +test leak-4.1 {leaks in structs} -body { +#lang L --line=1 + struct leak_4_1_js {int x, y;}; + void leak_4_1() { + int tmp, end, i; + struct leak_4_1_js j; + end = getbytes(); + for(i=0; i<5;i++) { + j.x=i; + j.y=2*j.x+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_4_1(); +} -constraints memory -output "0 {4 12}\n" + +test leak-4.2 {leaks in structs} -body { +#lang L --line=1 + struct leak_4_2_js {int x, y[2];}; + void leak_4_2() { + int tmp, end, i; + struct leak_4_2_js j; + end = getbytes(); + for(i=0; i<5;i++) { + j.x=i; + j.y[0]=2*j.x+i; + j.y[1]=2*j.y[0]+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_4_2(); +} -constraints memory -output "0 {4 {12 28}}\n" + +test leak-4.3 {leaks in structs} -body { +#lang L --line=1 + struct leak_4_3_js {int x, y;}; + void leak_4_3() { + int tmp, end, i; + struct leak_4_3_js j[2]; + end = getbytes(); + for(i=0; i<5;i++) { + j[0].x=i; + j[0].y=2*j[0].x+i; + j[1].x=j[0].x+j[0].y; + j[1].y=2*j[1].x+i; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_4_3(); +} -constraints memory -output "0 {{4 12} {16 36}}\n" + +test leak-5.1 {leaks in deep diving} -body { +#lang L --line=1 + struct leak_5_1_js {string h{string}; poly a[2];}; + struct leak_5_1_js leak_5_1_j[2]; + string leak_5_1_h{string}; + void leak_5_1() { + int tmp, end, i; + end = getbytes(); + for(i=0; i<5;i++) { + leak_5_1_j[0].h{"foo"}= leak_5_1_j[1].a[1]; + leak_5_1_j[1].h{"foo"}= "moo"; + leak_5_1_j[0].a[0]=leak_5_1_j[1].h; + leak_5_1_j[0].a[1]=leak_5_1_j[0].h{"foo"}; + leak_5_1_j[1].a[0]=leak_5_1_j[0].h{"foo"}; + leak_5_1_j[1].a[1]=leak_5_1_j[1].a[0]; + tmp=end; + end = getbytes(); + } + leak_5_1_h = (hash)leak_5_1_j[0].a[0]; + puts(list(end-tmp, leak_5_1_h{"foo"}, leak_5_1_j[1].h{"foo"})); + } + leak_5_1(); +} -constraints memory -output "0 moo moo\n" + +test leak-5.2 {leaks in deep diving} -body { +#lang L --line=1 + void leak_5_2() { + int tmp, end, i, j; + end = getbytes(); + for(i=0; i<5;i++) { + j = {1,2,3}[1]; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_5_2(); +} -constraints memory -output "0 2\n" + +test leak-5.3 {leaks in deep diving} -body { +#lang L --line=1 + void leak_5_3() { + int tmp, end, i, j; + end = getbytes(); + for(i=0; i<5;i++) { + j = {{1,2},{3,4},{4,5}}[1][0]; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_5_3(); +} -constraints memory -output "0 3\n" + +test leak-5.4 {leaks in deep diving} -body { +#lang L --line=1 + void leak_5_4() { + int tmp, end, i, j; + end = getbytes(); + for(i=0; i<5;i++) { + j = { {{1,2},{3,4}}, {{4,5},{5,6}}, {{7,8},{9,10}} }[1][1][0]; + { {0,0} }[END][0]; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, j)); + } + leak_5_4(); +} -constraints memory -output "0 5\n" + +test leak-5.5 {leaks in deep diving} -body { +#lang L --line=1 +void leak_5_5() +{ + int n = 1000; + int i, start, end, types{string}[]; + + /* + * Push onto a hash element that's an array element while + * check memory usage. Allow 1 kB/element. Any more than that + * must be a memory leak. + */ + start = getbytes(); + for (i = 0; i < n; ++i) { + push(&types{"foo"}, i); + } + end = getbytes(); + if ((end - start) > (1000*n)) { + puts("took ${(end-start)/n} bytes per elt"); + } +} +leak_5_5(); +} -constraints memory -output {} + +test leak-6.1 {leaks in string indexing} -body { +#lang L --line=1 + void leak_6_1() { + int end, i, tmp; + string a[], s1, s2; + + a[0] = "zero"; + end = getbytes(); + for(i=0; i<5;i++) { + s1 = a[0]; + s2 = {"zero"}[0]; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, s1, s2)); + } + leak_6_1(); +} -constraints memory -output "0 zero zero\n" + +test leak-6.2 {leaks in string indexing} -body { +#lang L --line=1 + void leak_6_2() { + int end, i, tmp; + string a[][], s1, s2; + + a[0][0] = "zero"; + end = getbytes(); + for(i=0; i<5;i++) { + s1 = a[0][0]; + s2 = { {"zero"} }[0][0]; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, s1, s2)); + } + leak_6_2(); +} -constraints memory -output "0 zero zero\n" + +test leak-6.3 {leaks in string indexing} -body { +#lang L --line=1 + void leak_6_3() { + int end, i, tmp; + string a[][][], s1, s2; + + a[0][0][0] = "zero"; + end = getbytes(); + for(i=0; i<5;i++) { + s1 = a[0][0][0]; + s2 = { { {"zero"} } }[0][0][0]; + tmp=end; + end = getbytes(); + } + puts(list(end-tmp, s1, s2)); + } + leak_6_3(); +} -constraints memory -output "0 zero zero\n" + +test leak-6.4 {leaks in string indexing} -body { +#lang L --line=1 + void leak_6_4() { + int end, i, tmp; + string s; + + s = "abcd"; + end = getbytes(); + for(i=0; i<5;i++) { + s[0] = "w"; + s[1] = "x"; + s[2] = "y"; + s[3] = "z"; + s[0] = "123"; + s[1] = "456"; + s[2] = "789"; + s[3] = "0yz"; + s[0] = ""; + s[1] = ""; + s[2] = ""; + s[3] = ""; + s[4] = ""; + s[5] = ""; + s[0] = ""; + s[0] = ""; + tmp=end; + end = getbytes(); + } + puts(end-tmp); + } + leak_6_4(); +} -constraints memory -output "0\n" + +test leak-7.1 {leaks in classes} -body { +#lang L --line=1 +class leak_7_1 +{ + public int v1; + instance { + public int v2; + } + constructor leak_7_1_init() {} + destructor leak_7_1_free(leak_7_1 self) {} +} +void leak_7_1_main() +{ + int end, i, tmp; + leak_7_1 o; + + end = getbytes(); + for (i = 0; i < 5; ++i) { + o = leak_7_1_init(); + leak_7_1_free(o); + tmp = end; + end = getbytes(); + } + puts(end - tmp); +} +leak_7_1_main(); +} -constraints memory -output "0\n" + +test leak-8.1 {leaks with undef() on hashes} -body { +#lang L --line=1 +void leak_8_1_main() +{ + int end, i, tmp; + + end = getbytes(); + for (i = 0; i < 5; ++i) { + string h{string} = { "1"=>"1", "2"=>"2", "3"=>"3", "4"=>"4" }; + undef(h{"1"}); + undef(h{"2"}); + undef(h{"3"}); + undef(h{"4"}); + tmp = end; + end = getbytes(); + } + puts(end - tmp); +} +leak_8_1_main(); +} -constraints memory -output "0\n" + +test leak-8.2 {leaks with undef() on arrays} -body { +#lang L --line=1 +void leak_8_2_main() +{ + int end, i, tmp; + + end = getbytes(); + for (i = 0; i < 5; ++i) { + int a[] = { 1, 2, 3, 4 }; + undef(a[0]); + undef(a[0]); + undef(a[0]); + undef(a[0]); + tmp = end; + end = getbytes(); + } + puts(end - tmp); +} +leak_8_2_main(); +} -constraints memory -output "0\n" + +# Disable the leak-9 test for now. L leaks memory when freeing +# a Tcl interp. Usually, L code is run all within one interp so +# this usually isn't a big deal. Some day we'll come back to this. +::tcltest::cleanupTests +return + +test leak-9 {per-interp L state leak} -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + interp create slave + slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 + interp delete slave + set tmp $end + set end [getbytes] + } + puts [expr {$end - $tmp}] +} -constraints memory -output "0\n" + +# cleanup +::tcltest::cleanupTests +return diff --git a/tests/l-libl.test b/tests/l-libl.test new file mode 100644 index 0000000..ec40be1 --- /dev/null +++ b/tests/l-libl.test @@ -0,0 +1,3922 @@ +# Test the L library. +# Copyright (c) 2009 BitMover, Inc. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* + testConstraint exec [llength [info commands exec]] +} + +if {$::tcl_platform(platform) eq "windows"} { + set _windows 1 +} else { + set _windows 0 +} + +# This causes L to keep running L code even after a compile error. +set ::env(_L_TEST) 1 + +# This tells L to run in a backwards compatibility mode for +# the old eq/ne/le/lt/ge/gt string-comparison operators. +set ::env(_L_ALLOW_EQ_OPS) 1 + +test angle-1 {test <f>} -setup { + set fname1 [makeFile "linea1\n" angle1 .] + set fname2 [makeFile "lineb1\nlineb2\n" angle2 .] + set fname3 [makeFile "linec1\nlinec2\nlinec3\n" angle3 .] +} -body { +#lang L --line=1 +void angle1() +{ + int i; + string s; + FILE f; + + unless (defined(f = fopen("angle1", "r"))) puts("bad 1.1"); + for (i = 1; i <= 1; ++i) { + unless (defined(s = <f>)) puts("bad 1.2"); + unless (s eq "linea${i}") puts("bad 1.3"); + } + if (defined(<f>)) puts("bad 1.4"); + unless (fclose(f) == 0) puts("bad 1.5"); + + unless (defined(f = fopen("angle2", "r"))) puts("bad 3.1"); + for (i = 1; i <= 2; ++i) { + unless (defined(s = <f>)) puts("bad 3.2"); + unless (s eq "lineb${i}") puts("bad 3.3"); + } + if (defined(<f>)) puts("bad 3.4"); + unless (fclose(f) == 0) puts("bad 3.5"); + + unless (defined(f = fopen("angle3", "r"))) puts("bad 4.1"); + for (i = 1; i <= 3; ++i) { + unless (defined(s = <f>)) puts("bad 4.2"); + unless (s eq "linec${i}") puts("bad 4.3"); + } + if (defined(<f>)) puts("bad 4.4"); + unless (fclose(f) == 0) puts("bad 4.5"); + + /* Create and read an empty file. */ + unless (defined(f = fopen("angle4", "w"))) puts("bad 5.1"); + fclose(f); + unless (defined(f = fopen("angle4", "r"))) puts("bad 5.2"); + if (defined(<f>)) puts("bad 5.3"); + unless (fclose(f) == 0) puts("bad 5.4"); + unlink("angle4"); +} +angle1(); +} -output {} + +test angle-2 {test <>} -setup { + set script [makeFile { + void main() { + string s; + printf("<"); + while (defined(s=<>)) puts(s); + printf(">"); + } + } angle2.l .] + set fname1 [makeFile "linea1\n" angle2-1 .] + set fname2 [makeFile "lineb1\nlineb2\n" angle2-2 .] + set fname3 [makeFile "linec1\nlinec2\nlinec3\n" angle2-3 .] +} -constraints { + exec +} -body { + puts [exec [interpreter] $script $fname1] + puts [exec [interpreter] $script $fname1 $fname2] + puts [exec [interpreter] $script $fname1 $fname2 $fname3] + puts [exec [interpreter] $script $fname1 $fname1] + puts [exec [interpreter] $script $fname1 $fname1 $fname1] +} -output {<linea1 +> +<linea1 +lineb1 +lineb2 +> +<linea1 +lineb1 +lineb2 +linec1 +linec2 +linec3 +> +<linea1 +linea1 +> +<linea1 +linea1 +linea1 +> +} + +test angle-2.1 {test <> reading stdin} -setup { + makeFile { + void main() + { + string s; + while (s = <>) puts("<${s}>"); + } + } angle-2.1-1.l . + makeFile { + void main() + { + string s; + while (s = <stdin>) puts("<${s}>"); + } + } angle-2.1-2.l . +} -body { +#lang L +void angle_2_1() +{ + int ret; + string err, in[], out[]; + string tclsh = eval("interpreter"); + + in = { "line1", "line2", "line3" }; + ret = system({tclsh, "angle-2.1-1.l"}, in, &out, &err); + if (ret) puts("bad 1.1"); + unless (eq(out, {"<line1>","<line2>","<line3>"})) { + puts("bad 1.2 got '${out}'"); + } + if (err) puts("bad 1.3"); + + in = { "line1", "line2", "line3" }; + ret = system({tclsh, "angle-2.1-2.l"}, in, &out, &err); + if (ret) puts("bad 2.1"); + unless (eq(out, {"<line1>","<line2>","<line3>"})) { + puts("bad 2.2 got '${out}'"); + } + if (err) puts("bad 2.3"); +} +angle_2_1(); +} -output {} + +test angle-3 {test <f> errors} -body { +#lang L --line=1 +void angle3() +{ + FILE f; + + if (defined(<f>)) puts("bad 1"); +} +angle3(); +} -output {} + +test angle-4 {test <> type errors} -body { +#lang L --line=1 +void angle4() +{ + string arr[]; + string hsh{string}; + struct { string s; } st; + + /* These are all type errors. */ + <0>; + <0.0>; + <{0}>; + <arr>; + <st>; + <hsh>; +} +} -returnCodes error -match regexp -result {.*8: L Error: expect FILE in <> +.*9: L Error: expect FILE in <> +.*10: L Error: expect FILE in <> +.*11: L Error: expect FILE in <> +.*12: L Error: expect FILE in <> +.*13: L Error: expect FILE in <> +} + +test angle-5 {test <> file-open errors} -setup { + set script [makeFile { + void main() { + string s; + while (defined(s=<>)) puts(s); + } + } angle5.l .] + set fname [makeFile "line1\n" angle5-1 .] +} -constraints { + exec +} -body { + puts [exec [interpreter] $script bad1 2>err] + puts [exec cat err] + puts [exec [interpreter] $script bad2 $fname 2>err] + puts [exec cat err] + puts [exec [interpreter] $script $fname bad3 $fname 2>err] + puts [exec cat err] + puts [exec [interpreter] $script $fname bad4 bad5 $fname bad6 2>err] + puts [exec cat err] +} -output { +couldn't open "bad1": no such file or directory +line1 +couldn't open "bad2": no such file or directory +line1 +line1 +couldn't open "bad3": no such file or directory +line1 +line1 +couldn't open "bad4": no such file or directory +couldn't open "bad5": no such file or directory +couldn't open "bad6": no such file or directory +} + +test assert-1 {test assert} -setup { + set fname [makeFile { + int i = 0; + assert(i > 0); + } assert1.l] +} -body { +#lang L --line=1 +/* + * Some contortions here to run tclsh on assert1.l (above) which + * prints to stderr and then exits(1), so we can capture stderr and + * check the return status. Otherwise, tcltest sees anything to + * stderr as an error and fails the test. + */ +void assert1() +{ + int ret; + string cmd = "\"${eval('interpreter')}\" assert1.l"; + string err[], out[]; + + ret = system(cmd, undef, &out, &err); + unless (ret == 1) puts("bad status ${ret}"); + unless (length(out) == 0) puts("bad 2"); + unless (err[0] eq "ASSERTION FAILED assert1.l:3: i > 0") { + puts("bad stderr ${err}"); + } +} +assert1(); +} -output {} + +test basename-1 {test basename} -body { +#lang L --line=1 +void basename1() +{ + unless (basename("x") eq "x") puts("bad 1"); + unless (basename("") eq "") puts("bad 2"); + unless (basename("/x/y") eq "y") puts("bad 3"); + unless (basename("/path/to/file") eq "file") puts("bad 4"); + unless (basename("path/to/file") eq "file") puts("bad 5"); + unless (basename("with spaces/to/f ile") eq "f ile") puts("bad 6"); + unless (basename("with brace/to/f {}le") eq "f {}le") puts("bad 7"); + unless (basename("with quotes/f \"\'le") eq "f \"\'le") puts("bad 8"); +} +basename1(); +} -output {} + +test chdir-1 {test chdir} -setup { + file mkdir testdir1 + file mkdir {test dir 2} + file mkdir testdir\{3\} + if {!$_windows} {file mkdir {testdir "'4}} + # '" +} -body { +#lang L --line=1 +void chdir1() +{ + unless (chdir("testdir1") == 0) puts("bad 1.1"); + unless (basename(pwd()) eq "testdir1") puts("bad 1.2"); + unless (chdir("..") == 0) puts("bad 1.3"); + + unless (chdir("test dir 2") == 0) puts("bad 2.1"); + unless (basename(pwd()) eq "test dir 2") puts("bad 2.2"); + unless (chdir("..") == 0) puts("bad 2.3"); + + unless (chdir("testdir{3}") == 0) puts("bad 3.1"); + unless (basename(pwd()) eq "testdir{3}") puts("bad 3.2"); + unless (chdir("..") == 0) puts("bad 3.3"); + + unless (platform() eq "windows") { + unless (chdir("testdir \"\'4") == 0) puts("bad 4.1"); + unless (basename(pwd()) eq "testdir \"\'4") puts("bad 4.2"); + unless (chdir("..") == 0) puts("bad 4.3"); + } + + unless (chdir("does-not-exist") == -1) puts("bad 10.1"); +} +chdir1(); +} -cleanup { + file delete -force testdir1 + file delete -force {test dir 2} + file delete -force testdir\{3\} + if {!$_windows} {file delete -force {testdir "'4}} + # '" +} -output {} + +test caller-1 {test caller} -body { +#lang L --line=1 +void caller1_foo() +{ + unless (caller(0) eq "caller1_foo") puts("bad 2.1"); + unless (caller(1) eq "caller1") puts("bad 2.2"); +} +void caller1() +{ + unless (caller(0) eq "caller1") puts("bad 1.1"); + if (defined(caller(1000))) puts("bad 1.2"); +} +caller1(); +} -output {} + +test chmod-1 {test chmod} -constraints tempNotWin -setup { + set fname1 [makeFile {test} chmod_test1 .] + set fname2 [makeFile {test} {chmod test 2} .] + set fname3 [makeFile {test} chmodtest\{3\} .] + set fname4 [makeFile {test} {chmod test \"\'4} .] +} -body { +#lang L --line=1 +void chmod1(string nm) +{ + FILE f; + struct stat stat; + + f = fopen(nm, "r"); + unless (defined(f)) puts("bad 1.1"); + unless (chmod(nm, "444") == 0) puts("bad 1.2"); + unless (lstat(nm, &stat) == 0) puts("bad 1.3"); + unless (stat.st_mode & 0444) puts("bad 1.4"); + unless (chmod(nm, "666") == 0) puts("bad 1.5"); + unless (lstat(nm, &stat) == 0) puts("bad 1.6"); + unless (stat.st_mode & 0666) puts("bad 1.7"); + fclose(f); + + unless (chmod("does-not-exist", "755") == -1) puts("bad 10.1"); +} +#lang tcl +chmod1 $fname1 +chmod1 $fname2 +chmod1 $fname3 +chmod1 $fname4 +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 + removeFile $fname4 +} -output {} + +test chown-1 {test chown} -constraints tempNotWin -setup { + set fname1 [makeFile {test} chown_test1 .] + set fname2 [makeFile {test} {chown test 2} .] + set fname3 [makeFile {test} chowntest\{3\} .] + set fname4 [makeFile {test} {chown test \"\'4} .] +} -body { +#lang L --line=1 +/* + * This isn't the greatest test, because we can't be sure which users + * or groups are available on the test machine. So we create some + * files, get the current users and groups, and chown the file with + * those, verifying that this doesn't change the file user or group. + */ +void chown1(string nm) +{ + FILE f; + string group, owner; + + f = fopen(nm, "r"); + unless (defined(f)) puts("bad 1.1"); + owner = file("attributes", nm, "-owner"); + group = file("attributes", nm, "-group"); + + unless (chown(owner, "", nm) == 0) puts("bad 1.2"); + unless (file("attributes", nm, "-owner") eq owner) puts("bad 1.3"); + + unless (chown("", group, nm) == 0) puts("bad 1.4"); + unless (file("attributes", nm, "-group") eq group) puts("bad 1.5"); + + unless (chown(owner, group, nm) == 0) puts("bad 1.6"); + unless (file("attributes", nm, "-owner") eq owner) puts("bad 1.7"); + unless (file("attributes", nm, "-group") eq group) puts("bad 1.8"); + + fclose(f); + + unless (chmod("does-not-exist", "755") == -1) puts("bad 10.1"); +} +#lang tcl +chown1 $fname1 +chown1 $fname2 +chown1 $fname3 +chown1 $fname4 +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 + removeFile $fname4 +} -output {} + +test cpus-1 {test cpus api} -body { +#lang L +void cpus1() +{ + if (exists("/proc/cpuinfo")) { + unless (cpus() > 0) puts("bad"); + } +} +cpus1(); +} -output {} + +test die-1 {test die} -setup { + makeFile { + die("die: %s\n", "s1"); + } die1-1.l + makeFile { + die("die: %s %s\n", "s1", "s2"); + } die1-2.l + makeFile { + die("die: %s", "s1"); + } die1-3.l + makeFile { + die("die: %s %s", "s1", "s2"); + } die1-4.l + +} -body { +#lang L --line=1 +void die1() +{ + int ret; + string err, out; + string tclsh = eval("interpreter"); + + ret = system({tclsh, "die1-1.l"}, undef, &out, &err); + unless (ret == 1) puts("bad 1.1"); + if (out) puts("bad 1.2"); + unless (err == "die: s1\n") puts("bad 1.3"); + + ret = system({tclsh, "die1-2.l"}, undef, &out, &err); + unless (ret == 1) puts("bad 2.1"); + if (out) puts("bad 2.2"); + unless (err == "die: s1 s2\n") puts("bad 2.3"); + + ret = system({tclsh, "die1-3.l"}, undef, &out, &err); + unless (ret == 1) puts("bad 3.1"); + if (out) puts("bad 3.2"); + unless (err =~ /die: s1 at die1-3.l line 2.\n/) { + puts("bad 3.3 ${err}"); + } + + ret = system({tclsh, "die1-4.l"}, undef, &out, &err); + unless (ret == 1) puts("bad 4.1"); + if (out) puts("bad 4.2"); + unless (err =~ /die: s1 s2 at die1-4.l line 2.\n/) { + puts("bad 4.3 ${err}"); + } +} +die1(); +} -output {} + +test die-2 {test die errors} -body { +#lang L --line=1 +void die2() +{ + die("%s"); +} +die2(); +} -returnCodes error -match regexp -result {.*3: L Warning: bad format specifier +} + +test dirname-1 {test dirname} -body { +#lang L --line=1 +void dirname1() +{ + unless (dirname("x") eq ".") puts("bad 1"); + unless (dirname("") eq ".") puts("bad 2"); + unless (dirname("/x/y") eq "/x") puts("bad 3"); + unless (dirname("/path/to/file") eq "/path/to") puts("bad 4"); + unless (dirname("path/to/file") eq "path/to") puts("bad 5"); + unless (dirname("with spaces/to/f ile") eq "with spaces/to") { + puts("bad 6"); + } + unless (platform() eq "windows") { + unless (dirname("with \"\'quotes/to/f ile") eq + "with \"\'quotes/to") { + puts("bad 7"); + } + } +} +dirname1(); +} -output {} + +test env-1 {getenv and putenv} -body { +#lang L --line=1 +void env1() +{ + string fmt; + + unless (putenv("LIBLTEST=123") eq "123") puts("bad 0"); + unless (getenv("LIBLTEST") eq "123") puts("bad 1"); + unless (putenv("LIBLTEST=") eq "") puts("bad 1.2"); + if (defined(getenv("LIBLTEST"))) puts("bad 2"); + + unless (defined(getenv("PATH"))) puts("bad 3"); + + putenv("LIBLTEST=%s%s", "one", "two"); + unless (getenv("LIBLTEST") eq "onetwo") puts("bad 4"); + + /* The value can contain = */ + unless (putenv("LIBLTEST=HAS=") eq "HAS=") puts("bad 5.1"); + unless (getenv("LIBLTEST") eq "HAS=") puts("bad 5.2"); + unless (putenv("LIBLTEST=HAS=X") eq "HAS=X") puts("bad 5.3"); + unless (getenv("LIBLTEST") eq "HAS=X") puts("bad 5.4"); + unless (putenv("LIBLTEST=HAS==") eq "HAS==") puts("bad 5.5"); + unless (getenv("LIBLTEST") eq "HAS==") puts("bad 5.6"); + unless (putenv("LIBLTEST=HAS=TWO=") eq "HAS=TWO=") puts("bad 5.7"); + unless (getenv("LIBLTEST") eq "HAS=TWO=") puts("bad 5.8"); + unless (putenv("LIBLTEST=HAS=TWO==") eq "HAS=TWO==") puts("bad 5.9"); + unless (getenv("LIBLTEST") eq "HAS=TWO==") puts("bad 5.10"); + unless (putenv("LIBLTEST==") eq "=") puts("bad 5.11"); + unless (getenv("LIBLTEST") eq "=") puts("bad 5.12"); + unless (putenv("LIBLTEST=====") eq "====") puts("bad 5.13"); + unless (getenv("LIBLTEST") eq "====") puts("bad 5.14"); + + /* Check bad putenv format. */ + if (defined(putenv("BAD"))) puts("bad 6.1"); + if (defined(putenv(""))) puts("bad 6.2"); + fmt = "BAD=%s"; + if (defined(putenv(fmt))) puts("bad 6.3"); +} +env1(); +} -output {} + +test exists-1 {test exists} -setup { + set fname1 [makeFile {test} exists_test1 .] + set fname2 [makeFile {test} {exists test 2} .] + set fname3 [makeFile {test} existstest\{3\} .] + if {!$_windows} {set fname4 [makeFile {test} {exists test \"\'4} .]} +} -body { +#lang L --line=1 +void exists1(string nm) +{ + unless (exists(nm)) puts("bad 1"); + +} +if (exists("does-not-exist")) puts("bad 2"); +#lang tcl +exists1 $fname1 +exists1 $fname2 +exists1 $fname3 +if {!$_windows} {exists1 $fname4} +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 + if {!$_windows} {removeFile $fname4} +} -output {} + +test fclose-1 {test fclose errors} -body { +#lang L --line=1 +void fclose1() +{ + FILE f = "bad"; + + fclose(f); + unless (stdio_lasterr eq 'can not find channel named "bad"') { + puts("bad 1"); + } +} +fclose1(); +} -output {} + +test fclose-2 {test fclose type errors} -body { +#lang L --line=1 +void fclose2() +{ + fclose("not a FILE"); +} +} -returnCodes error -match regexp -result {.*3: L Error: parameter 1 has incompatible type +} + +test file-1 {test fopen/fclose/fprintf} -body { +#lang L --line=1 +void file1(string nm) +{ + FILE f; + + f = fopen(nm, "w"); + unless (defined(f)) puts("bad 1.1"); + unless (fprintf(f, "file-1 test\n") == 0) puts("bad 1.2"); + unless (fclose(f) == 0) puts("bad 1.3"); + + unlink(nm); +} +file1("filetest1"); +file1("file test 2"); +file1("file test {3}"); +unless (platform() eq "windows") file1("file test \"4\'"); +} -output {} + +test file-2 {test fopen/fclose/fprintf run-time errors} -setup { + file delete -force "does not exist" +} -body { +#lang L --line=1 +void file2() +{ + FILE f; + string fmt; + + if (defined(f = fopen("does not exist", "rw"))) puts("bad 1"); + + unless (fclose(f) == -1) puts("bad 2"); + unless (fprintf(f, "bad") == -1) puts("bad 4"); + + unless (f = fopen("file2tst", "w")) puts("bad 4.1"); + fmt = "%s"; + unless (fprintf(f, fmt) == -1) puts("bad 4.2"); + fclose(f); + unlink("file2tst"); +} +file2(); +} -output {} + +test file-2.1 {test fprintf compile-time errors} -body { +#lang L --line=1 +void file2_1() +{ + FILE f; + + fprintf(f, "%s"); +} +file2_1(); +} -returnCodes error -match regexp -result {.*5: L Warning: bad format specifier +} + +test file-3 {test fprintf type errors} -body { +#lang L --line=1 +void file3() +{ + fprintf("not a FILE", "%s", "bad"); +} +} -returnCodes error -match regexp -result {.*3: L Error: parameter 1 has incompatible type +} + +test fopen-1 {test fopen errors} -body { +#lang L --line=1 +void fopen1() +{ + if (defined(fopen("bad1", "r"))) puts("bad 1"); + unless (stdio_lasterr eq 'couldn\'t open "bad1": no such file or directory') { + puts("bad 2"); + } + if (defined(fopen("bad2", "rv"))) puts("bad 3"); + if (defined(fopen("bad3", "vrv"))) puts("bad 4"); +} +fopen1(); +} -errorOutput {fopen(bad2, r) = couldn't open "bad2": no such file or directory +fopen(bad3, r) = couldn't open "bad3": no such file or directory +} -output {} + +test fprintf-1 {test fprintf compile-time errors} -body { +#lang L --line=1 +void fprintf1() +{ + fprintf(stderr, "%s"); +} +fprintf1(); +} -returnCodes error -match regexp -result {.*3: L Warning: bad format specifier +} + +test fprintf-2 {test fprintf run-time errors} -body { +#lang L +void fprintf2() +{ + string fmt = "%s"; + + unless (fprintf(stderr, fmt) == -1) puts("bad 1"); +} +fprintf2(); +} -output {} + +test Fprintf-1 {test Fprintf} -body { +#lang L --line=1 +void Fprintf1() +{ + FILE f; + + unless (Fprintf("/this/is/bad", "bad") < 0) puts("bad 1.1"); + + unless (Fprintf("fprintf-tst", "hello Fprintf\n") == 0) puts("bad 2.1"); + unless (f = fopen("fprintf-tst", "r")) puts("bad 2.2"); + unless (<f> eq "hello Fprintf") puts("bad 2.3"); + if (<f>) puts("bad 2.4"); + fclose(f); + + unless (Fprintf("fprintf-tst", "%s %s %s", "a", "b", "c") == 0) { + puts("bad 3.1"); + } + unless (f = fopen("fprintf-tst", "r")) puts("bad 3.2"); + unless (<f> eq "a b c") puts("bad 3.3"); + if (<f>) puts("bad 3.4"); + fclose(f); + + unlink("fprintf-tst"); +} +Fprintf1(); +} -output {} + +test Fprintf-2 {test Fprintf compile-time errors} -body { +#lang L --line=1 +void Fprintf2() +{ + Fprintf("fname", "%s"); +} +Fprintf2(); +} -cleanup { + removeFile "fname" +} -returnCodes error -match regexp -result {.*3: L Warning: bad format specifier +} + +test Fprintf-2-1 {test Fprintf run-time errors} -body { +#lang L +void Fprintf2_1() +{ + string fmt = "%s"; + unless (Fprintf("fname", fmt) == -1) puts("bad 1"); +} +Fprintf2_1(); +} -cleanup { + removeFile "fname" +} -output {} + +test ftype-1 {test ftpye} -setup { + set fname1 [makeFile {test} ftype_test1 .] + set fname2 [makeFile {test} {ftype test 2} .] + set fname3 [makeFile {test} ftypetest\{3\} .] + if {!$_windows} {set fname4 [makeFile {test} {ftype test \"\'4} .]} + set fdirname1 ftypedir1 + set fdirname2 {ftype dir 2} + set fdirname3 ftypedir\{3\} + if {!$_windows} {set fdirname4 {ftypedir "'4}} + # '" + file mkdir $fdirname1 + file mkdir $fdirname2 + file mkdir $fdirname3 + if {!$_windows} {file mkdir $fdirname4} +} -body { +#lang L --line=1 +void ftype1(string nm, string t) +{ + unless (ftype(nm) eq t) puts("bad 1"); +} +#lang tcl +ftype1 $fname1 file +ftype1 $fname2 file +ftype1 $fname3 file +if {!$_windows} {ftype1 $fname4 file} +ftype1 $fdirname1 directory +ftype1 $fdirname2 directory +ftype1 $fdirname3 directory +if {!$_windows} {ftype1 $fdirname4 directory} +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 + if {!$_windows} {removeFile $fname4} + file delete -force $fdirname1 + file delete -force $fdirname2 + file delete -force $fdirname3 + if {!$_windows} {file delete -force $fdirname4} +} -output {} + +test ftype-2 {test ftype errors} -setup { + file delete -force "does not exist" +} -body { +#lang L --line=1 +void ftype2() +{ + if (defined(ftype("does not exist"))) puts("bad 1"); +} +ftype2(); +} -output {} + +test getdir-1 {test getdir} -setup { + file mkdir getdirtest + set fname1 [makeFile {test1} f1 getdirtest] + set fname2 [makeFile {test2} f2 getdirtest] + set fname3 [makeFile {test3} f3 getdirtest] + file delete -force "does not exist" +} -body { +#lang L --line=1 +void getdir1() +{ + string dirs[]; + + dirs = getdir("getdirtest", "*"); + unless (length(dirs) == 3) puts("bad 1.1"); + unless (dirs[0] eq "getdirtest/f1") puts("bad 1.2"); + unless (dirs[1] eq "getdirtest/f2") puts("bad 1.3"); + unless (dirs[2] eq "getdirtest/f3") puts("bad 1.4"); + + dirs = getdir("getdirtest", "f2"); + unless (length(dirs) == 1) puts("bad 2.1"); + unless (dirs[0] eq "getdirtest/f2") puts("bad 2.2"); + + dirs = getdir("getdirtest", "*3"); + unless (length(dirs) == 1) puts("bad 3.1"); + unless (dirs[0] eq "getdirtest/f3") puts("bad 3.2"); + + dirs = getdir("getdirtest"); + unless (length(dirs) == 3) puts("bad 4.1"); + unless (dirs[0] eq "getdirtest/f1") puts("bad 4.2"); + unless (dirs[1] eq "getdirtest/f2") puts("bad 4.3"); + unless (dirs[2] eq "getdirtest/f3") puts("bad 4.4"); + + dirs = getdir("does not exist", "*"); + unless (length(dirs) == 0) puts("bad 10.1"); + + if (defined(getdir("dir", "*", "too-many-args"))) puts("bad 11.1"); + + /* getdir should strip any leading ./ now */ + cd("getdirtest"); + dirs = getdir("."); + unless (length(dirs) == 3) puts("bad 12.1"); + unless (dirs[0] eq "f1") puts("bad 12.2"); + unless (dirs[1] eq "f2") puts("bad 12.3"); + unless (dirs[2] eq "f3") puts("bad 12.4"); + cd(".."); +} +getdir1(); +} -cleanup { + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 + file delete -force getdirtest +} -output {} + +test getdirx-1 {test getdirx} -setup { + file delete -force getdirx1-tst + file mkdir getdirx1-tst +} -body { +#lang L --line=1 +int getdirx1_compar(dirent d1, dirent d2) +{ + if (d1.name < d2.name) { + return (-1); + } else if (d1.name > d2.name) { + return (1); + } else { + return (0); + } +} +void getdirx1() +{ + dirent files[]; + + cd("getdirx1-tst"); + + if (mkdir("files-only")) puts("bad 1.1"); + cd("files-only"); + Fprintf("f2", "file2"); + Fprintf(".h1", "hidden1"); + Fprintf("f1", "file1"); + cd(".."); + + if (mkdir("dirs-only")) puts("bad 2.1"); + cd("dirs-only"); + mkdir(".hd1"); + mkdir("d2"); + mkdir("d1"); + cd(".."); + + if (mkdir("mix")) puts("bad 3.1"); + cd("mix"); + mkdir(".hd2"); + mkdir("d6"); + mkdir("d5"); + Fprintf(".h2", "hidden2"); + Fprintf("f6", "file6"); + Fprintf("f5", "file5"); + cd(".."); + + files = sort(command: &getdirx1_compar, getdirx(".")); + unless (length(files) == 5) puts("bad 10.1"); + unless (files[0] == {".","directory",1}) puts("bad 10.2"); + unless (files[1] == {"..","directory",1}) puts("bad 10.3"); + unless (files[2] == {"dirs-only","directory",0}) puts("bad 10.4"); + unless (files[3] == {"files-only","directory",0}) puts("bad 10.5"); + unless (files[4] == {"mix","directory",0}) puts("bad 10.6"); + + files = sort(command: &getdirx1_compar, getdirx("dirs-only")); + unless (length(files) == 5) puts("bad 11.1"); + unless (files[0] == {".","directory",1}) puts("bad 11.2"); + unless (files[1] == {"..","directory",1}) puts("bad 11.3"); + unless (files[2] == {".hd1","directory",1}) puts("bad 11.4"); + unless (files[3] == {"d1","directory",0}) puts("bad 11.5"); + unless (files[4] == {"d2","directory",0}) puts("bad 11.6"); + + files = sort(command: &getdirx1_compar, getdirx("files-only")); + unless (length(files) == 5) puts("bad 12.1"); + unless (files[0] == {".","directory",1}) puts("bad 12.2"); + unless (files[1] == {"..","directory",1}) puts("bad 12.3"); + unless (files[2] == {".h1","file",1}) puts("bad 12.4"); + unless (files[3] == {"f1","file",0}) puts("bad 12.5"); + unless (files[4] == {"f2","file",0}) puts("bad 12.6"); + + files = sort(command: &getdirx1_compar, getdirx("mix")); + unless (length(files) == 8) puts("bad 13.1"); + unless (files[0] == {".","directory",1}) puts("bad 13.2"); + unless (files[1] == {"..","directory",1}) puts("bad 13.3"); + unless (files[2] == {".h2","file",1}) puts("bad 13.7"); + unless (files[3] == {".hd2","directory",1}) puts("bad 13.4"); + unless (files[4] == {"d5","directory",0}) puts("bad 13.5"); + unless (files[5] == {"d6","directory",0}) puts("bad 13.6"); + unless (files[6] == {"f5","file",0}) puts("bad 13.8"); + unless (files[7] == {"f6","file",0}) puts("bad 13.9"); + + // error case + stdio_lasterr = ""; + if (defined(getdirx("does-not-exist"))) puts("bad 20.1"); + unless ((stdio_lasterr =~ /no such file/i) || + (stdio_lasterr =~ /cannot find/i)) { + puts("bad 20.2: '${stdio_lasterr}'"); + } + + cd(".."); +} +getdirx1(); +} -cleanup { + file delete -force getdirx1-tst +} -output {} + +test getopt-1 {test getopt} -body { +#lang L --line=1 +private string doit(string av[], string opts, string lopts[]) +{ + string c, s = ""; + + getoptReset(); + while (defined(c = getopt(av, opts, lopts))) { + if (c eq "") { + s .= "<${optopt}|err>"; + break; + } else { + if (optarg) { + s .= "<${c}|${optarg}|${optind}>"; + } else { + s .= "<${c}|#|${optind}>"; + } + } + } + return (s); +} +void getopt1() +{ + string s; + + /* + * This could be more exhaustive. It covers cases only for a + * single arg. + */ + + s = doit({}, "", {}); + unless (s eq "") puts("bad 1.1"); + + /* opt a */ + s = doit({"a.out","-a","x"}, "a", {}); + unless (s eq "<a|#|2>") puts("bad 3.1"); + + /* opt a: */ + s = doit({"a.out","-a","x"}, "a:", {}); + unless (s eq "<a|x|3>") puts("bad 4.1"); + s = doit({"a.out","-ax"}, "a:", {}); + unless (s eq "<a|x|2>") puts("bad 4.2"); + s = doit({"a.out","-a"}, "a:", {}); + unless (s eq "<a|err>") puts("bad 4.3"); + s = doit({"a.out","-a","-b"}, "a:", {}); + unless (s eq "<a|err>") puts("bad 4.4"); + + /* opt a; */ + s = doit({"a.out","-ax"}, "a;", {}); + unless (s eq "<a|x|2>") puts("bad 5.1"); + s = doit({"a.out","-a","x"}, "a;", {}); + unless (s eq "<a|err>") puts("bad 5.2"); + s = doit({"a.out","-a"}, "a;", {}); + unless (s eq "<a|err>") puts("bad 5.3"); + + /* opt a| */ + s = doit({"a.out","-ax"}, "a|", {}); + unless (s eq "<a|x|2>") puts("bad 6.1"); + s = doit({"a.out","-a","x"}, "a|", {}); + unless (s eq "<a|#|2>") puts("bad 6.2"); + + /* longopt long */ + s = doit({"a.out","--long", "x"}, "", {"long"}); + unless (s eq "<long|#|2>") puts("bad 7.1"); + + /* longopt long: */ + s = doit({"a.out","--long", "x"}, "", {"long:"}); + unless (s eq "<long|x|3>") puts("bad 8.1"); + s = doit({"a.out","--long=x"}, "", {"long:"}); + unless (s eq "<long|x|2>") puts("bad 8.2"); + s = doit({"a.out","--long:x"}, "", {"long:"}); + unless (s eq "<long|x|2>") puts("bad 8.2.1"); + s = doit({"a.out","--long"}, "", {"long:"}); + unless (s eq "<|err>") puts("bad 8.3"); + + /* longopt long; */ + s = doit({"a.out","--long", "x"}, "", {"long;"}); + unless (s eq "<|err>") puts("bad 9.1"); + s = doit({"a.out","--long=x"}, "", {"long;"}); + unless (s eq "<long|x|2>") puts("bad 9.2"); + s = doit({"a.out","--long"}, "", {"long;"}); + unless (s eq "<|err>") puts("bad 9.3"); + + /* longopt long| */ + s = doit({"a.out","--long", "x"}, "", {"long|"}); + unless (s eq "<long|#|2>") puts("bad 10.1"); + s = doit({"a.out","--long=x"}, "", {"long|"}); + unless (s eq "<long|x|2>") puts("bad 10.2"); + s = doit({"a.out","--long"}, "", {"long|"}); + unless (s eq "<long|#|2>") puts("bad 10.3"); +} +getopt1(); +} -output {} + +test getopt-2 {test getopt optind} -body { +#lang L +void getopt2() +{ + string av[], c, s; + + av = { "prog", "-a", "-b", "-c" }; + s = ""; + + /* This tests that changing optind works as expected. */ + + getoptReset(); + if (optind) puts("bad 0.1"); + unless (optopt == "") puts("bad 0.2"); + if (optarg) puts("bad 0.3"); + + while (c = getopt(av, "abc", undef)) { + switch (c) { + case "a": + ++optind; + s .= c; + break; + case /[bc]/: + s .= c; + break; + } + } + unless (s == "ac") puts("bad 1.1 '${s}'"); + unless (optind == 4) puts("bad 1.2"); +} +getopt2(); +} -output {} + +test getpid-1 {test getpid} -body { +#lang L --line=1 +void getpid1() +{ + unless (getpid() == pid()) puts("bad"); +} +getpid1(); +} -output {} + +test here-1 {test here} -body { +#lang L --line=1 +void here1func() { + here(); +} +void here1() +{ + here(); + here(); here(); + here1func(); + + here(); +} +here1(); +here(); +} -match regexp -errorOutput {here1\(\) in l-libl.test:6 +here1\(\) in l-libl.test:7 +here1\(\) in l-libl.test:7 +here1func\(\) in l-libl.test:2 +here1\(\) in l-libl.test:10 +\d+%l_toplevel\(\) in l-libl.test:13 +} -output {} + +test here-2 {test here errors} -body { +#lang L --line=1 +void here2() +{ + here("bad"); +} +} -returnCodes error -match regexp -result {.*3: L Error: here\(\) takes no arguments +} + +test here-3 {test here with #includes} -setup { + set fname1 [makeFile {here(); +#include "here3b.l" +here(); + } here3a.l [file dirname [info script]]] + set fname2 [makeFile {here(); +#include "here3c.l" +here(); + } here3b.l] + set fname3 [makeFile {here(); + } here3c.l] +} -body { +#lang L --line=1 +#include "here3a.l" +void here3() +{ + here(); +} +here3(); +} -match regexp -errorOutput {\d+%l_toplevel\(\) in here3a.l:1 +\d+%l_toplevel\(\) in here3b.l:1 +\d+%l_toplevel\(\) in here3c.l:1 +\d+%l_toplevel\(\) in here3b.l:3 +\d+%l_toplevel\(\) in here3a.l:3 +here3\(\) in l-libl.test:4 +} -output {} + +test is-1 {test isdir/isreg/islink} -setup { + set fdirname1 istestdir1 + set fdirname2 {is test dir2} + set fdirname3 istestdir\{3\} + if {!$_windows} {set fdirname4 {istestdir "' 4}} + # '" + file mkdir $fdirname1 + file mkdir $fdirname2 + file mkdir $fdirname3 + if {!$_windows} {file mkdir $fdirname4} + set fname1 [makeFile {test} istestfile1 .] + set fname2 [makeFile {test} {is test file 2} .] + set fname3 [makeFile {test} istestfile\{3\} .] + if {!$_windows} {set fname4 [makeFile {test} {is test file \"\'4} .]} + if {!$_windows} { + set flink1 islink1 + set flink2 {is link 2} + set flink3 islink\{3\} + set flink4 {is link \"\'4} + file delete -force $flink1 $flink2 $flink3 $flink4 + file link $flink1 $fname1 + file link $flink2 $fname1 + file link $flink3 $fname1 + file link $flink4 $fname1 + } else { + set flink1 "" + set flink2 "" + set flink3 "" + set flink4 "" + } + file delete -force "does not exist" +} -body { +#lang L --line=1 +void is1(string dirnm, string filenm, string linknm) +{ + unless (isdir(dirnm)) puts("bad 3.1"); + unless (isreg(filenm)) puts("bad 4.1"); + unless (platform() eq "windows") { + unless (islink(linknm)) puts("bad 5.1"); + } + + if (isdir("does not exist")) puts("bad 10.1"); + if (isreg("does not exist")) puts("bad 10.2"); + unless (platform() eq "windows") { + if (islink("does not exist")) puts("bad 10.3"); + } +} +#lang tcl +is1 $fdirname1 $fname1 $flink1 +is1 $fdirname2 $fname2 $flink2 +is1 $fdirname3 $fname3 $flink3 +if {!$_windows} {is1 $fdirname4 $fname4 $flink4} +} -cleanup { + if {!$_windows} {file delete -force $flink1 $flink2 $flink3 $flink4} + file delete -force $fdirname1 $fdirname2 $fdirname3 + if {!$_windows} {file delete -force $fdirname4} + removeFile $fname1 + removeFile $fname2 + removeFile $fname3 + if {!$_windows} {removeFile $fname4} +} -output {} + +test lc-1 {test lc} -body { +#lang L --line=1 +void lc1() +{ + unless (lc("abcde") eq "abcde") puts("bad 1"); + unless (lc("ABCDE") eq "abcde") puts("bad 2"); + unless (lc("AbCdE") eq "abcde") puts("bad 3"); + unless (lc("") eq "") puts("bad 4"); +} +lc1(); +} -output {} + +test link-1 {test link} -setup { + set fname [makeFile {123456} linktest .] + file delete -force linktest2 +} -body { +#lang L --line=1 +void link1() +{ + /* Error if target does not exist. */ + unless (link("link", "does not exist") == -1) puts("bad 1.1"); + + /* + * This isn't supported on all platforms, so if it returns + * failure, don't check for the link. + */ + if (link("linktest", "linktest2") == 0) { + unless (exists("linktest2")) puts("bad 2.1"); + unless (size("linktest") == size("linktest2")) puts("bad 2.2"); + } +} +link1(); +} -cleanup { + file delete -force linktest linktest2 +} -output {} + +test mkdir-1 {test mkdir} -setup { + set fname [makeFile {test} mkdir_file .] +} -body { +#lang L --line=1 +void mkdir1() +{ + string f1 = "mkdir1"; + string f2 = "mk dir 2"; + string f3 = "mkdir{3}"; + string f4 = "mkdir\"\'4"; + + unless (mkdir(f1) == 0) puts("bad 1.1"); + unless (mkdir(f2) == 0) puts("bad 1.2"); + unless (mkdir(f3) == 0) puts("bad 1.3"); + unless (platform() eq "windows") { + unless (mkdir(f4) == 0) puts("bad 1.4"); + } + + unless (ftype(f1) eq "directory") puts("bad 2.1"); + unless (ftype(f2) eq "directory") puts("bad 2.2"); + unless (ftype(f3) eq "directory") puts("bad 2.3"); + unless (platform() eq "windows") { + unless (ftype(f4) eq "directory") puts("bad 2.4"); + } + + unlink(f1); + unlink(f2); + unlink(f3); + unless (platform() eq "windows") { + unlink(f4); + } + + /* Check that the entire path is created. */ + unless (mkdir("path/to/the/file") == 0) puts("bad 3.1"); + unless (ftype("path") eq "directory") puts("bad 3.2"); + unless (ftype("path/to") eq "directory") puts("bad 3.3"); + unless (ftype("path/to/the") eq "directory") puts("bad 3.4"); + unless (ftype("path/to/the/file") eq "directory") puts("bad 3.5"); + unlink("path/to/the/file"); + unlink("path/to/the"); + unlink("path/to"); + unlink("path"); + + /* Error if file already exists as a regular file. */ + unless (mkdir("mkdir_file") == -1) puts("bad 4.1"); +} +mkdir1(); +} -cleanup { + file delete -force $fname +} -output {} + +test mtime-1 {test mtime} -setup { + set fname [makeFile {test} mtime_file .] + file delete -force "does not exist" +} -body { +#lang L --line=1 +void mtime1() +{ + /* + * Check the success is returned. Not sure how to check that + * the return value is actually correct. + */ + unless (mtime("mtime_file") > 0) puts("bad 1"); + + /* Check error case. */ + unless (mtime("does not exist") == 0) puts("bad 2"); +} +mtime1(); +} -cleanup { + file delete -force $fname +} -output {} + +test normalize-1 {test normalize} -body { +#lang L --line=1 +void normalize1() +{ + unless (normalize("") eq "") puts("bad 1"); + unless (normalize("./x") eq (pwd() . "/x")) puts("bad 2"); +} +normalize1(); +} -output {} + +test ord-1 {test ord} -body { +#lang L --line=1 +void ord1() +{ + string s; + + unless (ord("A") == 65) puts("bad 1"); + unless (ord("BCD") == 66) puts("bad 2"); + unless (ord("") == -1) puts("bad 3"); + s = ""; + unless (ord(s) == -1) puts("bad 4"); +} +ord1(); + } -output {} + +test pclose-1 {test pclose errors} -body { +#lang L --line=1 +void pclose1() +{ + FILE fd; + STATUS st; + + pclose(); + pclose(0, undef, 0); + pclose(fd, st); + pclose("not a FILE"); +} +} -returnCodes error -match regexp -result {.*6: L Error: not enough arguments for function pclose +.*7: L Error: too many arguments for function pclose +.*8: L Error: parameter 2 has incompatible type +.*9: L Error: parameter 1 has incompatible type +} + +test pclose-2 {test pclose with errors} -body { +#lang L --line=1 +void pclose2() +{ + FILE fd; + string cmd; + STATUS st; + + cmd = "perl -e 'print STDERR \"to err\"; exit 0;'"; + fd = popen(cmd, "r", undef); + fconfigure(fd, blocking: 0); + + pclose(fd, &st); + puts(stdio_lasterr); +} +pclose2(); +} -output {to err +} + +test popen-1 {test popen/pclose} -setup { + set fname [makeFile "line1\nline2\nline3\n" popen_file .] +} -body { +#lang L --line=1 +void popen1() +{ + int i; + FILE f; + string buf; + STATUS st; + + /* There are more popen() tests in system1() later on. */ + + f = popen("cat popen_file", "r"); + unless (defined(f)) puts("bad 1"); + + i = 1; + while (defined(buf = <f>)) { + unless (buf eq "line${i}") printf("bad i=%d\n", i); + ++i; + } + unless (i == 4) puts("bad 2"); + + unless (pclose(f, &st) == 0) puts("bad 3.1"); + unless (st.exit == 0) puts("bad 3.2"); + + /* Check error case. */ + f = popen("what-the-heck bad-command", "r"); + if (defined(f)) puts("bad 10"); + + /* Check passing the command as an argv[]. */ + + f = popen({"cat","popen_file"}, "r"); + unless (defined(f)) puts("bad 11"); + i = 1; + while (defined(buf = <f>)) { + unless (buf eq "line${i}") printf("bad 2 i=%d\n", i); + ++i; + } + unless (i == 4) puts("bad 12"); + + unless (pclose(f, &st) == 0) puts("bad 13.1"); + unless (st.exit == 0) puts("bad 13.2"); +} +popen1(); +} -output {} + +test popen-2 {test popen errors} -body { +#lang L --line=1 +void popen2() +{ + if (defined(popen("bad-cmd1", "r"))) puts("bad 1"); + unless (stdio_lasterr =~ /couldn\'t execute \"bad cmd1\"/) { + puts("bad 2"); + } + + if (defined(popen("bad-cmd2", "rv"))) puts("bad 5"); + if (defined(popen("bad-cmd3", "vrv"))) puts("bad 6"); +} +popen2(); +} -match regexp -errorOutput {popen\(bad-cmd2, r\) = couldn't execute "bad-cmd2".* +popen\(bad-cmd3, r\) = couldn't execute "bad-cmd3".* +} -output {} + +test popen-3 {test popen stderr} -setup { + set fname [makeFile { + string cmd; + FILE f; + + cmd = "perl -e 'print \"to out\"; print STDERR \"to err\";'"; + f = popen(cmd, "r"); + unless (defined(f)) die("popen"); + unless (<f> eq "to out") puts("bad stdout"); + pclose(f); + } popen3.l] +} -body { +#lang L --line=1 +/* + * Some contortions here to run tclsh on popen3.l (above) which prints + * to stderr, so we can capture stderr and check it. Otherwise, + * tcltest sees anything to stderr as an error and fails the test. + */ +void popen3() +{ + int ret; + string cmd = "\"${eval('interpreter')}\" popen3.l"; + string err[], out[]; + + ret = system(cmd, undef, &out, &err); + unless (defined(ret)) puts("bad status ${ret}"); + unless (length(out) == 0) puts("bad 2"); + unless (err[0] eq "to err") puts("bad 3"); +} +popen3(); +} -output {} + +test popen-4 {test popen stderr re-direction} -body { +#lang L --line=1 +void popen4() +{ + string cmd; + FILE f; + + cmd = "perl -e 'print \"to out\"; print STDERR \"to err\";' 2>p4err"; + + f = popen(cmd, "r"); + unless (defined(f)) puts("bad 1.1"); + unless (<f> eq "to out") puts("bad 1.2"); + pclose(f); + + f = fopen("p4err", "r"); + unless (defined(f)) puts("bad 2.1"); + unless (<f> eq "to err") puts("bad 2.2"); + fclose(f); +} +popen4(); +} -cleanup { + removeFile "p4err" +} -output {} + +test popen-5.1 {test popen stderr callback 1} -body { +#lang L --line=1 +string p51cmd = <<'END' +perl -e 'print STDERR "to err1\n"; + print "to out\n"; + print STDERR "to err2\n";' +END +int p51cb_lines = 0; +int p51cb_eof = 0; +void p51cb(string cmd, FILE f) +{ + string s; + + unless (cmd == p51cmd) puts("bad 2.1"); + + if (Chan_names(f) == "") puts("bad 2.1.1"); + while (s = <f>) { + switch (++p51cb_lines) { + case 1: + unless (s == "to err1") puts("bad 2.2 ${s}"); + break; + case 2: + unless (s == "to err2") puts("bad 2.3 ${s}"); + break; + default: + puts("bad 2.4"); + break; + } + } + if (eof(f)) ++p51cb_eof; +} +void popen5_1() +{ + FILE f; + + /* + * This test tries to get the popen()'d process to complete + * before we call pclose(); + */ + + f = popen(p51cmd, "r", &p51cb); + unless (f) puts("bad 1.1"); + unless (<f> == "to out") puts("bad 1.2"); + /* + * Let the process complete so we get a call to the p51cb where + * EOF if seen, then call pclose(). + */ + sleep(1); + update(); + pclose(f); + if (<f>) puts("bad 1.2.1"); + unless (p51cb_lines == 2) puts("bad 1.3 ${p51cb_lines}"); + unless (p51cb_eof) puts("bad 1.4 ${p51cb_eof}"); +} +popen5_1(); +} -output {} + +test popen-5.2 {test popen stderr callback 2} -body { +#lang L --line=1 +string p52cmd = <<'END' +perl -e 'print STDERR "to err1\n"; + print "to out\n"; + print STDERR "to err2\n";' +END +int p52cb_lines = 0; +int p52cb_eof = 0; +void p52cb(string cmd, FILE f) +{ + string s; + + unless (cmd == p52cmd) puts("bad 2.1"); + + if (Chan_names(f) == "") puts("bad 2.1.1"); + while (s = <f>) { + switch (++p52cb_lines) { + case 1: + unless (s == "to err1") puts("bad 2.2 ${s}"); + break; + case 2: + unless (s == "to err2") puts("bad 2.3 ${s}"); + // Delay so pclose() below is called before we exit. + sleep(1); + break; + default: + puts("bad 2.4"); + break; + } + } + if (eof(f)) ++p52cb_eof; +} +void popen5_2() +{ + FILE f; + + /* + * This test tries to call pclose() before the popen()'d + * process exits. + */ + + f = popen(p52cmd, "r", &p52cb); + unless (f) puts("bad 1.1"); + unless (<f> == "to out") puts("bad 1.2"); + pclose(f); + if (<f>) puts("bad 1.2.1"); + unless (p52cb_lines == 2) puts("bad 1.3 ${p52cb_lines}"); + unless (p52cb_eof) puts("bad 1.4 ${p52cb_eof}"); +} +popen5_2(); +} -output {} + +test popen-5.3 {test stderr callback that closes the pipe} -body { +#lang L --line=1 +/* + * This tests a stderr callback that closes the read end of + * the pipe. It used to cause lib L to thrown an exception. + */ +int popen_5_3_called = 0; +void popen_5_3_cb(_argused string cmd, FILE f) +{ + ++popen_5_3_called; + close(f); +} +void popen_5_3() +{ + FILE f; + string cmd = "perl -e 'print STDERR \"to err\";'"; + + f = popen(cmd, "r", &popen_5_3_cb); + unless (f) puts("bad 1.1"); + if (pclose(f)) puts("bad 1.2"); + unless (popen_5_3_called == 1) puts("bad 1.3: ${popen_5_3_called}"); +} +popen_5_3(); +} -output {} + +test popen-6 {test popen stderr ignore} -setup { + set fname [makeFile { + string cmd; + FILE f; + + cmd = "perl -e 'print \"to out\"; print STDERR \"to err\";'"; + f = popen(cmd, "r", undef); + unless (defined(f)) die("popen"); + unless (<f> eq "to out") puts("bad stdout"); + pclose(f); + } popen6.l] +} -body { +#lang L --line=1 +/* + * This is like popen3() but stderr should be ignored. + */ +void popen6() +{ + int ret; + string tclsh = eval('interpreter'); + string err[], out[]; + + ret = system({tclsh, "popen6.l"}, undef, &out, &err); + unless (ret == 0) puts("bad status ${ret}"); + if (out) puts("bad 2"); + if (err) puts("bad 3: ${err}"); +} +popen6(); +} -output {} + +test popen-7 {test popen type checking} -body { +#lang L --line=1 +void popen7_bad1(); +void popen7_bad2(string cmd); +void popen7_bad3(FILE f); +int popen7_bad4(string cmd, FILE f); +int popen7_bad5(string cmd, string f); +void popen7_good(string cmd, string f); +void popen_7() +{ + popen("cmd", "r", popen7_bad1); + popen("cmd", "r", popen7_bad2); + popen("cmd", "r", popen7_bad3); + popen("cmd", "r", popen7_bad4); + popen("cmd", "r", popen7_bad5); + + popen(); + popen("cmd", "mode", popen7_good, "too many"); + + popen(123, "mode"); + popen("cmd", 123); + popen("cmd", 123, popen7_good); +} +popen_7(); +} -returnCodes error -match regexp -result {.*9: L Error: illegal type for stderr callback +.*10: L Error: illegal type for stderr callback +.*11: L Error: illegal type for stderr callback +.*12: L Error: illegal type for stderr callback +.*13: L Error: illegal type for stderr callback +.*15: L Error: incorrect # args to popen +.*16: L Error: incorrect # args to popen +.*18: L Error: first arg to popen must be string or string array +.*19: L Error: expected type string but got int in second arg to popen +.*20: L Error: expected type string but got int in second arg to popen +} + +test printf-1 {test printf} -body { +#lang L --line=1 +void printf1() +{ + printf("Test1\n"); + printf("Test%s\n", "2"); + printf("Test%d - last one\n", 3); +} +printf1(); +} -output {Test1 +Test2 +Test3 - last one +} + +test printf-2 {test that we exit silently on broken stdout pipe} -setup { + set fname [makeFile { + while (1) puts("printf2 test"); + } printf2.l] +} -body { +#lang L --line=1 +void printf2() +{ + int ret; + string cmd, err[], out[]; + + /* + * This runs the printf2.l script (above) in a separate + * instance of the L interpreter and pipes it to a perl script + * that reads only the first two lines and then exits. L + * should ignore the broken output pipe error and silently + * exit. + */ + cmd = "\"${eval('interpreter')}\" printf2.l | perl -e '$_=<>;$_=<>'"; + ret = system(cmd, undef, &out, &err); + unless (defined(ret)) perror("system"); + unless (length(out) == 0) puts("bad 2 ${out}"); + unless (length(err) == 0) puts("bad 3 ${err}"); +} +printf2(); +} -output {} + +test printf-3 {test printf run-time errors} -body { +#lang L --line=1 +void printf3() +{ + string fmt = "%s"; + + unless (printf(fmt) == -1) puts("bad 1"); +} +printf3(); +} -output {} + +test printf-3.1 {test printf compile-time errors} -body { +#lang L --line=1 +void printf3_1() +{ + printf("%s"); +} +printf3_1(); +} -returnCodes error -match regexp -result {.*3: L Warning: bad format specifier +} + +test putenv-1 {test putenv errors} -body { +#lang L --line=1 +void putenv1() +{ + putenv("BAD=%s"); +} +putenv1(); +} -returnCodes error -match regexp -result {.*3: L Warning: bad format specifier +} + +test read-1 {test read} -setup { + set fname [makeFile "012345678901234567\n" read_test .] +} -body { +#lang L --line=1 +void read1() +{ + int n; + FILE f; + string buf; + + f = fopen("read_test", "r"); + unless (defined(f)) puts("bad 1.1"); + + buf = undef; + n = read(f, &buf, 5); + unless (defined(buf)) puts("bad 2.1"); + unless ((n == 5) && (buf eq "01234")) puts("bad 2.2"); + + buf = undef; + n = read(f, &buf, 5); + unless (defined(buf)) puts("bad 2.3"); + unless ((n == 5) && (buf eq "56789")) puts("bad 2.4"); + + buf = undef; + n = read(f, &buf, 5); + unless (defined(buf)) puts("bad 2.5"); + unless ((n == 5) && (buf eq "01234")) puts("bad 2.6"); + + buf = undef; + n = read(f, &buf, 5); + unless (defined(buf)) puts("bad 2.7"); + unless ((n == 4) && (buf eq "567\n")) puts("bad 2.8"); + + n = read(f, &buf, 1); + unless (n == -1) puts("bad 2.9"); + n = read(f, &buf, 1); + unless (n == -1) puts("bad 2.10"); + + fclose(f); + + f = fopen("read_test", "r"); + unless (defined(f)) puts("bad 3.1"); + + buf = undef; + n = read(f, &buf, -1); + unless (defined(buf)) puts("bad 4.1"); + unless ((n == 19) && (buf eq "012345678901234567\n")) puts("bad 4.2"); + + fclose(f); + + /* Check that last arg is optional. */ + + f = fopen("read_test", "r"); + unless (defined(f)) puts("bad 5.1"); + buf = undef; + n = read(f, &buf); + unless (defined(buf)) puts("bad 5.2"); + unless ((n == 19) && (buf eq "012345678901234567\n")) puts("bad 5.3"); + fclose(f); +} +read1(); +} -cleanup { + file delete -force $fname +} -output {} + +test read-2 {test read type errors} -body { +#lang L --line=1 +void read2() +{ + FILE f; + string s; + + read(); + read(f); + read(f, &s, -1, "too many"); + read(0, &s, -1); + read(f, 0, -1); + read(f, &s, s); +} +} -returnCodes error -match regexp -result {.*6: L Error: incorrect # args to read\(\) +.*7: L Error: incorrect # args to read\(\) +.*8: L Error: incorrect # args to read\(\) +.*9: L Error: first arg to read\(\) must have type FILE +.*10: L Error: second arg to read\(\) must have type string\& +.*11: L Error: third arg to read\(\) must have type int +} + +test rename-1 {test rename} -setup { + set fname1 [makeFile {test} rename_test1 .] + set fname2 [makeFile {test} {rename test 2} .] + set fname3 [makeFile {test} renametest\{3\} .] + if {!$_windows} {set fname4 [makeFile {test} {rename test \"\'4} .]} +} -body { +#lang L --line=1 +void rename1(string old) +{ + FILE f; + string buf; + string new = old . "-renamed"; + + unless (rename(old, new) == 0) puts("bad 1.1"); + f = fopen(new, "r"); + unless (defined(f)) puts("bad 2.1"); + unless (defined(buf = <f>)) puts("bad 2.2"); + unless (buf eq "test") puts("bad 2.3"); + if (defined(buf = <f>)) puts("bad 2.4"); + unless (fclose(f) == 0) puts("bad 2.5"); + + unlink(new); +} +#lang tcl +rename1 $fname1 +rename1 $fname2 +rename1 $fname3 +if {!$_windows} {rename1 $fname4} +} -output {} + +test rename-2 {test rename errors} -setup { + file delete -force "does not exist" +} -body { +#lang L --line=1 +void rename2() +{ + unless (rename("does not exist", "bad") == -1) puts("bad 1"); +} +rename2(); +} -output {} + +test require-1 {test require errors} -body { +#lang L --line=1 +void require1() +{ + if (defined(require("non-existent package for sure"))) puts("bad"); +} +require1(); +} -output {} + +test require-2 {test package version number} -body { +#lang L --line=1 +void require2() +{ + string v = Lver(); + + unless (require("L", v) == v) puts("bad 1"); + if (require("L", (float)v+1.0)) puts("bad 2"); + if (require("L", (float)v+0.1)) puts("bad 3"); +} +require2(); +} -output {} + +test rmdir-1 {test rmdir} -setup { + set fdirname1 rmdir1 + set fdirname2 {rm dir 2} + set fdirname3 rmdir\{3\} + if {!$_windows} {set fdirname4 {rmdir "' 4}} + # '" + set fdirname5 rmdir_nonempty + file mkdir $fdirname1 + file mkdir $fdirname2 + file mkdir $fdirname3 + if {!$_windows} {file mkdir $fdirname4} + file mkdir $fdirname5 + file delete -force "does not exist" + set fname [makeFile {test} file rmdir_nonempty] +} -body { +#lang L --line=1 +void rmdir1a(string nm) +{ + unless (rmdir(nm) == 0) puts("bad 1"); + unless (rmdir("does not exist") == 0) puts("bad 2"); +} +void rmdir1b(string nm) +{ + /* Check error case (trying to remove non-empty directory). */ + unless (rmdir(nm) == -1) puts("bad 3"); +} +#lang tcl +rmdir1a $fdirname1 +rmdir1a $fdirname2 +rmdir1a $fdirname3 +if {!$_windows} {rmdir1a $fdirname4} +rmdir1b $fdirname5 +} -cleanup { + file delete -force $fdirname1 $fdirname2 $fdirname3 + if {!$_windows} {file delete -force $fdirname4} + file delete -force $fname $fdirname5 +} -output {} + +test size-1 {test size} -setup { + set fname1 [makeFile {123456} size1 .] + set fname2 [makeFile {123456} {si ze 2} .] + set fname3 [makeFile {123456} size\{3\} .] + if {!$_windows} {set fname4 [makeFile {123456} {size "' 4} .]} + # '" + file delete -force "does not exist" +} -body { +#lang L --line=1 +void size1(string nm) +{ + unless (size(nm) == 7) printf("bad 1 for '%s'\n", nm); + unless (size("does not exist") == -1) puts("bad 2"); +} +#lang tcl +size1 $fname1 +size1 $fname2 +size1 $fname3 +if {!$_windows} {size1 $fname4} +} -cleanup { + file delete -force $fname1 $fname2 $fname3 + if {!$_windows} {file delete -force $fname4} +} -output {} + +test sleep-1 {test sleep} -body { +#lang L --line=1 +void sleep1() +{ + /* + * Touch a file before and after a sleep(3) and check that the + * two mod times are at least two seconds apart. + */ + + int t1, t2; + FILE f; + + f = fopen("sleep_test", "w"); + unless (defined(f)) puts("bad 1"); + fprintf(f, "test1\n"); + fclose(f); + t1 = mtime("sleep_test"); + + sleep(3.0); + + f = fopen("sleep_test", "a"); + unless (defined(f)) puts("bad 2"); + fprintf(f, "test2\n"); + fclose(f); + t2 = mtime("sleep_test"); + + unless ((t2 - t1) >= 2) puts("bad 3"); + + unlink("sleep_test"); +} +sleep1(); +} -output {} + +test spawn1 {test spawn type errors} -body { +#lang L --line=1 +void spawn1() +{ + int iarr[]; + string arr[], s; + STATUS status; + FILE f; + + spawn(); + spawn("not", "enough", "args"); + spawn("cmd", "in", "out", "err", "status", "toomany"); + + /* + * Type errors in cmd arg. It must be string or string[]. + */ + spawn(&s); + spawn(&arr); + spawn(iarr); + + /* + * Type errors in status arg. It must be STATUS&. + */ + spawn(s, status); + spawn(s, s); + + /* + * Type errors in "in" arg. It must be string[], a string + * constant, string variable, or FILE. + */ + spawn(s, &arr, "out", "err"); + spawn(s, iarr, "out", "err"); + spawn(s, &f, "out", "err"); + + /* + * Type errors in "out" arg. It must be string constant, or + * FILE. + */ + spawn(s, "in", s, "err"); + spawn(s, "in", &s, "err"); + spawn(s, "in", &arr, "err"); + spawn(s, "in", arr, "err"); + spawn(s, "in", &iarr, "err"); + spawn(s, "in", &f, "err"); + + /* + * Type errors in "err" arg. Same as for "out" arg. + */ + spawn(s, "in", "out", s); + spawn(s, "in", "out", &s); + spawn(s, "in", "out", &arr); + spawn(s, "in", "out", arr); + spawn(s, "in", "out", &iarr); + spawn(s, "in", "out", &f); +} +} -returnCodes error -match regexp -result {.*8: L Error: incorrect # args +.*9: L Error: incorrect # args +.*10: L Error: incorrect # args +.*15: L Error: first arg must be string or string array +.*16: L Error: first arg must be string or string array +.*17: L Error: first arg must be string or string array +.*22: L Error: last arg must be of type STATUS \& +.*23: L Error: last arg must be of type STATUS \& +.*29: L Error: second arg must be FILE, or string constant/variable/array +.*30: L Error: second arg must be FILE, or string constant/variable/array +.*31: L Error: second arg must be FILE, or string constant/variable/array +.*37: L Error: third arg must be FILE, or string constant +.*38: L Error: third arg must be FILE, or string constant +.*39: L Error: third arg must be FILE, or string constant +.*40: L Error: third arg must be FILE, or string constant +.*41: L Error: third arg must be FILE, or string constant +.*42: L Error: third arg must be FILE, or string constant +.*47: L Error: fourth arg must be FILE, or string constant +.*48: L Error: fourth arg must be FILE, or string constant +.*49: L Error: fourth arg must be FILE, or string constant +.*50: L Error: fourth arg must be FILE, or string constant +.*51: L Error: fourth arg must be FILE, or string constant +.*52: L Error: fourth arg must be FILE, or string constant +} + +test spawn2 {test spawn error return values} -body { +#lang L --line=1 +void spawn2() +{ + int pid; + + /* + * Possible errors: + * error parsing shell quoting in argv[] command + * command not found + * cannot open input file + * cannot open output file + * cannot open err file + * error from Tcl open command (unclear how to get this) + */ + + pid = spawn("'bad quoting"); + if (defined(pid)) puts("bad 1.1"); + + pid = spawn("command-not-found"); + if (defined(pid)) puts("bad 2.1"); + + pid = spawn("date", "bad-input-file", undef, undef); + if (defined(pid)) puts("bad 2.1"); + + pid = spawn("date", undef, "/bad/bad-file", undef); + if (defined(pid)) puts("bad 2.2"); + pid = spawn("date", undef, undef, "/bad/bad-file"); + if (defined(pid)) puts("bad 2.3"); +} +spawn2(); +} -output {} + +test spawn3 {test spawn pid return value} -body { +#lang L --line=1 +void spawn3() +{ + int pid; + FILE f; + + /* + * For a pipeline, spawn should return the pid of the last + * command, like bash does with #!, not a list of pids like + * Tcl's pid() does. + */ + + pid = spawn("date | perl -e 'print $$'", undef, "spawn3-out", undef); + unless (defined(pid)) puts("bad 1"); + unless ((poly)pid =~ /^\d+$/) puts("bad 2"); + waitpid(pid, undef, 0); + unless (exists("spawn3-out")) puts("bad 3"); + unless (f = fopen("spawn3-out", "r")) puts("bad 4"); + unless ((int)<f> == pid) puts("bad 5"); + fclose(f); + unlink("spawn3-out"); +} +spawn3(); +} -output {} + +test spawn4 {test spawn output options} -body { +#lang L +void spawn4() +{ + /* + * Test some cases that were omitted elsewhere. + */ + + int pid; + FILE fe, fo; + string cmd, in; + + // Test that file handles for stdout and stderr are not closed. + + unless (fo = fopen("spawn4-out", "w")) puts("bad 1.1"); + unless (fe = fopen("spawn4-err", "w")) puts("bad 1.2"); + cmd = "perl -e 'while (<>) { print uc $_; print STDERR lc $_; }'"; + in = "LinE1\n"; + pid = spawn(cmd, in, fo, fe); + unless (defined(pid)) puts("bad 1.3 ${stdio_lasterr}"); + unless (waitpid(pid, undef, 0) == pid) puts("bad 1.4"); + if (fprintf(fo, "line2\n")) puts("bad 1.5"); + if (fprintf(fe, "line3\n")) puts("bad 1.6"); + fclose(fo); + fclose(fe); + unless (fo = fopen("spawn4-out", "r")) puts("bad 1.7"); + unless (fe = fopen("spawn4-err", "r")) puts("bad 1.8"); + unless ((<fo> == "LINE1") && (<fo> == "line2") && !<fo>) { + puts("bad 1.9"); + } + unless ((<fe> == "line1") && (<fe> == "line3") && !<fe>) { + puts("bad 1.10"); + } + fclose(fo); + fclose(fe); + + // Test that a list of strings is OK for the stdin arg. + + cmd = "perl -e 'print uc $_ while (<>)'"; + pid = spawn(cmd, {"line1","line2"}, "spawn4-out", undef); + unless (defined(pid)) puts("bad 1.1 ${stdio_lasterr}"); + unless (waitpid(pid, undef, 0) == pid) puts("bad 2.2"); + unless (fo = fopen("spawn4-out", "r")) puts("bad 2.3"); + unless ((<fo> == "LINE1") && (<fo> == "LINE2") && !<fo>) { + puts("bad 2.4"); + } + fclose(fo); + + unlink("spawn4-out"); + unlink("spawn4-err"); +} +spawn4(); +} -output {} + +test sprintf-1 {test sprintf} -body { +#lang L --line=1 +void sprintf1() +{ + string s; + + s = sprintf("Test1"); + unless (s eq "Test1") puts("bad 1"); + + s = sprintf("Test%s", "2"); + unless (s eq "Test2") puts("bad 2"); + + s = sprintf("Test%s%d", "3", 4); + unless (s eq "Test34") puts("bad 3"); +} +sprintf1(); +} -output {} + +test sprintf-2 {test sprintf run-time errors} -body { +#lang L --line=1 +void sprintf2() +{ + string fmt = "%s"; + + if (sprintf(fmt)) puts("bad 1"); +} +sprintf2(); +} -output {} + +test sprintf-2.1 {test sprintf compile-time errors} -body { +#lang L --line=1 +void sprintf2_1() +{ + sprintf("%s"); +} +sprintf2_1(); +} -returnCodes error -match regexp -result {.*3: L Warning: bad format specifier +} + +test stat-1 {test lstat and stat} -setup { + # put 33 digits into the files + set fname1 [makeFile {123456789012345678901234567890123} statfile1 .] + set fname2 [makeFile {123456789012345678901234567890123} {stat file 2} .] + set fname3 [makeFile {123456789012345678901234567890123} statfile\{3\} .] + if {!$_windows} { + set fname4 [makeFile {123456789012345678901234567890123} {stat file \"\' 4} .] + } + file delete -force "does not exist" +} -body { +#lang L --line=1 +void stat1(string target) +{ + string lnk = target . "_link"; + struct stat buf; + + /* + * Links aren't supported on all platforms, so don't test + * lstat if the link can't be created. + */ + unlink(lnk); + if (symlink(lnk, target) == 0) { + unless (lstat(lnk, &buf) == 0) puts("bad 1.1"); + if (buf.st_size == 34) puts("bad 1.2"); + unless (buf.st_type eq "link") puts("bad 1.3"); + } + unlink(lnk); + + /* Error if file does not exist. */ + unless (lstat("does not exist", &buf) == -1) puts("bad 2.1"); + + unless (stat(target, &buf) == 0) puts("bad 5.1"); + unless (buf.st_size == 34) puts("bad 5.2"); + unless (buf.st_type eq "file") puts("bad 5.3"); + unless (buf.st_mtime == mtime(target)) puts("bad 5.4"); +} +#lang tcl +stat1 $fname1 +stat1 $fname2 +stat1 $fname3 +if {!$_windows} {stat1 $fname4} +} -cleanup { + file delete -force $fname1 $fname2 $fname3 + if {!$_windows} {file delete -force $fname4} +} -output {} + +test strchr-1 {test strchr} -body { +#lang L --line=1 +void strchr1() +{ + unless (strchr("abcabc", "a") == 0) puts("bad 1"); + unless (strchr("abcabc", "b") == 1) puts("bad 2"); + unless (strchr("abcabc", "c") == 2) puts("bad 3"); + unless (strchr("abcabc", "d") == -1) puts("bad 4"); +} +strchr1(); +} -output {} + +test streq-1 {test streq} -body { +#lang L --line=1 +void streq1() +{ + unless (streq("abc", "abc") == 1) puts("bad 1"); + unless (streq("abc", "cba") == 0) puts("bad 2"); +} +streq1(); +} -output {} + +test strlen-1 {test strlen} -body { +#lang L --line=1 +void strlen1() +{ + int i; + int n = 10; + string s; + + for (s = "", i = 0; i < n; ++i) { + unless (strlen(s) == i) printf("bad 1 i=%d\n", i); + s = s . "x"; + } +} +strlen1(); +} -output {} + +test strneq-1 {test strneq} -body { +#lang L --line=1 +void strneq1() +{ + unless (strneq("abc", "abc", 10) == 1) puts("bad 1"); + unless (strneq("abc", "cba", 10) == 0) puts("bad 2"); + unless (strneq("abc", "abc", 3) == 1) puts("bad 3"); + unless (strneq("abc", "cba", 3) == 0) puts("bad 4"); + unless (strneq("abc", "abc", 2) == 1) puts("bad 5"); + unless (strneq("abc", "cba", 2) == 0) puts("bad 6"); + + unless (strneq("abc", "abd", 2) == 1) puts("bad 7"); + unless (strneq("abc", "aaa", 1) == 1) puts("bad 8"); +} +strneq1(); + +} -output {} + +test strrchr-1 {test strrchr} -body { +#lang L --line=1 +void strrchr1() +{ + unless (strrchr("abcabc", "a") == 3) puts("bad 1"); + unless (strrchr("abcabc", "b") == 4) puts("bad 2"); + unless (strrchr("abcabc", "c") == 5) puts("bad 3"); + unless (strrchr("abcabc", "d") == -1) puts("bad 4"); +} +strrchr1(); +} -output {} + +test system-1 {test system and popen shell quoting} -body { +#lang L --line=1 +private string do_popen(string cmd) +{ + FILE f; + string ret; + + unless (defined(f = popen(cmd, "r"))) return (undef); + read(f, &ret, -1); + pclose(f); + return (ret); +} +void system1() +{ + /* + * This test checks that we got the shell-quoting semantics right. + * It uses a perl script to echo each element of the argv array + * bracketed with < and >. + * + * xyz -- all escapes are processed except \<newline> ignored + * 'xyz' -- no single quotes allowed inside, no escapes processed + * "xyz" -- only \\ and \" are processed, \<newline> ignored + */ + + int ret; + string s, t; + string perl = "perl -e 'foreach (@ARGV) {print \"<\${_}>\"}'"; + + /* + * Format is <argv element> | <expected output from perl script> + * Note that the Tcl parser requires that the *test* itself + * have balanced {}, so be careful with the order of braces below. + */ + string tests = <<'END' +x | <x> +xy | <xy> +x\yz | <xyz> +x\y\zx | <xyzx> +x\\\\y | <x\\y> +x\ny | <xny> +$x | <$x> +[ | <[> +] | <]> +"x" | <x> +"xy" | <xy> +"x y" | <x y> +"x\yz" | <x\yz> +"x\"y" | <x"y> +"x\\y" | <x\y> +'x' | <x> +'xy' | <xy> +'x y' | <x y> +'x\\' | <x\\> +'x\y' | <x\y> +x"y" | <xy> +x"y"z | <xyz> +x"y""z" | <xyz> +x'y' | <xy> +x'y'z | <xyz> +x'y''z' | <xyz> +x"y"'z' | <xyz> +x'y'"z" | <xyz> +"{" | <{> +} | <}> +{ | <{> +"}" | <}> +{} | <{}> +}{ | <}{> +"{}" | <{}> +"}{" | <}{> +x y | <x><y> + x y | <x><y> + x y | <x><y> + x y | <x><y> + x y | <x><y> +x y | <x><y> +x y | <x><y> +x y z | <x><y><z> +- | <-> +-- --x | <--x> +END +//" (to balance quotes for emacs) + foreach (t in split(/\n/, tests)) { + string a[] = split(/\s*\|\s*/, t); + assert(length(a) == 2); + unless (defined(system("${perl} ${a[0]}", undef, &s, undef))) { + puts("system: error for ${a[0]}"); + } + unless (s eq a[1]) { + puts("system: for ${a[0]} got ${s} wanted ${a[1]}"); + } + unless ((s = do_popen("${perl} ${a[0]}")) eq a[1]) { + puts("popen: for ${a[0]} got ${s} wanted ${a[1]}"); + } + } + + /* Check \<newline> escapes. */ + ret = system("${perl} x\\\ny", undef, &s, undef); // x\ny + unless (defined(ret) && (s eq "<xy>")) puts("bad 1.1"); + ret = system("${perl} \"x\\\ny\"", undef, &s, undef); // "x\ny" + unless (defined(ret) && (s eq "<xy>")) puts("bad 1.2"); + ret = system("${perl} 'x\\\ny'", undef, &s, undef); // 'x\ny' + unless (defined(ret) && (s eq "<x\\\ny>")) puts("bad 1.3"); + s = do_popen("${perl} x\\\ny"); // x\ny + unless (s eq "<xy>") puts("bad 1.4"); + s = do_popen("${perl} \"x\\\ny\""); // "x\ny" + unless (s eq "<xy>") puts("bad 1.5"); + + /* Check error cases (unterminated escapes and quoted strings). */ + + if (defined(system("\\"))) puts("bad 2.1"); + unless (stdio_lasterr eq "trailing \\") puts("bad 2.2"); + if (defined(system("\"\\"))) puts("bad 2.3"); + unless (stdio_lasterr eq "unterminated \"") puts("bad 2.4"); + if (defined(system("\'\\"))) puts("bad 2.5"); + unless (stdio_lasterr eq "unterminated '") puts("bad 2.6"); + if (defined(system("\""))) puts("bad 2.7"); + unless (stdio_lasterr eq "unterminated \"") puts("bad 2.8"); + if (defined(system("\'"))) puts("bad 2.9"); + unless (stdio_lasterr eq "unterminated '") puts("bad 2.10"); + if (defined(system(""))) puts("bad 2.11"); + if (defined(system("bad-executable"))) puts("bad 2.12"); + + if (defined(do_popen("\\"))) puts("bad 3.1"); + unless (stdio_lasterr eq "trailing \\") puts("bad 3.2"); + if (defined(do_popen("\"\\"))) puts("bad 3.3"); + unless (stdio_lasterr eq "unterminated \"") puts("bad 3.4"); + if (defined(do_popen("\'\\"))) puts("bad 3.5"); + unless (stdio_lasterr eq "unterminated '") puts("bad 3.6"); + if (defined(do_popen("\""))) puts("bad 3.7"); + unless (stdio_lasterr eq "unterminated \"") puts("bad 3.8"); + if (defined(do_popen("\'"))) puts("bad 3.9"); + unless (stdio_lasterr eq "unterminated '") puts("bad 3.10"); + if (defined(do_popen(""))) puts("bad 3.11"); + if (defined(do_popen("bad-executable"))) puts("bad 3.12"); +} +system1(); +} -output {} + +test system-2 {test system type errors} -body { +#lang L --line=1 +void system2() +{ + int iarr[]; + string arr[], s; + STATUS status; + FILE f; + + system(); + system("not", "enough", "args"); + system("cmd", "in", "out", "err", "status", "toomany"); + + /* + * Type errors in cmd arg. It must be string or string[]. + */ + system(&s); + system(&arr); + system(iarr); + + /* + * Type errors in status arg. It must be STATUS&. + */ + system(s, status); + system(s, s); + + /* + * Type errors in "in" arg. It must be string[], a string + * constant, string variable, or FILE. + */ + system(s, &arr, "out", "err"); + system(s, iarr, "out", "err"); + system(s, &f, "out", "err"); + + /* + * Type errors in "out" arg. It must be string[]&, string&, + * string constant, or FILE. + */ + system(s, "in", s, "err"); + system(s, "in", arr, "err"); + system(s, "in", &iarr, "err"); + system(s, "in", &f, "err"); + + /* + * Type errors in "err" arg. Same as for "out" arg. + */ + system(s, "in", "out", s); + system(s, "in", "out", arr); + system(s, "in", "out", &iarr); + system(s, "in", "out", &f); +} +} -returnCodes error -match regexp -result {.*8: L Error: incorrect # args +.*9: L Error: incorrect # args +.*10: L Error: incorrect # args +.*15: L Error: first arg must be string or string array +.*16: L Error: first arg must be string or string array +.*17: L Error: first arg must be string or string array +.*22: L Error: last arg must be of type STATUS \& +.*23: L Error: last arg must be of type STATUS \& +.*29: L Error: second arg must be FILE, or string constant/variable/array +.*30: L Error: second arg must be FILE, or string constant/variable/array +.*31: L Error: second arg must be FILE, or string constant/variable/array +.*37: L Error: third arg must be FILE, string constant, or reference to string or string array +.*38: L Error: third arg must be FILE, string constant, or reference to string or string array +.*39: L Error: third arg must be FILE, string constant, or reference to string or string array +.*45: L Error: fourth arg must be FILE, string constant, or reference to string or string array +.*46: L Error: fourth arg must be FILE, string constant, or reference to string or string array +.*47: L Error: fourth arg must be FILE, string constant, or reference to string or string array +} + +test system-3 {test system return values} -body { +#lang L --line=1 +void system3() +{ + int ret; + string err[], out[]; + STATUS status; + FILE not_open; + + /* Check that a non-zero cmd return status is surfaced as an error. */ + ret = system("perl -e 'print \"out\";exit(123)'", + undef, &out, &err, &status); + unless (ret == 123) puts("bad 1.1"); + unless (status.exit == 123) puts("bad 1.2"); + if (defined(status.signal)) puts("bad 1.3"); + + /* Writing to stderr is NOT an error, unlike with Tcl's exec cmd. */ + + stdio_lasterr = undef; + ret = system("perl -e 'print STDERR \"err\"; exit(0)'", + undef, &out, &err, &status); + unless (ret == 0) puts("bad 2.1"); + unless (status.exit == 0) puts("bad 2.2"); + if (stdio_lasterr) puts("bad 2.3"); + + ret = system("perl -e 'print STDERR \"err\"; exit(123)'", + undef, &out, &err, &status); + unless (ret == 123) puts("bad 2.4"); + unless (status.exit == 123) puts("bad 2.5"); + + /* + * This is a poor test, but to check the name and path members + * of the status, check that "perl" is a pathname of some sort. + */ + ret = system("perl -e ''", undef, &out, &err, &status); + unless (ret == 0) puts("bad 3.1"); + unless (status.argv[0] eq "perl") puts("bad 3.2"); + unless (status.path =~ /.+perl(.exe)?$/i) puts("bad 3.3"); + + /* Check that the path comes back undef if executable not found. */ + ret = system("verybadxyz", undef, &out, &err, &status); + if (defined(ret)) puts("bad 4.1"); + if (defined(status.path)) puts("bad 4.2"); + + /* Error parsing shell quoting in argv[] command. */ + ret = system("'bad quoting"); + if (defined(ret)) puts("bad 5.1"); + + /* Command not found. */ + ret = system("command-not-found"); + if (defined(ret)) puts("bad 6.1"); + + /* Cannot open input file. */ + ret = system("date", "bad-input-file", "out", "err"); + if (defined(ret)) puts("bad 7.1"); + + /* Cannot open output file. */ + ret = system("date", undef, "/bad/unwritable", "err"); + if (defined(ret)) puts("bad 7.3"); + + /* Cannot open error file. */ + ret = system("date", undef, "out", "/bad/unwritable"); + if (defined(ret)) puts("bad 8.1"); + + /* A passed-in FILE that is undef. */ + ret = system("date", not_open, undef, undef); + if (defined(ret)) puts("bad 9.1"); + ret = system("date", undef, not_open, undef); + if (defined(ret)) puts("bad 9.2"); + ret = system("date", undef, undef, not_open); + if (defined(ret)) puts("bad 9.3"); + + /* A passed-in FILE that was open but is now closed. */ + not_open = open("out", "w"); + unless (not_open) puts("bad 10.1"); + fclose(not_open); + ret = system("date", not_open, undef, undef); + if (defined(ret)) puts("bad 10.2"); + ret = system("date", undef, not_open, undef); + if (defined(ret)) puts("bad 10.3"); + ret = system("date", undef, undef, not_open); + if (defined(ret)) puts("bad 10.4"); + + unlink("out"); + unlink("err"); +} +system3(); +} -output {} + +test system-3.1 {test system return value when process exits from signal} -constraints unix -body { +#lang L +void system3_1() +{ + int ret; + string err, out; + STATUS status; + + ret = system("perl -e '$pid=$$; print \"out\n\"; system(\"kill $pid\");'", + undef, &out, &err, &status); + if (defined(ret)) puts("bad 1: ${ret}"); + if (out) puts("bad 2: ${out}"); + if (err) puts("bad 3: ${err}"); + unless (stdio_status.signal == 15) puts("bad 4: ${stdio_status.signal}"); + unless (status.signal == 15) puts("bad 5: ${status.signal}"); + if (defined(stdio_status.exit)) puts("bad 6"); + if (defined(status.exit)) puts("bad 7"); +} +system3_1(); +} -output {} + +test system-4 {test system and spawn I/O} -body { +#lang L --line=1 +// Write lines[] to file fname w/open file handle f, then re-open. +private FILE tstwriteh(FILE f, string fname, string lines[]) +{ + string s; + + foreach (s in lines) puts(f, s); + fclose(f); + unless (defined(f = fopen(fname, "r"))) { + puts("cannot open ${fname} for read"); + return (undef); + } + return (f); +} +// Write lines[] to file fname, then close. +private void tstwritef(string fname, string lines[]) +{ + string s; + FILE f; + + unless (defined(f = fopen(fname, "w"))) return; + foreach (s in lines) puts(f, s); + fclose(f); +} +// Read from open file handle f, verify it has lines[]. +private int tstreadh(FILE f, string lines[]) +{ + string s; + + while (defined(s = <f>)) { + unless (defined(lines[0])) { + puts("file too long"); + return (1); + } + unless (s eq lines[0]) { + puts("expected \"${lines[0]}\" got \"${s}\""); + return (1); + } + undef(lines[0]); + } + if (defined(lines[0])) { + puts("file too short"); + return (1); + } + return (0); +} +// Read from file name fname, verify it has lines[]. +private int tstreadf(string fname, string lines[]) +{ + int ret; + FILE f; + + unless (defined(f = fopen(fname, "r"))) { + puts("cannot open ${fname} for read"); + return (1); + } + ret = tstreadh(f, lines); + fclose(f); + return (ret); +} +void system4() +{ + int pid, ret; + string cmd, strIn, strOut, strErr; + string av[], err[], in[], out[]; + string errNm, inNm, outNm; + FILE errf, inf, outf; + + /* Try a cmd that copies stdin to stdout and converts to upper case. */ + cmd = "perl -e 'print uc $_ while (<>)'"; + in = { "this is line 1", "and line 2", "line 3" }; + ret = system(cmd, in, &out, &err); + unless (ret == 0) puts("bad 1.1"); + unless ((tcl)out eq (tcl){"THIS IS LINE 1", "AND LINE 2", "LINE 3"}) { + puts("bad 1.2"); + } + if (err) puts("bad 1.3"); + + /* Same, with stdin coming from a list. */ + cmd = "perl -e 'print uc $_ while (<>)'"; + ret = system(cmd, { "this is line 1", "and line 2", "line 3" }, + &out, &err); + unless (ret == 0) puts("bad 1.4"); + unless ((tcl)out eq (tcl){"THIS IS LINE 1", "AND LINE 2", "LINE 3"}) { + puts("bad 1.5"); + } + if (err) puts("bad 1.6"); + + /* Same, with the command in av[]. */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + in = { "this is line 1", "and line 2", "line 3" }; + ret = system(av, in, &out, &err); + unless (ret == 0) puts("bad 2.1"); + unless ((tcl)out eq (tcl){"THIS IS LINE 1", "AND LINE 2", "LINE 3"}) { + puts("bad 2.2"); + } + if (err) puts("bad 2.3"); + + /* Same, reading and writing to files. */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + ret = system(av, "in", "out", "err"); + unless (ret == 0) puts("bad 3.1"); + if (tstreadf("out", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 3.2"); + } + if (tstreadf("err", {})) { + puts("bad 3.3"); + } + unlink("in"); + unlink("out"); + unlink("err"); + + /* Same, reading and writing to files w/filename in interpolated string. */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + inNm = "in"; + outNm = "out"; + errNm = "err"; + ret = system(av, "${inNm}", "${outNm}", "${errNm}"); + unless (ret == 0) puts("bad 3.1"); + if (tstreadf(outNm, {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 3.2"); + } + if (tstreadf("err", {})) { + puts("bad 3.3"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); + + /* Same, using spawn(). */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + pid = spawn(av, "in", "out", "err"); + unless (defined(pid)) puts("bad 3.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 3.11"); + if (tstreadf("out", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 3.12"); + } + if (tstreadf("err", {})) { + puts("bad 3.13"); + } + unlink("in"); + unlink("out"); + unlink("err"); + + /* Same, using spawn() w/filename in interpolated string. */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + inNm = "in"; + outNm = "out"; + errNm = "err"; + pid = spawn(av, "${inNm}", "${outNm}", "${errNm}"); + unless (defined(pid)) puts("bad 3.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 3.11"); + if (tstreadf("out", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 3.12"); + } + if (tstreadf("err", {})) { + puts("bad 3.13"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); + + /* Same, reading and writing to open file handles. */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + inf = File_Tempfile(&inNm); + outf = File_Tempfile(&outNm); + errf = File_Tempfile(&errNm); + inf = tstwriteh(inf, inNm, { "this is line 1", "and line 2", "line 3" }); + ret = system(av, inf, outf, errf); + unless (ret == 0) puts("bad 4.1"); + // Verify that the handles are still open by writing some more. + fprintf(outf, "AND 4\n"); + fprintf(errf, "only one\n"); + fclose(inf); + fclose(outf); + fclose(errf); + if (tstreadf(outNm, {"THIS IS LINE 1", "AND LINE 2", "LINE 3", "AND 4"})) { + puts("bad 4.2"); + } + if (tstreadf(errNm, {"only one"})) { + puts("bad 4.3"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); + + /* Same, using spawn(). */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + inf = File_Tempfile(&inNm); + outf = File_Tempfile(&outNm); + errf = File_Tempfile(&errNm); + inf = tstwriteh(inf, inNm, { "this is line 1", "and line 2", "line 3" }); + pid = spawn(av, inf, outf, errf); + unless (defined(pid)) puts("bad 4.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 4.11"); + fclose(inf); + fclose(outf); + fclose(errf); + if (tstreadf(outNm, {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 4.12"); + } + if (tstreadf(errNm, {})) { + puts("bad 4.13"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); + + /* Same, with I/O to and from string variables. */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + strIn = "this is line 1\nand line 2\nline 3"; + ret = system(av, strIn, &strOut, &strErr); + unless (ret == 0) puts("bad 5.1"); + unless (strOut eq "THIS IS LINE 1\nAND LINE 2\nLINE 3") puts("bad 5.2"); + if (strErr) puts("bad 5.3"); + + /* Same, using spawn() with input from a string variable. */ + av = { "perl", "-e", "print uc $_ while (<>)" }; + strIn = "this is line 1\nand line 2\nline 3"; + pid = spawn(av, strIn, "out", "err"); + unless (defined(pid)) puts("bad 5.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 5.11"); + fclose(inf); + fclose(outf); + fclose(errf); + if (tstreadf("out", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 5.12"); + } + if (tstreadf("err", {})) { + puts("bad 5.13"); + } + unlink("out"); + unlink("err"); + + /* Try a cmd that copies stdin to stderr and converts to upper case. */ + cmd = "perl -e 'print STDERR uc $_ while (<>)'"; + in = { "this is line 1", "and line 2", "line 3" }; + ret = system(cmd, in, &out, &err); + unless (ret == 0) puts("bad 10.1"); + if (out) puts("bad 10.2"); + unless ((tcl)err eq (tcl){"THIS IS LINE 1", "AND LINE 2", "LINE 3"}) { + puts("bad 10.3"); + } + + /* Same, with the command in av[]. */ + av = { "perl", "-e", "print STDERR uc $_ while (<>)" }; + in = { "this is line 1", "and line 2", "line 3" }; + ret = system(cmd, in, &out, &err); + unless (ret == 0) puts("bad 11.1"); + if (out) puts("bad 11.2"); + unless ((tcl)err eq (tcl){"THIS IS LINE 1", "AND LINE 2", "LINE 3"}) { + puts("bad 11.3"); + } + + /* Same, reading and writing to files. */ + av = { "perl", "-e", "print STDERR uc $_ while (<>)" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + ret = system(av, "in", "out", "err"); + unless (ret == 0) puts("bad 12.1"); + if (tstreadf("out", {})) { + puts("bad 12.2"); + } + if (tstreadf("err", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 12.3"); + } + unlink("in"); + unlink("out"); + unlink("err"); + + /* Same, using spawn(). */ + av = { "perl", "-e", "print STDERR uc $_ while (<>)" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + pid = spawn(av, "in", "out", "err"); + unless (defined(pid)) puts("bad 12.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 12.11"); + if (tstreadf("out", {})) { + puts("bad 12.12"); + } + if (tstreadf("err", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 12.13"); + } + unlink("in"); + unlink("out"); + unlink("err"); + + /* Same, reading and writing to open file handles. */ + av = { "perl", "-e", "print STDERR uc $_ while (<>)" }; + inf = File_Tempfile(&inNm); + outf = File_Tempfile(&outNm); + errf = File_Tempfile(&errNm); + inf = tstwriteh(inf, inNm, { "this is line 1", "and line 2", "line 3" }); + ret = system(av, inf, outf, errf); + unless (ret == 0) puts("bad 13.1"); + // Verify that the handles are still open by writing some more. + fprintf(outf, "only one\n"); + fprintf(errf, "AND 4\n"); + fclose(inf); + fclose(outf); + fclose(errf); + if (tstreadf(outNm, {"only one"})) { + puts("bad 13.2"); + } + if (tstreadf(errNm, {"THIS IS LINE 1", "AND LINE 2", "LINE 3", "AND 4"})) { + puts("bad 13.3"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); + + /* Same, using spawn(). */ + av = { "perl", "-e", "print STDERR uc $_ while (<>)" }; + inf = File_Tempfile(&inNm); + outf = File_Tempfile(&outNm); + errf = File_Tempfile(&errNm); + inf = tstwriteh(inf, inNm, { "this is line 1", "and line 2", "line 3" }); + pid = spawn(av, inf, outf, errf); + unless (defined(pid)) puts("bad 13.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 13.11"); + fclose(inf); + fclose(outf); + fclose(errf); + if (tstreadf(outNm, {})) { + puts("bad 13.12"); + } + if (tstreadf(errNm, {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 13.13"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); + + /* Same, with I/O to and from string variables. */ + av = { "perl", "-e", "print STDERR uc $_ while (<>)" }; + strIn = "this is line 1\nand line 2\nline 3"; + ret = system(cmd, strIn, &strOut, &strErr); + unless (ret == 0) puts("bad 14.1"); + if (strOut) puts("bad 14.2"); + unless (strErr eq "THIS IS LINE 1\nAND LINE 2\nLINE 3") { + puts("bad 14.3"); + } + + /* Same, using spawn() with input from a string variable. */ + av = { "perl", "-e", "print STDERR uc $_ while (<>)" }; + strIn = "this is line 1\nand line 2\nline 3"; + pid = spawn(cmd, strIn, "out", "err"); + unless (defined(pid)) puts("bad 14.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 14.11"); + if (tstreadf("out", {})) { + puts("bad 14.12"); + } + if (tstreadf("err", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 14.13"); + } + unlink("out"); + unlink("err"); + + /* Try a cmd that copies to both stdin and stderr. */ + cmd = "perl -e 'while (<>) {print lc $_;print STDERR uc $_}'"; + in = { "this is line 1", "and line 2", "line 3" }; + ret = system(cmd, in, &out, &err); + unless (ret == 0) puts("bad 20.1"); + unless ((tcl)out eq (tcl){"this is line 1", "and line 2", "line 3"}) { + puts("bad 20.2"); + } + unless ((tcl)err eq (tcl){"THIS IS LINE 1", "AND LINE 2", "LINE 3"}) { + puts("bad 20.3"); + } + + /* Same, with the command in av[]. */ + av = { "perl", "-e", "while (<>) {print lc $_;print STDERR uc $_}" }; + in = { "this is line 1", "and line 2", "line 3" }; + ret = system(cmd, in, &out, &err); + unless (ret == 0) puts("bad 21.1"); + unless ((tcl)out eq (tcl){"this is line 1", "and line 2", "line 3"}) { + puts("bad 21.2"); + } + unless ((tcl)err eq (tcl){"THIS IS LINE 1", "AND LINE 2", "LINE 3"}) { + puts("bad 21.3"); + } + + /* Same, reading and writing to files. */ + av = { "perl", "-e", "while (<>) {print lc $_;print STDERR uc $_}" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + ret = system(av, "in", "out", "err"); + unless (ret == 0) puts("bad 22.1"); + if (tstreadf("out", {"this is line 1", "and line 2", "line 3"})) { + puts("bad 22.2"); + } + if (tstreadf("err", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 22.3"); + } + unlink("in"); + unlink("out"); + unlink("err"); + + /* Same, using spawn(). */ + av = { "perl", "-e", "while (<>) {print lc $_;print STDERR uc $_}" }; + tstwritef("in", { "this is line 1", "and line 2", "line 3" }); + pid = spawn(av, "in", "out", "err"); + unless (defined(pid)) puts("bad 22.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 22.11"); + if (tstreadf("out", {"this is line 1", "and line 2", "line 3"})) { + puts("bad 22.12"); + } + if (tstreadf("err", {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 22.13"); + } + unlink("in"); + unlink("out"); + unlink("err"); + + /* Same, reading and writing to open file handles. */ + av = { "perl", "-e", "while (<>) {print lc $_;print STDERR uc $_}" }; + inf = File_Tempfile(&inNm); + outf = File_Tempfile(&outNm); + errf = File_Tempfile(&errNm); + inf = tstwriteh(inf, inNm, { "this is line 1", "and line 2", "line 3" }); + ret = system(av, inf, outf, errf); + unless (ret == 0) puts("bad 23.1"); + // Verify that the handles are still open by writing some more. + fprintf(outf, "and 4\n"); + fprintf(errf, "AND 4\n"); + fclose(inf); + fclose(outf); + fclose(errf); + if (tstreadf(outNm, {"this is line 1", "and line 2", "line 3", "and 4"})) { + puts("bad 23.2"); + } + if (tstreadf(errNm, {"THIS IS LINE 1", "AND LINE 2", "LINE 3", "AND 4"})) { + puts("bad 23.3"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); + + /* Same, using spawn(). */ + av = { "perl", "-e", "while (<>) {print lc $_;print STDERR uc $_}" }; + inf = File_Tempfile(&inNm); + outf = File_Tempfile(&outNm); + errf = File_Tempfile(&errNm); + inf = tstwriteh(inf, inNm, { "this is line 1", "and line 2", "line 3" }); + pid = spawn(av, inf, outf, errf); + unless (defined(pid)) puts("bad 23.10"); + unless (waitpid(pid, undef, 0) >= 0) puts("bad 23.11"); + fclose(inf); + fclose(outf); + fclose(errf); + if (tstreadf(outNm, {"this is line 1", "and line 2", "line 3"})) { + puts("bad 23.12"); + } + if (tstreadf(errNm, {"THIS IS LINE 1", "AND LINE 2", "LINE 3"})) { + puts("bad 23.13"); + } + unlink(inNm); + unlink(outNm); + unlink(errNm); +} +system4(); +} -output {} + +test system-5 {test system quoting some more} -body { +#lang L --line=1 +void system5() +{ + string t; + string err, out; + string perl[] = { 'perl', '-e', 'foreach (@ARGV) {print "<${_}>"}' }; + + /* + * This checks that the args are literally sent to the cmd, + * with no quote or escape processing. It uses a perl script + * to echo each element of the argv array bracketed with < and >. + * + * Format is <arg1> | <arg2> | ... | <argn> | <expected output> + * Note that the Tcl parser requires that the *test* itself + * have balanced {}, so be careful with the order of braces below. + */ + string tests = <<'END' +x | <x> +x | y | <x><y> +x | y | z | <x><y><z> +x\ | <x\> +x\\ | <x\\> +x\\\ | <x\\\> +x\y | <x\y> +'x' | <'x'> +"x" | <"x"> +{x} | <{x}> +{x} | {y} | <{x}><{y}> +{{x}} | {{y}} | <{{x}}><{{y}}> +{{x}} {{y}} | <{{x}} {{y}}> +"'}{ { } " ' " | <"'}{ { } " ' "> +"'}{ | { | } | " | ' ' | <"'}{><{><}><"><' '> +- | <-> +-- | --x | <--x> +END + foreach (t in split(/\n/, tests)) { + string a[] = split(/\s*\|\s*/, t); + string cmd[] = { (expand)perl, (expand)a[0..END-1] }; + unless (system(cmd, undef, &out, &err) == 0) puts("bad 1"); + unless (out eq a[END]) { + puts("for ${a[0..END-1]} got ${out} want ${a[END]}"); + } + if (err) puts("bad 2"); + } +} +system5(); +} -output {} + +test system6 {test system and spawn chomping} -body { +#lang L --line=1 +int s6chk(string fname, string contents) +{ + FILE f; + string buf; + + unless (defined(f = fopen(fname, "r"))) return (0); + if (read(f, &buf, -1) < 0) return (0); + fclose(f); + return (buf eq contents); +} +void system6() +{ + int pid; + string errNm, errStr, outNm, outStr; + string errArr[], outArr[]; + FILE errHandle, outHandle; + string av[] = {'perl', '-e', 'print "xx\n\n";print STDERR "yy\n\n"'}; + STATUS status; + + /* + * For system() and spawn(), a string arg is passed in/out + * without chomping or appending a newline. Same for FILE and + * "filename". For a string[], when used as the input, each + * element is appending with a newline, and when used as the + * output (system() only), each element is chomped. + */ + + system(av, undef, &outStr, &errStr); + unless (outStr eq "xx\n\n") puts("bad 1.1"); + unless (errStr eq "yy\n\n") puts("bad 1.2"); + + system(av, undef, &outArr, &errArr); + unless (length(outArr) == 2) puts("bad 2.1"); + unless (length(errArr) == 2) puts("bad 2.2"); + unless ((outArr[0] eq "xx") && (outArr[1] eq "")) puts("bad 2.3"); + unless ((errArr[0] eq "yy") && (errArr[1] eq "")) puts("bad 2.4"); + + system(av, undef, "s6tst-out", "s6tst-err"); + unless (s6chk("s6tst-out", "xx\n\n")) puts("bad 3.1"); + unless (s6chk("s6tst-err", "yy\n\n")) puts("bad 3.2"); + unlink("s6tst-out"); + unlink("s6tst-err"); + + pid = spawn(av, undef, "s6tst-out", "s6tst-err"); + unless (defined(pid)) puts("bad 3.5"); + unless (waitpid(pid, &status, 0) >= 0) puts("bad 3.6"); + unless (s6chk("s6tst-out", "xx\n\n")) puts("bad 3.7"); + unless (s6chk("s6tst-err", "yy\n\n")) puts("bad 3.8"); + unlink("s6tst-out"); + unlink("s6tst-err"); + + outHandle = File_Tempfile(&outNm); + errHandle = File_Tempfile(&errNm); + system(av, undef, outHandle, errHandle); + fclose(outHandle); + fclose(errHandle); + unless (s6chk(outNm, "xx\n\n")) puts("bad 4.1"); + unless (s6chk(errNm, "yy\n\n")) puts("bad 4.2"); + unlink(outNm); + unlink(errNm); + + outHandle = File_Tempfile(&outNm); + errHandle = File_Tempfile(&errNm); + pid = spawn(av, undef, outHandle, errHandle); + unless (waitpid(pid, &status, 0) >= 0) puts("bad 5.1"); + fclose(outHandle); + fclose(errHandle); + unless (s6chk(outNm, "xx\n\n")) puts("bad 5.2"); + unless (s6chk(errNm, "yy\n\n")) puts("bad 5.3"); + unlink(outNm); + unlink(errNm); +} +system6(); +} -output {} + +test system7 {misc system and spawn tests} -body { +#lang L --line=1 +void system7() +{ + int ret; + string out; + FILE f; + + /* These used to be type errors. */ + + out = undef; + ret = undef; + ret = system({'perl', '-e', 'print "SYSTEM7"'}, undef, &out, undef); + unless (defined(ret)) puts("bad 1.1"); + unless (out eq "SYSTEM7") puts("bad 1.2"); + + out = undef; + ret = undef; + ret = spawn({'perl', '-e', 'print "SYSTEM7"'}, undef, "out7", undef); + unless (defined(ret) && (ret > 0)) puts("bad 2.1"); + waitpid(ret, undef, 0); + unless (f = fopen("out7", "r")) puts("bad 2.2"); + unless (<f> eq "SYSTEM7") puts("bad 2.3"); + fclose(f); + unlink("out7"); + + out = undef; + ret = undef; + ret = system({'perl', '-e', 'print "SYSTEM7"'}, undef, &out, undef, + undef); + unless (defined(ret)) puts("bad 3.1"); + unless (out eq "SYSTEM7") puts("bad 3.2"); + + out = undef; + ret = undef; + ret = spawn({'perl', '-e', 'print "SYSTEM7"'}, undef, "out7", undef, + undef); + unless (defined(ret) && (ret > 0)) puts("bad 4.1"); + waitpid(ret, undef, 0); + unless (f = fopen("out7", "r")) puts("bad 4.2"); + unless (<f> eq "SYSTEM7") puts("bad 4.3"); + fclose(f); + unlink("out7"); +} +system7(); +} -output {} + +test system-8 {test system output re-direction} -body { +#lang L --line=1 +string sys8_file(string filename) +{ + string ret; + FILE f; + + unless (f = fopen(filename, "r")) return ("fopen ${filename}"); + ret = <f>; + fclose(f); + return (ret); +} +void system8() +{ + int ret; + string cmd_in = "perl -e 'print $_ while (<>)' <in"; + string cmd_out = "perl -e 'print \"OUT8\"' >out"; + string cmd_err = "perl -e 'print STDERR \"ERR8\"' 2>err"; + string cmd_both = "perl -e 'print \"BOTH8o\"; print STDERR \"BOTH8e\"' >out 2>err"; + string err, out; + + Fprintf("in", "sys8 in"); + ret = system(cmd_in, undef, &out, &err); + unless (ret == 0) puts("bad 1.1"); + unless (out eq "sys8 in") puts("bad 1.2"); + if (err) puts("bad 1.3"); + + unlink("out"); + ret = system(cmd_out); + unless (ret == 0) puts("bad 2.1"); + unless (sys8_file("out") eq "OUT8") puts("bad 2.2"); + + unlink("out"); + ret = system(cmd_out, undef, undef, undef); + unless (ret == 0) puts("bad 3.1"); + unless (sys8_file("out") eq "OUT8") puts("bad 3.2"); + + unlink("err"); + ret = system(cmd_err); + unless (ret == 0) puts("bad 4.1"); + unless (sys8_file("err") eq "ERR8") puts("bad 4.2"); + + unlink("err"); + ret = system(cmd_err, undef, undef, undef); + unless (ret == 0) puts("bad 5.1"); + unless (sys8_file("err") eq "ERR8") puts("bad 5.2"); + + unlink("out"); unlink("err"); + ret = system(cmd_both); + unless (ret == 0) puts("bad 6.1"); + unless (sys8_file("out") eq "BOTH8o") puts("bad 6.2"); + unless (sys8_file("err") eq "BOTH8e") puts("bad 6.3"); + + unlink("out"); unlink("err"); + ret = system(cmd_both, undef, undef, undef); + unless (ret == 0) puts("bad 7.1"); + unless (sys8_file("out") eq "BOTH8o") puts("bad 7.2"); + unless (sys8_file("err") eq "BOTH8e") puts("bad 7.3"); + + unlink("out"); unlink("err"); + + ret = system(cmd_in, "in", "out", undef); + if (defined(ret)) puts("bad 10.1"); + unless (stdio_lasterr eq "cannot both specify and re-direct stdin") { + puts("bad 10.2"); + } + if (exists("out")) puts("bad 10.3"); + + ret = system(cmd_out, undef, "out", undef); + if (defined(ret)) puts("bad 11.1"); + unless (stdio_lasterr eq "cannot both specify and re-direct stdout") { + puts("bad 11.2"); + } + if (exists("out")) puts("bad 11.3"); + + ret = system(cmd_err, undef, undef, "err2"); + if (defined(ret)) puts("bad 12.1"); + unless (stdio_lasterr eq "cannot both specify and re-direct stderr") { + puts("bad 12.2"); + } + if (exists("err2")) puts("bad 12.3"); + unlink("err2"); + + unlink("in"); +} +system8(); +} -output {} + +test system-9 {test that unredirected stderr output causes no error} -setup { + makeFile { + int main() { + int ret; + + stdio_lasterr = undef; + ret = system("perl -e 'print STDERR \"err9\";exit(0)'"); + unless (defined(ret) && (ret == 0)) puts("bad 1"); + if (stdio_lasterr) puts("bad 3"); + return (0); + } + } system-9.l . +} -body { +#lang L +void system9() +{ + int ret; + string err, out; + string tclsh = eval("interpreter"); + + ret = system({tclsh, "system-9.l"}, undef, &out, &err); + if (ret) puts("bad 1.1 ret=${ret}"); + if (out) puts("bad 1.2"); + unless (err == "err9") puts("bad 1.3 err='${err}'"); +} +system9(); +} -output {} + +test system-10 {test indirectly passed undef references for out and err args} -body { +#lang L +/* + * The omitted _optional call-by-reference reference arg is passed on + * to system() which used to crash because it tried to reference it + * without checking for undef first. + */ +void system10_out(_optional string &s) +{ + if (system("perl -e exit 0", undef, &s, undef)) puts("bad 1"); +} +void system10_err(_optional string &s) +{ + if (system("perl -e exit 0", undef, undef, &s)) puts("bad 2"); +} +void system10() +{ + system10_out(); + system10_err(); +} +system10(); +} -output {} + +test symlink-1 {test symlink} -setup { + set fname [makeFile {test} linktest .] + file delete -force linktest2 +} -body { +#lang L --line=1 +void symlink1() +{ + /* Error if target does not exist. */ + unless (symlink("link", "does not exist") == -1) puts("bad 1.1"); + + /* + * This isn't supported on all platforms, so if it returns + * failure, don't check for the symlink. + */ + if (symlink("linktest", "linktest2") == 0) { + unless (islink("linktest2")) puts("bad 2.1"); + unless (exists("linktest2")) puts("bad 2.2"); + } +} +symlink1(); +} -cleanup { + file delete -force linktest linktest2 +} -output {} + +test backtick-1 {test backtick} -setup { + set fname [makeFile "line1\nline2\nline3\n" system_file .] +} -body { +#lang L --line=1 +void backtick1() +{ + string s; + + /* Note: back-tick trims trailing newline. */ + s = `cat system_file`; + unless (s eq "line1\nline2\nline3") puts("bad 1"); + + /* Check error case. */ + s = `what-the-heck bad-command`; + if (defined(s)) puts("bad 2"); + + s = `perl -e 'print "%s"'`; + unless (s == "%s") puts("bad 3"); +} +backtick1(); +} -output {} + +test backtick-2 {test backtick stderr} -setup { + set fname [makeFile { + string ret; + + ret = `perl -e 'print "to out"; print STDERR "to err";'`; + unless (ret eq "to out") puts("bad stdout ${ret}"); + unless (stdio_status.argv[0] eq "perl") puts("bad 10"); + unless (stdio_status.path =~ /.+perl(.exe)?$/i) puts("bad 11"); + unless (stdio_status.exit == 0) puts("bad 12"); + if (defined(stdio_status.signal)) puts("bad 13"); + } backtick2.l] +} -body { +#lang L --line=1 +/* + * Some contortions here to run tclsh on backtick2.l (above) which + * prints to stderr, so we can capture stderr and check it. + * Otherwise, tcltest sees anything to stderr as an error and fails + * the test. + */ +void backtick2() +{ + int ret; + string cmd = "\"${eval('interpreter')}\" backtick2.l"; + string err[], out[]; + + ret = system(cmd, undef, &out, &err); + unless (defined(ret)) puts("bad status ${ret}"); + unless (length(out) == 0) puts("bad 2 ${out}"); + unless (err[0] eq "to err") puts("bad 3 ${err}"); +} +backtick2(); +} -output {} + +test backtick-3 {test backtick stderr} -setup { + set fname [makeFile { + string ret; + + ret = `perl -e 'print "to out"; print STDERR "to err";exit 3'`; + unless (ret eq "to out") puts("bad stdout ${ret}"); + unless (stdio_status.argv[0] eq "perl") puts("bad 10"); + unless (stdio_status.path =~ /.+perl(.exe)?$/i) puts("bad 11"); + unless (stdio_status.exit == 3) puts("bad 12"); + if (defined(stdio_status.signal)) puts("bad 13"); + } backtick3.l] +} -body { +#lang L --line=1 +/* + * Same as backtick2() above except with non-zero exit status. + */ +void backtick3() +{ + int ret; + string cmd = "\"${eval('interpreter')}\" backtick3.l"; + string err[], out[]; + + ret = system(cmd, undef, &out, &err); + unless (defined(ret)) puts("bad status ${ret}"); + unless (length(out) == 0) puts("bad 2 ${out}"); + unless (err[0] eq "to err") puts("bad 3 ${err}"); +} +backtick3(); +} -output {} + +test trim-1 {test trim} -body { +#lang L --line=1 +void trim1() +{ + unless (trim("") eq "") puts("bad 1"); + unless (trim(" ") eq "") puts("bad 2"); + unless (trim(" ") eq "") puts("bad 3"); + unless (trim("abc") eq "abc") puts("bad 4"); + unless (trim(" abc") eq "abc") puts("bad 5"); + unless (trim("abc ") eq "abc") puts("bad 6"); + unless (trim(" abc") eq "abc") puts("bad 7"); + unless (trim("abc ") eq "abc") puts("bad 8"); + unless (trim("\tabc") eq "abc") puts("bad 9"); + unless (trim("abc\t") eq "abc") puts("bad 10"); + unless (trim("\nabc") eq "abc") puts("bad 11"); + unless (trim("abc\n") eq "abc") puts("bad 12"); +} +trim1(); +} -output {} + +test unlink-1 {test lunlink and unlink} -setup { + set fname1 [makeFile {test} unlinkfile1 .] + set fname2 [makeFile {test} {unlink file 2} .] + set fname3 [makeFile {test} unlinkfile\{3\} .] + if {!$_windows} {set fname4 [makeFile {test} {unlink file \"\' 4} .]} + file delete -force "does not exist" +} -body { +#lang L --line=1 +void unlink1(string nm) +{ + unless (unlink(nm) == 0) puts("bad 1"); + if (exists(nm)) puts("bad 2"); +} +#lang tcl +unlink1 $fname1 +unlink1 $fname2 +unlink1 $fname3 +if {!$_windows} {unlink1 $fname4} +} -cleanup { + file delete -force $fname1 $fname2 $fname3 + if {!$_windows} {file delete -force $fname4} +} -output {} + +test uc-1 {test uc} -body { +#lang L --line=1 +void uc1() +{ + unless (uc("abcde") eq "ABCDE") puts("bad 1"); + unless (uc("ABCDE") eq "ABCDE") puts("bad 2"); + unless (uc("AbCdE") eq "ABCDE") puts("bad 3"); + unless (uc("") eq "") puts("bad 5"); +} +uc1(); +} -output {} + +test waitpid-1 {test waitpid, nohang} -body { +#lang L --line=1 +void wpDoit(int exit_status) +{ + int i, pid, ret, reaped, secs; + string av[]; + STATUS st; + + secs = 2; + av = {"perl", "-e", "sleep ${secs}; exit ${exit_status}"}; + pid = spawn(av); + unless (defined(pid)) puts("bad 1.1"); + + /* Poll waitpid every 1/4 second up to secs+1 seconds. */ + reaped = 0; + for (i = 0; !reaped && (i < (secs+1)*4); ++i) { + ret = waitpid(pid, &st, 1); + switch (ret) { + case 0: // process still running + break; + case -1: // error + puts("bad 2.0"); + break; + undef: // should never happen + puts("bad 2.1"); + break; + default: // should be pid + unless (ret == pid) puts("bad 2.2"); + unless (defined(st.exit)) puts("bad 2.3"); + unless (st.exit == exit_status) puts("bad 2.4"); + if (defined(st.signal)) puts("bad 2.5"); + ++reaped; + break; + } + sleep(0.25); + } + unless (reaped) puts("bad 3.1"); +} +void waitpid1() +{ + wpDoit(0); + wpDoit(1); + wpDoit(100); +} +waitpid1(); +} -output {} + +test waitpid-2 {test waitpid on exited process} -body { +#lang L --line=1 +void waitpid2() +{ + int pid; + FILE f; + + /* Test waitpid on an already exited process. */ + + pid = spawn({'perl', '-e', 'print "waitpid2"'}, + undef, "outp2", undef); + unless (pid > 0) puts("bad 1.1"); + sleep(1); + unless (waitpid(pid, undef, 0) == pid) puts("bad 1.2"); + // check that if you call again, you get -1 + unless (waitpid(pid, undef, 0) == -1) puts("bad 1.2.1"); + unless (f = fopen("outp2", "r")) puts("bad 1.3"); + unless (<f> eq "waitpid2") puts("bad 1.4"); + fclose(f); + unlink("outp2"); +} +waitpid2(); +} -output {} + +test waitpid-3 {test waitpid with multiple procs} -body { +#lang L --line=1 +/* This test is from Larry. */ +void waitpid3(int n, int parallel) +{ + string cmd[]; + string pids{int}; + int i, pid, reaped, ret; + int bg = 0; + int usleep = getpid(); + STATUS st; + + for (i = 0; i < n; ++i) { + while (bg > parallel) { + reaped = 0; + foreach (pid in keys(pids)) { + ret = waitpid(pid, &st, 1); + if (ret == 0) continue; + if (ret < 0) puts("bad 1.1"); + unless (ret == pid) puts("bad 1.2"); + unless (st.exit == 0) puts("bad 1.3"); + reaped++; + bg--; + undef(pids{pid}); + // check that if you call again, you get -1 + unless (waitpid(pid, undef, 1) == -1) { + puts("bad 1.4"); + } + break; + } + if (reaped) break; + sleep(0.1); + } + cmd = { + "bk", + "_usleep", + (string)usleep, + }; + unless (defined(pid = spawn(cmd))) puts("spawn failed: ${cmd}"); + pids{pid} = join(" ", cmd); + bg++; + usleep = pid; // move the amounts around + } + foreach (pid in keys(pids)) { + unless (waitpid(pid, &st, 0) == pid) puts("bad 2.1"); + unless (waitpid(pid, &st, 0) == -1) puts("bad 2.1.1"); + unless (st.exit == 0) puts("bad 2.2"); + } +} +waitpid3(10, 5); +} -output {} + +test waitpid-4 {test waitpid with multiple procs, wait on any} -body { +#lang L +/* This test is from Larry. */ +void +waitpid4(void) +{ + int i, pid; + string cmd, pids{int}; + + for (i = 0; i < 5; i++) { + cmd = "bk _usleep ${i * 100000}"; + pid = spawn(cmd); + unless (defined(pid)) puts("spawn err ${cmd}"); + pids{pid} = cmd; + } + for (i = 0; i < 5; i++) { + if (i < 3) { + pid = waitpid(-1, undef, 0); + } else { + pid = wait(undef); + } + if (pids{pid}) { + cmd = join(" ", stdio_status.argv); + unless(cmd == pids{pid}) { + puts("bad argv: want ${cmd} got ${pids{pid}}"); + } + undef(pids{pid}); + } else { + puts("${i} waitpid error ${pid}"); + } + } + unless ((pid = waitpid(-1, undef, 0)) == -1) { + puts("waitpid w/ no processes=${pid}"); + } + unless ((pid = wait(undef)) == -1) { + puts("wait w/ no processes=${pid}"); + } +} +waitpid4(); +} -output {} + +test warn-1 {test warn} -body { +#lang L --line=1 +void warn1() +{ + string s1 = "s1", s2 = "s2"; + + warn("warning: %s\n", s1); + warn("warning: %s %s\n", s1, s2); + + /* No trailing newline -- warn should append file,line. */ + + warn("warning: %s", s1); + warn("warning: %s %s", s1, s2); +} +warn1(); +} -match regexp -errorOutput {warning: s1 +warning: s1 s2 +warning: s1 at .*.test line 10. +warning: s1 s2 at .*.test line 11. +} -output {} + +test warn-2 {test warn errors} -body { +#lang L --line=1 +void warn2() +{ + warn("%s"); +} +warn2(); +} -returnCodes error -match regexp -result {.*3: L Warning: bad format specifier +} + +test write-1 {test write} -body { +#lang L --line=1 +void write1() +{ + int n; + string s; + widget w; + FILE f; + + f = fopen("write1", "w"); + unless (defined(f)) puts("bad 1.1"); + s = "x"; + unless (write(f, s, 1) == 1) puts("bad 1.2"); + s = "yz"; + unless (write(f, s, 2) == 2) puts("bad 1.3"); + s = "0123456789"; + unless (write(f, s, 10) == 10) puts("bad 1.4"); + w = "w"; + unless (write(f, w, 1) == 1) puts("bad 1.5"); + fclose(f); + + f = fopen("write1", "r"); + unless (defined(f)) puts("bad 2.1"); + n = read(f, &s, -1); + unless (n == 14) puts("bad 2.2"); + unless (s eq "xyz0123456789w") puts("bad 2.3"); + fclose(f); +} +write1(); +} -cleanup { + removeFile write1 +} -output {} + +test write-2 {test write type errors} -body { +#lang L --line=1 +void write2() +{ + FILE f; + string s; + + write(); + write(f); + write(f, s); + write(f, s, -1, "too many"); + write(0, s, -1); + write(f, 0, -1); + write(f, s, s); +} +} -returnCodes error -match regexp -result {.*6: L Error: incorrect # args to write\(\) +.*7: L Error: incorrect # args to write\(\) +.*8: L Error: incorrect # args to write\(\) +.*9: L Error: incorrect # args to write\(\) +.*10: L Error: first arg to write\(\) must have type FILE +.*11: L Error: second arg to write\(\) must have type string +.*12: L Error: third arg to write\(\) must have type int +} + +test write-3 {test write run-time errors} -body { +#lang L --line=1 +void write3() +{ + string s; + FILE f; + + f = fopen("write3", "w"); + unless (defined(f)) puts("bad 1"); + fclose(f); + f = fopen("write3", "r"); + unless (defined(f)) puts("bad 2"); + unless (write(f, s, 1) == -1) puts("bad 3"); + unless (stdio_lasterr =~ /wasn\'t opened for writing/) puts("bad 4"); + fclose(f); +} +write3(); +} -cleanup { + removeFile write3 +} -output {} + +test write-4 {test write with binary data} -body { +#lang L --line=1 +void write4() +{ + /* + * Write all the ordinals from 0 to 255 to a file a few times + * and read them back. + */ + + int i, n; + int niters = 3; + FILE f; + string buf; + + unless (f = fopen("write4-out", "w")) puts("bad 1"); + fconfigure(f, translation: "binary"); + for (i = 0; i < 256*niters; ++i) { + buf = sprintf("%c", i%256); + assert(length(buf) == 1); + write(f, buf, 1); + } + fclose(f); + + unless (f = fopen("write4-out", "r")) puts("bad 2"); + fconfigure(f, translation: "binary"); + i = 0; + while ((n = read(f, &buf, 1)) > 0) { + unless (n == 1) puts("bad 3"); + unless (length(buf) == 1) puts("bad 4"); + unless (ord(buf[0]) == (i%256)) puts("bad 5 @${i}"); + ++i; + } + unless (n == 0) puts("bad 6"); + unless (i == 256*niters) puts("bad 7 ${i}"); + unlink("write4-out"); +} +write4(); +} -output {} + +::tcltest::cleanupTests +return diff --git a/tests/l-regression.test b/tests/l-regression.test new file mode 100644 index 0000000..b1ae3de --- /dev/null +++ b/tests/l-regression.test @@ -0,0 +1,381 @@ +# Test to make sure that bugs don't creep back into L +# Copyright (c) 2007 BitMover, Inc. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +# This causes L to keep running L code even after a compile error. +set ::env(_L_TEST) 1 + +# This tells L to run in a backwards compatibility mode for +# the old eq/ne/le/lt/ge/gt string-comparison operators. +set ::env(_L_ALLOW_EQ_OPS) 1 + +test empty-1.0 {empty code blocks} -body { +#lang L --line=1 +void empty_1_0() { +} +#lang tcl +empty_1_0 +} + +test empty-1.1 {empty code blocks with some control flow} -body { +#lang L --line=1 +void empty_1_1() { + /* note that none of these conditions is true, + so no code is executed */ + unless(1) { + puts("1 broken"); + } else if (0) { + puts("1.1 broken"); + } else unless(1) { + puts("1 working"); + } +} +#lang tcl +empty_1_1 +} + +test values-1.0 {the values of struct increment and assignment} -body { +#lang L --line=1 +struct values_1_0 { + int clicks; + string value; +}; + +void values_1_0() { + struct values_1_0 main_entry; + puts(main_entry.clicks = 0); + puts(++main_entry.clicks); +} +#lang tcl +values_1_0 +} -output "0\n1\n" + + +test multi-dimensional-1.0 {move[state][read_symbol] was being evaluated as +move[state][state[read_symbol]][read_symbol], or thereabouts, because the AST +was built in an ambiguous way.} -body { +#lang L --line=1 +string dump_tape(int tape[]); +void turing(int step, int state, int tape[], int pos) { + int write_symbol[5][2], move[5][2], new_state[5][2], read_symbol; + + write_symbol[0][1] = 0; move[0][1] = 1; new_state[0][1] = 1; + write_symbol[1][1] = 1; move[1][1] = 1; new_state[1][1] = 1; + write_symbol[1][0] = 0; move[1][0] = 1; new_state[1][0] = 2; + write_symbol[2][0] = 1; move[2][0] = 0; new_state[2][0] = 3; + write_symbol[2][1] = 1; move[2][1] = 1; new_state[2][1] = 2; + write_symbol[3][1] = 1; move[3][1] = 0; new_state[3][1] = 3; + write_symbol[3][0] = 0; move[3][0] = 0; new_state[3][0] = 4; + write_symbol[4][1] = 1; move[4][1] = 0; new_state[4][1] = 4; + write_symbol[4][0] = 1; move[4][0] = 1; new_state[4][0] = 0; + + read_symbol = tape[pos]; + puts(append("", " ", step, "\ts", state + 1, "\t", dump_tape(tape))); + + // state 0 and symbol 0 means to halt + if (read_symbol + state) { + tape[pos] = write_symbol[state][read_symbol]; + if (move[state][read_symbol]) { + pos++; + } else { + pos--; + } + turing(step + 1, new_state[state][read_symbol], tape, pos); + } else { + puts("-- halt --"); + } +} + +/* dump the tape to a string */ +string +dump_tape(int tape[]) { + return format("%d %d %d %d %d", + tape[0], tape[1], tape[2], tape[3], tape[4]); +} + +void multi_dimensional_1_0() { + int tape[5]; + + tape[0] = 1; tape[1] = 1; tape[2] = 0; tape[3] = 0; tape[4] = 0; + puts("Step\tState\tTape"); + puts("- - - - - - - - - -"); + turing(1, 0, tape, 0); +} +#lang tcl +multi_dimensional_1_0 +} -output {Step State Tape +- - - - - - - - - - + 1 s1 1 1 0 0 0 + 2 s2 0 1 0 0 0 + 3 s2 0 1 0 0 0 + 4 s3 0 1 0 0 0 + 5 s4 0 1 0 1 0 + 6 s5 0 1 0 1 0 + 7 s5 0 1 0 1 0 + 8 s1 1 1 0 1 0 + 9 s2 1 0 0 1 0 + 10 s3 1 0 0 1 0 + 11 s3 1 0 0 1 0 + 12 s4 1 0 0 1 1 + 13 s4 1 0 0 1 1 + 14 s5 1 0 0 1 1 + 15 s1 1 1 0 1 1 +-- halt -- +} + +test initializers-1.0 {initialize a whole array at once} -body { +#lang L --line=1 +void initializers_1_1() { + string foo[] = initializers_1_1_returnarray(); + + printf("foo[0] is %s\n", foo[0]); + printf("foo[1] is %s\n", foo[1]); +} + +poly initializers_1_1_returnarray() { + return "foo bar"; +} +#lang tcl +initializers_1_1 +} -output "foo\[0\] is foo\nfoo\[1\] is bar\n" + +test cast-1.0 {don't segfault when casting to a string} -body { +#lang L --line=1 +void cast_1_0() { + puts((string)"asdf"); +} +#lang tcl +cast_1_0 +} -output "asdf\n" + + +test typecheck-1.0 {typechecker segfaults on unop check that must be queued} -body { +#lang L --line=1 +int typecheck_1_0_bar() { + return 22; +} +string typecheck_1_0_foo(string foo) { + return foo; +} +void typecheck_1_0() { + // note the - + typecheck_1_0_foo(-typecheck_1_0_bar()); +} +#lang tcl +typecheck_1_0 +} -returnCodes {error} -match glob -result \ + "*:9: L Error: parameter 1 has incompatible type\n" + +test decl-1.0 {don't drop array dimensions from typedef when declaring multiple variables} -body { +#lang L --line=1 +typedef int atype[2]; +void decl_1_0() { + atype foo[3], bar; + foo[2][1] = 0; + bar[1] = 0; + puts(foo); + puts(bar); +} +#lang tcl +decl_1_0 +} -output "{} {} {{} 0}\n{} 0\n" + +test if-1.0 {jump target is wrong when else block gets too big} -body { +#lang L --line=1 -nowarn +void if_1_0() { + string w = ".asdf"; + string btm = "${w}.btm", e = "${w}.e"; + if (0) { + puts("wicky wicky2"); + wm("withdraw", btm); + } else { + string width, h, h1, x, y; + puts("wicky wicky3"); + width = winfo("width", e); + h = winfo("reqheight", w); + h1 = winfo("reqheight", btm); + x = winfo("rootx", w); + y = winfo("rooty", w); + /* XXX, wtf? */ + puts(width); + puts(h1); + puts(x); + } +} + +string winfo(string a, string b) {return "42";} +#lang tcl +if_1_0 +} -output {wicky wicky3 +42 +42 +42 +} + +test scope-1.0 {if a global is first used as a reference, it gets erroneously created twice} -body { +#lang L --line=1 +string avar = "foo"; +void frob(string &str) { + str = "bar"; +} +void scope_1_0() { + frob(&avar); + puts(avar); +} +#lang tcl +scope_1_0 +} -output "bar\n"; + +test scope-1.1 {a block introduces a new scope} -body { +#lang L --line=1 +void scope_1_1() { + { + int a; + a = 5; + } + puts(a); +} +#lang tcl +scope_1_1 +} -returnCodes {error} -match glob -result "*:6: L Error: undeclared variable: a\n" + +test regexp-1.0 {regexps might start with a dash, so call regex/regsub with -- before the regexp} -body { +#lang L --line=1 +void regexp_1_0() { + string v = "a-b-c"; + v =~ s/-/\–/g; + puts(v); +} +#lang tcl +regexp_1_0 +} -output "a–b–c\n" + +test errors-1.0 {don't run L code if there were compilation errors} -body { +#lang L --line=1 +void errors_1_0() { + int argc; + // we want "this is text" to _not_ print + puts("this is text"); + puts(argc[1]); +} +errors_1_0(); +#lang tcl +} -returnCodes {error} -match glob -result "*:5: L Error: not an array*\n" \ +-output {} + +test break-1.0 {breaks break when loop jump instructions grow because the loop body is big} -body { +#lang L --line=1 +void break_1_0() { + int i; + + for (i = 0; i<10; i++) { + printf("${i}"); + printf("${i}"); + printf("${i}"); + printf("${i}"); + printf("${i}"); + break; + } +} +break_1_0(); +#lang tcl +} -output {00000} + +test typedef-1.0 {L redeclaring types is allowed for same types} -body { +#lang L --line=1 +typedef string typedef_1_0_FOO; +typedef string typedef_1_0_FOO; +#lang tcl +} -output "" + +test typedef-1.1 {L redefining types is not allowed} -body { +#lang L --line=1 +typedef string typedef_1_1_BAR; +typedef int typedef_1_1_BAR; +#lang tcl +} -returnCodes {error} -match glob -result \ + "*:2: L Error: Cannot redefine type typedef_1_1_BAR*" + +test crash-1.1 {crashing in some interim versions} -body { +#lang L --line=1 +struct c11xy { int x,y; }; +void +crash_1_1() +{ + struct c11xy xys[2]; + xys[0].x = 1; + printf("%s", xys); +} +crash_1_1(); +} -output "1" + + +test pattern-1.2 {L widget pattern functions} -body { +#lang L --line=1 +void pattern_1_2_foo(...args) +{ + puts(args); +} + +void pattern_1_2() +{ + widget w = "pattern_1_2_foo"; + Text_insert(w, "end", "FOO"); +} +pattern_1_2(); +#lang tcl +} -output "insert end FOO\n" + +test empty-stmt {empty stmt crashed in parser} -body { +#lang L --line=1 +void empty_stmt() +{ + printf("Should be OK now.\n");; // Note the two semicolons. +} +#lang tcl +empty_stmt +} -output "Should be OK now.\n" + +test struct-typedef-1.1 {check struct typedef bug} -body { +#lang L --line=1 +typedef struct { + int x; + int y; +} foo_st_11; + +foo_st_11 bars_st_11{string}; + +void a_st_11(foo_st_11 f) +{ + bars_st_11{"FOO"} = f; + puts("X = ${f.x}"); +} + +void struct_typedef_1_1() +{ + foo_st_11 f = {66,63}; + a_st_11(f); + puts(bars_st_11); +} +#lang tcl +struct_typedef_1_1 +} -output "X = 66\nFOO {66 63}\n" + +test list-1 {check list creation bug} -body { +#lang L --line=1 +void list_1() +{ + /* This used to trip an assert. */ + {undeclared_variable}; +} +list_1(); +} -returnCodes {error} -match regexp -result {.*4: L Error: undeclared variable.* +} + +# cleanup +::tcltest::cleanupTests +return diff --git a/tests/langbench/BEFORE-PERF b/tests/langbench/BEFORE-PERF new file mode 100644 index 0000000..831ee2a --- /dev/null +++ b/tests/langbench/BEFORE-PERF @@ -0,0 +1,26 @@ +These are the langbench results from the source base as of early Nov-2007. + +lang cat grep hash loop proc fib sort wc +tcl 2.10 4.10 1.51 0.06 1.27 3.76 5.40 0.97 +l 2.10 4.21 1.48 0.08 0.51 3.92 5.76 coredump :( + +vs now, late Jan-2008 + +lang cat grep hash loop proc fib sort wc +tcl 0.81 0.97 1.13 0.05 0.98 3.45 2.85 1.21 +l 0.82 0.97 1.14 0.05 0.45 3.36 3.11 1.93 + +Factor better: +lang cat grep hash loop proc fib sort wc +tcl 2.6x 4.2x 1.3x wash 1.3x wash 1.9x .8x (whoops) +l 2.6x 4.2x 1.3x wash wash 1.2x 1.9x NA + +And other languages for comparison: +lang cat grep hash loop proc fib sort wc +pl 0.36 0.36 0.61 0.07 0.40 3.68 2.15 1.00 +py 0.46 1.50 0.48 0.15 0.23 1.27 2.26 0.49 +rb 0.82 0.73 1.64 0.29 1.13 4.06 4.29 3.09 + +Amount slower than perl: +lang cat grep hash loop proc fib sort wc +tcl/l 2.3x 2.7x 1.9x faster wash faster 1.4x 1.2x diff --git a/tests/langbench/BEFORE.pcre b/tests/langbench/BEFORE.pcre new file mode 100644 index 0000000..e62a0d5 --- /dev/null +++ b/tests/langbench/BEFORE.pcre @@ -0,0 +1,8 @@ +langbench version 0.6 results: +lang cat grep hash loop proc fib sort wc +tcl 0.54 2.61 0.87 0.05 0.91 2.27 2.38 0.80 +tcl 0.53 2.59 0.87 0.05 0.92 2.28 2.36 0.79 +tcl 0.55 2.58 0.87 0.05 0.89 2.32 2.37 0.79 +l 0.56 1.88 0.84 0.04 0.30 2.14 2.64 1.33 +l 0.55 1.87 0.86 0.05 0.30 2.14 2.63 1.30 +l 0.55 1.89 0.85 0.04 0.32 2.15 2.64 1.32 diff --git a/tests/langbench/ChangeLog b/tests/langbench/ChangeLog new file mode 100644 index 0000000..d8c6cec --- /dev/null +++ b/tests/langbench/ChangeLog @@ -0,0 +1,10 @@ +0.6 + - Make the grep expr be [^A-Za-z]fopen\(.*\) since that is not + trivially optimized. + - Add fibonacci benchmark. + - Make the procedure calls take more arguments. + - add a findtclsh so that if you run this in a tcl source tree + under tests/langbench it just works. + - Allow setting of each language with RUBY=/build/ruby/ruby + (for testing new versions like the ruby with a byte code + compiler). diff --git a/tests/langbench/PERF_LOG b/tests/langbench/PERF_LOG new file mode 100644 index 0000000..2e8ce52 --- /dev/null +++ b/tests/langbench/PERF_LOG @@ -0,0 +1,20 @@ +2.6ghz T61 + +2008-02-02 + +lang cat grep hash loop proc fib sort wc +pl 0.35 0.34 0.62 0.07 0.40 3.65 2.19 1.00 +py 0.45 1.48 0.49 0.15 0.22 1.21 2.15 0.49 +rb 0.82 0.73 1.57 0.28 1.12 3.94 4.28 3.10 +tcl 0.78 0.93 1.11 0.05 0.99 3.54 2.84 1.16 +l 0.79 0.93 1.13 0.05 0.46 3.42 2.98 1.86 + +2008-04-10 + +lang cat grep hash loop proc fib sort wc +pl 0.38 0.36 0.64 0.07 0.42 3.90 2.27 1.04 +py 0.48 1.55 0.51 0.16 0.23 1.26 2.24 0.51 +rb 0.87 0.76 1.63 0.29 1.18 4.17 4.53 3.23 +tcl 0.84 1.05 1.19 0.06 1.06 3.75 2.91 1.23 +l 0.84 1.02 1.22 0.05 0.46 3.66 2.90 1.85 + diff --git a/tests/langbench/README b/tests/langbench/README new file mode 100644 index 0000000..f8007ba --- /dev/null +++ b/tests/langbench/README @@ -0,0 +1,56 @@ +langbench is a simplistic set of microbenchmarks designed to see how +well a scripting language performs at basic operations. The intent is to +have a set of tests that encourage each language team to optimize their +language in a way that would benefit the widest possible set of users. +The version number of this test suite will be 1.0 when there is widespread +agreement that these are the "right" set of benchmarks, much like lmbench +was the "right" set of benchmarks for operating systems. + +We (BitKeeper Inc) are using it to benchmark our scripting language, you can +use it for whatever you like. + +You may use for langbench any purpose provided that if you use the +"langbench" name you report all results for all languages like so: + +langbench version 0.5 results: +lang cat grep hash loop proc sort split +pl 0.85 0.85 1.38 0.24 0.68 4.72 5.13 +py 0.81 2.97 1.03 0.34 0.40 4.37 1.56 +rb 1.81 1.68 4.18 0.53 1.04 8.00 3.66 +tcl 2.02 1.45 2.44 0.13 0.72 7.48 3.93 +l 2.02 1.48 2.43 0.12 0.73 8.11 3.94 + +langbench version 0.6 results (faster cpu accounts for some diffs): +lang cat grep hash loop proc fib sort wc +pl 0.37 0.34 0.62 0.11 0.38 4.35 2.02 1.03 +py 0.38 1.99 0.46 0.18 0.21 1.08 1.83 0.48 +rb 0.84 0.81 1.98 0.31 0.59 2.95 3.33 2.33 +tcl 0.75 2.64 1.09 0.07 0.89 2.65 3.46 0.90 +l 0.71 2.03 1.14 0.07 0.29 2.49 3.88 1.54 + +with the exception that you may leave off the L language until it is +widely distributed (defined as apt-get install l just works or is +included with the tcl package). + +Note that for the cat, grep, hash, loop, proc, sort benchmarks the number +printed is the microseconds for the implied operation, i.e., for cat, +it is usecs/line, for sort it is the usecs/line to sort and print each +line, etc. + +Test descriptions: + cat copy stdin to stdout + grep match a regular expression against stdin, print each match + hash use each line of stdin as a hash key, value is 1. + loop measure the cost of a loop + proc measure procedure call cost + sort sorts stdin to stdout + split [Not used because the semantics are different across langs] + +Input data is a million lines of code generated like this: + + for i in 1 2 3 4 5 6 7 8 9 0 + do cat tcl/generic/*.[ch] + done | head -1000000 > DATA + +This file and tests are at http://www.bitkeeper.com/lm/langbench.shar + diff --git a/tests/langbench/RUN b/tests/langbench/RUN new file mode 100644 index 0000000..bbb8eaf --- /dev/null +++ b/tests/langbench/RUN @@ -0,0 +1,58 @@ +test X$LANGBENCH = X && { + LANGBENCH=. + test -d langbench && LANGBENCH=langbench +} +test X$TCLSH = X && { + test -x gui/bin/tclsh && TCLSH=gui/bin/tclsh + test -x ../gui/bin/tclsh && TCLSH=../gui/bin/tclsh +} +test X$TCLSH = X && { + echo Please set TCLSH + exit 1 +} +test X$PERL = X && PERL=perl +test X$PYTHON = X && PYTHON=python +test X$RUBY = X && RUBY=ruby +test "X$LANGS" = X && LANGS="pl py rb tcl l" +test "X$TESTS" = X && TESTS="cat grep hash loop proc fib sort wc" +export TCL_REGEXP_PCRE=1 +echo "langbench version 0.6 results:" +echo -n "lang " +for i in $TESTS +do echo -n "$i " +done +echo "" +for lang in $LANGS +do + case $lang in + pl) CMD=$PERL;; + py) CMD=$PYTHON;; + rb) CMD=$RUBY;; + tcl|l) CMD=$TCLSH;; + esac + N=1 + test X$RUNS = X || N=$RUNS + while (($N > 0)) + do + printf "%-8s" $lang + for test in $TESTS + do + DATA=DATA + test $test = wc && DATA=SMALL + export LANG_TEST=$test + for run in 1 2 3 + do time $CMD $LANGBENCH/${test}.${lang} $DATA > /dev/null + done 2>&1 | + perl -e '$min = 1000000; + while (<>) { + if (/real.*0m(.*)s/) { + $min = $1 if $1 < $min; + } + } + printf "%-8.2f", $min;' + done + printf "\n" + N=`expr $N - 1` + done +done +exit 0 diff --git a/tests/langbench/WEIRD b/tests/langbench/WEIRD new file mode 100644 index 0000000..b6a2533 --- /dev/null +++ b/tests/langbench/WEIRD @@ -0,0 +1,9 @@ +If the regexp is ^$ then the python code gets one more match than the others. + +python's split gets the word count wrong: + + wc -w: 3647213 + perl: 3647213 + ruby: 3647213 + tcl: 3647213 + python: 3647250 diff --git a/tests/langbench/cat.l b/tests/langbench/cat.l new file mode 100644 index 0000000..ca6ca1c --- /dev/null +++ b/tests/langbench/cat.l @@ -0,0 +1,18 @@ +void +main(int ac, string av[]) +{ + string buf; + FILE f; + int i; + + fconfigure("stdout", buffering:"full", translation:"binary"); + for (i = 1; i < ac; ++i) { + unless (f = open(av[i], "rb")) continue; + while (gets(f, &buf) >= 0) { + // roughly 40% slower than puts + // printf("%s\n", buf); + puts(buf); + } + close(f); + } +} diff --git a/tests/langbench/cat.pl b/tests/langbench/cat.pl new file mode 100644 index 0000000..915af0a --- /dev/null +++ b/tests/langbench/cat.pl @@ -0,0 +1,10 @@ +# One could argue this should be +# while ($foo = <>) { chomp($foo); print $foo . "\n"; } +# to match what tcl does. +# That slows it down by a factor of 2. +foreach $file (@ARGV) { + open(FD, $file); + while ($buf = <FD>) { + print $buf; + } +} diff --git a/tests/langbench/cat.py b/tests/langbench/cat.py new file mode 100644 index 0000000..3775fa3 --- /dev/null +++ b/tests/langbench/cat.py @@ -0,0 +1,16 @@ +#!/usr/bin/python +import os +import sys + +def cat(file): + f = open(file) + for line in f: + print line, + f.close() + +def main(): + for a in sys.argv: + cat(a) + +if __name__ == "__main__": + main() diff --git a/tests/langbench/cat.rb b/tests/langbench/cat.rb new file mode 100644 index 0000000..2eaf834 --- /dev/null +++ b/tests/langbench/cat.rb @@ -0,0 +1,3 @@ +while line = gets() + print line +end diff --git a/tests/langbench/cat.tcl b/tests/langbench/cat.tcl new file mode 100644 index 0000000..ebf83a5 --- /dev/null +++ b/tests/langbench/cat.tcl @@ -0,0 +1,9 @@ +proc cat {file} { + set f [open $file rb] + while {[gets $f buf] >= 0} { puts $buf } + close $f +} +fconfigure stdout -buffering full -translation binary +foreach file $argv { + cat $file +} diff --git a/tests/langbench/fib.l b/tests/langbench/fib.l new file mode 100644 index 0000000..dfb1e52 --- /dev/null +++ b/tests/langbench/fib.l @@ -0,0 +1,20 @@ + +int +fib(int n) +{ + if (n < 2) { + return (n); + } else { + return (fib(n - 1) + fib(n - 2)); + } +} + +void +main() +{ + int i; + + for (i = 0; i <= 30; ++i) { + printf("n=%d => %d\n", i, fib(i)); + } +} diff --git a/tests/langbench/fib.pl b/tests/langbench/fib.pl new file mode 100644 index 0000000..603a989 --- /dev/null +++ b/tests/langbench/fib.pl @@ -0,0 +1,11 @@ +sub fib +{ + my($n) = @_[0]; + + return $n if $n < 2; + return &fib($n - 1) + &fib($n - 2); +} + +for ($i = 0; $i <= 30; ++$i) { + printf "n=%d => %d\n", $i, &fib($i); +} diff --git a/tests/langbench/fib.py b/tests/langbench/fib.py new file mode 100644 index 0000000..f369a4c --- /dev/null +++ b/tests/langbench/fib.py @@ -0,0 +1,8 @@ +def fib(n): + if n < 2: + return n + else: + return fib(n-1) + fib(n-2) + +for i in range(30): + print "n=%d => %d" % (i, fib(i)) diff --git a/tests/langbench/fib.rb b/tests/langbench/fib.rb new file mode 100644 index 0000000..225c7bf --- /dev/null +++ b/tests/langbench/fib.rb @@ -0,0 +1,11 @@ +def fib(n) + if n < 2 + n + else + fib(n-1) + fib(n-2) + end +end + +30.times do |i| + puts "n=#{i} => #{fib(i)}" +end diff --git a/tests/langbench/fib.tcl b/tests/langbench/fib.tcl new file mode 100644 index 0000000..a107b7d --- /dev/null +++ b/tests/langbench/fib.tcl @@ -0,0 +1,11 @@ +proc fib {n} { + # Very bogus we have to do {$n - 1} to get performance. + # But if we don't this takes 35 seconds. Tcl has issues. + expr {$n < 2 ? 1 : [fib [expr {$n -2}]] + [fib [expr {$n -1}]]} +} + +set i 0 +while {$i <= 30} { + puts "n=$i => [fib $i]" + incr i +} diff --git a/tests/langbench/findtcl b/tests/langbench/findtcl new file mode 100755 index 0000000..338ab63 --- /dev/null +++ b/tests/langbench/findtcl @@ -0,0 +1,26 @@ +#!/bin/sh + +test X$TCL = X || { + echo $TCL + exit 0 +} + +# If langbench is in the bk source tree, tcl is at ../gui/tcltk/tcl +test -d ../gui/tcltk/tcl/generic && { + echo ../gui/tcltk/tcl + exit 0 +} + +# If langbench is in the tcl source tree, it is likely at tests/langbench +# or tests. +test -d ../tests -a -d ../generic && { + echo .. + exit 0 +} +test -d ../../tests -a -d ../../generic && { + echo ../.. + exit 0 +} + +echo "Can't find tcl source tree, set a path to one with TCL" 1>&2 +exit 1 diff --git a/tests/langbench/findtclsh b/tests/langbench/findtclsh new file mode 100755 index 0000000..e679716 --- /dev/null +++ b/tests/langbench/findtclsh @@ -0,0 +1,35 @@ +#!/bin/sh + +test X$TCLSH = X || { + echo $TCLSH + exit 0 +} + +# If langbench is in the bk source tree, tcl is at ../gui/tcltk/tcl +test -d ../gui/tcltk/tcl/generic && { + if [ -d C:/ ] + then echo ../gui/tcltk/tcl/win/tclsh85.exe + else echo ../gui/tcltk/tcl/unix/tclsh + fi + exit 0 +} + +# If langbench is in the tcl source tree, it is likely at tests/langbench +# or tests. +test -d ../tests -a -d ../generic && { + if [ -d C:/ ] + then echo ../win/tclsh85.exe + else echo ../unix/tclsh + fi + exit 0 +} +test -d ../../tests -a -d ../../generic && { + if [ -d C:/ ] + then echo ../../win/tclsh85.exe + else echo ../../unix/tclsh + fi + exit 0 +} + +echo "Can't find tclsh, set a path to one with TCLSH" 1>&2 +exit 1 diff --git a/tests/langbench/grep.l b/tests/langbench/grep.l new file mode 100644 index 0000000..96c255e --- /dev/null +++ b/tests/langbench/grep.l @@ -0,0 +1,15 @@ +void +main(int ac, string av[]) +{ + string buf; + int i; + FILE f; + + for (i = 1; i < ac; ++i) { + f = open(av[i], "rb"); + while (gets(f, &buf) >= 0) { + if (buf =~ /[^A-Za-z]fopen\(.*\)/) puts(buf); + } + close(f); + } +} diff --git a/tests/langbench/grep.pl b/tests/langbench/grep.pl new file mode 100644 index 0000000..9357302 --- /dev/null +++ b/tests/langbench/grep.pl @@ -0,0 +1,3 @@ +while (<>) { + print if /[^A-Za-z]fopen\(.*\)/; +} diff --git a/tests/langbench/grep.py b/tests/langbench/grep.py new file mode 100644 index 0000000..aa50e96 --- /dev/null +++ b/tests/langbench/grep.py @@ -0,0 +1,12 @@ +import os +import sys +import re + +p = re.compile('[^A-Za-z]fopen\(.*\)') +for a in sys.argv: + f = open(a) + for line in f: + m = p.search(line) + if m: + print line, + f.close() diff --git a/tests/langbench/grep.rb b/tests/langbench/grep.rb new file mode 100644 index 0000000..a13f8fe --- /dev/null +++ b/tests/langbench/grep.rb @@ -0,0 +1,4 @@ +re = Regexp.compile("[^A-Za-z]fopen\\(.*\\)") +while line = gets() + print if re =~ line +end diff --git a/tests/langbench/grep.tcl b/tests/langbench/grep.tcl new file mode 100644 index 0000000..c2ad946 --- /dev/null +++ b/tests/langbench/grep.tcl @@ -0,0 +1,12 @@ +proc grep {file} { + set f [open $file rb] + set buf "" + while {[gets $f buf] >= 0} { + if {[regexp -- {[^A-Za-z]fopen\(.*\)} $buf]} { puts $buf } + } + close $f +} +fconfigure stdout -translation binary +foreach file $argv { + grep $file +} diff --git a/tests/langbench/hash.l b/tests/langbench/hash.l new file mode 100644 index 0000000..ab10f2e --- /dev/null +++ b/tests/langbench/hash.l @@ -0,0 +1,17 @@ +void +main(int ac, string av[]) +{ + int i; + string buf; + hash h; + FILE f; + + + for (i = 1; i < ac; ++i) { + f = open(av[i], "rb"); + while (gets(f, &buf) >= 0) { + h{buf} = 1; + } + close(f); + } +} diff --git a/tests/langbench/hash.pl b/tests/langbench/hash.pl new file mode 100644 index 0000000..46e1b9a --- /dev/null +++ b/tests/langbench/hash.pl @@ -0,0 +1,5 @@ +while (<>) { + $hash{$_} = 1; +} +open(FD, "/proc/$$/status"); +while (<FD>) { print if /^Vm[RD]/; } diff --git a/tests/langbench/hash.py b/tests/langbench/hash.py new file mode 100644 index 0000000..07e8bca --- /dev/null +++ b/tests/langbench/hash.py @@ -0,0 +1,16 @@ +import os +import sys +import re + +d = {} +for a in sys.argv: + f = open(a) + for line in f: + d[line] = 1 + f.close +p = re.compile("^Vm[RD]") +f = open("/proc/%d/status" % os.getpid()) +for line in f: + m = p.match(line) + if m: + print line, diff --git a/tests/langbench/hash.rb b/tests/langbench/hash.rb new file mode 100644 index 0000000..5b30f3e --- /dev/null +++ b/tests/langbench/hash.rb @@ -0,0 +1,10 @@ +hash = {} +while line = gets() + hash[line] = 1 +end + +fd = File.open("/proc/#{$$}/status") +while $_ = fd.gets + print if $_ =~ /^Vm[RD]/ +end +fd.close diff --git a/tests/langbench/hash.tcl b/tests/langbench/hash.tcl new file mode 100644 index 0000000..0b1afa8 --- /dev/null +++ b/tests/langbench/hash.tcl @@ -0,0 +1,17 @@ +proc main {} { + global argv + + set d [dict create] + foreach file $argv { + set f [open $file rb] + while {[gets $f buf] >= 0} { + dict set d $buf 1 + } + close $f + } +} +main +set f [open "/proc/[pid]/status"] +while {[gets $f buf] >= 0} { + if {[regexp {^Vm[RD]} $buf]} { puts $buf } +} diff --git a/tests/langbench/loop.l b/tests/langbench/loop.l new file mode 100644 index 0000000..f62ff01 --- /dev/null +++ b/tests/langbench/loop.l @@ -0,0 +1,11 @@ +void +doit(int n) +{ + while (n-- > 0); +} + +void +main() +{ + doit(1000000); +} diff --git a/tests/langbench/loop.pl b/tests/langbench/loop.pl new file mode 100644 index 0000000..6f71a23 --- /dev/null +++ b/tests/langbench/loop.pl @@ -0,0 +1,2 @@ +$n = 1000000; +while ($n > 0) { $n--; } diff --git a/tests/langbench/loop.py b/tests/langbench/loop.py new file mode 100644 index 0000000..2fb1363 --- /dev/null +++ b/tests/langbench/loop.py @@ -0,0 +1,3 @@ +n = 1000000 +while n > 0: + n = n - 1 diff --git a/tests/langbench/loop.rb b/tests/langbench/loop.rb new file mode 100644 index 0000000..f6a3e16 --- /dev/null +++ b/tests/langbench/loop.rb @@ -0,0 +1,4 @@ +n = 1000000 +while n > 0 + n -= 1 +end diff --git a/tests/langbench/loop.tcl b/tests/langbench/loop.tcl new file mode 100644 index 0000000..c1de6f7 --- /dev/null +++ b/tests/langbench/loop.tcl @@ -0,0 +1,4 @@ +proc doit {n} { + while {$n > 0} { incr n -1 } +} +doit 1000000 diff --git a/tests/langbench/proc.l b/tests/langbench/proc.l new file mode 100644 index 0000000..7ac1fe6 --- /dev/null +++ b/tests/langbench/proc.l @@ -0,0 +1,20 @@ +int a(int val) { return b(val); } +int b(int val) { return c(val); } +int c(int val) { return d(val); } +int d(int val) { return e(val); } +int e(int val) { return f(val); } +int f(int val) { return g(val, 2); } +int g(int v1, int v2) { return h(v1, v2, 3); } +int h(int v1, int v2, int v3) { return i(v1, v2, v3, 4); } +int i(int v1, int v2, int v3, int v4) { return j(v1, v2, v3, v4, 5); } +int j(int v1, int v2, int v3, int v4, int v5) { return v1 + v2 + v3 + v4 + v5; } + +void +main() +{ + int n = 100000; // there are 10 procs, so .1M iterations + int x; + + while (n > 0) { x = a(n); n--; } + printf("x=%d\n", x); +} diff --git a/tests/langbench/proc.pl b/tests/langbench/proc.pl new file mode 100644 index 0000000..7ae5f2e --- /dev/null +++ b/tests/langbench/proc.pl @@ -0,0 +1,13 @@ +sub a { return &b($_[0]); } +sub b { return &c($_[0]); } +sub c { return &d($_[0]); } +sub d { return &e($_[0]); } +sub e { return &f($_[0]); } +sub f { return &g($_[0], 2); } +sub g { return &h($_[0], $_[1], 3); } +sub h { return &i($_[0], $_[1], $_[2], 4); } +sub i { return &j($_[0], $_[1], $_[2], $_[3], 5); } +sub j { return $_[0] + $_[1] + $_[2] + $_[3] + $_[4]; } +$n = 100000; +while ($n > 0) { $x = &a($n); $n--; } +print "$x\n"; diff --git a/tests/langbench/proc.py b/tests/langbench/proc.py new file mode 100644 index 0000000..726b9a5 --- /dev/null +++ b/tests/langbench/proc.py @@ -0,0 +1,28 @@ +#!/usr/bin/python + +def a(val): + return b(val) +def b(val): + return c(val) +def c(val): + return d(val) +def d(val): + return e(val) +def e(val): + return f(val) +def f(val): + return g(val, 2) +def g(v1, v2): + return h(v1, v2, 3) +def h(v1, v2, v3): + return i(v1, v2, v3, 4) +def i(v1, v2, v3, v4): + return j(v1, v2, v3, v4, 5) +def j(v1, v2, v3, v4, v5): + return v1 + v2 + v3 + v4 + v5 + +n = 100000 +while n > 0: + x = a(n) + n = n - 1 +print "x=%d" % x diff --git a/tests/langbench/proc.rb b/tests/langbench/proc.rb new file mode 100644 index 0000000..1c0aae2 --- /dev/null +++ b/tests/langbench/proc.rb @@ -0,0 +1,36 @@ +def a(i) + return b(i) +end +def b(i) + return c(i) +end +def c(i) + return d(i) +end +def d(i) + return e(i) +end +def e(i) + return f(i) +end +def f(i) + return g(i, 2) +end +def g(v1, v2) + return h(v1, v2, 3) +end +def h(v1, v2, v3) + return i(v1, v2, v3, 4) +end +def i(v1, v2, v3, v4) + return j(v1, v2, v3, v4, 5) +end +def j(v1, v2, v3, v4, v5) + return v1 + v2 + v3 + v4 + v5 +end +n = 100000; +while n > 0 + x = a(n) + n -= 1 +end +print "#{x}\n"; diff --git a/tests/langbench/proc.tcl b/tests/langbench/proc.tcl new file mode 100644 index 0000000..034190a --- /dev/null +++ b/tests/langbench/proc.tcl @@ -0,0 +1,16 @@ +proc a {val} { return [b $val] } +proc b {val} { return [c $val] } +proc c {val} { return [d $val] } +proc d {val} { return [e $val] } +proc e {val} { return [f $val] } +proc f {val} { return [g $val 2] } +proc g {v1 v2} { return [h $v1 $v2 3] } +proc h {v1 v2 v3} { return [i $v1 $v2 $v3 4] } +proc i {v1 v2 v3 v4} { return [j $v1 $v2 $v3 $v4 5] } +proc j {v1 v2 v3 v4 v5} { return [expr $v1 + $v2 + $v3 + $v4 + $v5] } +proc main {} { + set n 100000 + while {$n > 0} { set x [a $n]; incr n -1 } + puts $x +} +main diff --git a/tests/langbench/sort.l b/tests/langbench/sort.l new file mode 100644 index 0000000..f36c0e7 --- /dev/null +++ b/tests/langbench/sort.l @@ -0,0 +1,19 @@ +void +main(int ac, string av[]) +{ + int i; + FILE f; + string buf; + string l[]; + + fconfigure("stdout", buffering: "full", translation: "binary"); + for (i = 1; i < ac; ++i) { + f = open(av[i], "rb"); + while (gets(f, &buf) >= 0) { + push(&l, buf); + } + } + foreach (buf in sort(l)) { + puts(buf); + } +} diff --git a/tests/langbench/sort.pl b/tests/langbench/sort.pl new file mode 100644 index 0000000..be73936 --- /dev/null +++ b/tests/langbench/sort.pl @@ -0,0 +1,7 @@ +while (<>) { + push(@l, $_); +} + +foreach $_ (sort(@l)) { + print; +} diff --git a/tests/langbench/sort.py b/tests/langbench/sort.py new file mode 100644 index 0000000..f36bbc1 --- /dev/null +++ b/tests/langbench/sort.py @@ -0,0 +1,13 @@ +import os +import sys +import re + +l = [] +for a in sys.argv: + f = open(a) + for line in f: + l.append(line) + f.close() +l.sort() +for line in l: + print line, diff --git a/tests/langbench/sort.rb b/tests/langbench/sort.rb new file mode 100644 index 0000000..0acbf64 --- /dev/null +++ b/tests/langbench/sort.rb @@ -0,0 +1,8 @@ +l = [] +while gets + l.push($_) +end + +l.sort.each {|p| + print p +} diff --git a/tests/langbench/sort.tcl b/tests/langbench/sort.tcl new file mode 100644 index 0000000..9e353ab --- /dev/null +++ b/tests/langbench/sort.tcl @@ -0,0 +1,20 @@ +proc main {} { + global argv + + foreach file $argv { + set f [open $file rb] + + # Takes 2.7 seconds/12.3 + while {[gets $f buf] >= 0} { + lappend l $buf + } + close $f + } + + # takes 7.9 seconds/12.3 + foreach buf [lsort $l] { + puts $buf + } +} +fconfigure stdout -buffering full -translation binary +main diff --git a/tests/langbench/wc.l b/tests/langbench/wc.l new file mode 100644 index 0000000..f24ec07 --- /dev/null +++ b/tests/langbench/wc.l @@ -0,0 +1,52 @@ +string [] +wordsplit(string str) +{ + string chars[]; + string list[]; + string c, word; + int i; + + word = ""; + chars = split(str, ""); + foreach (c in chars) { + if (string("is", "space", c)) { + if (length(word) > 0) { + push(&list, word); + } + word = ""; + } else { + append(&word, c); + } + } + if (length(word) > 0) { + push(&list, word); + } + return (list); +} + +int +doit(string file) +{ + FILE f = open(file, "rb"); + string buf; + string words[]; + int n; + + while (gets(f, &buf) >= 0) { + words = wordsplit(buf); + n += llength(words); + } + close(f); + return (n); +} + +void +main(int ac, string av[]) +{ + int total, i; + + for (i = 1; i < ac; ++i) { + total += doit(av[i]); + } + printf("%d\n", total); +} diff --git a/tests/langbench/wc.pl b/tests/langbench/wc.pl new file mode 100644 index 0000000..0853908 --- /dev/null +++ b/tests/langbench/wc.pl @@ -0,0 +1,23 @@ +sub wordsplit +{ + chomp($_[0]); + @list = (); + $word = ""; + foreach $c (split(//, $_[0])) { + if ($c =~ /\s/o) { + push(@list, $word) if $word ne ""; + $word = ""; + } else { + $word .= $c; + } + } + push(@list, $word) if $word ne ""; + return @list; +} + +$n = 0; +while (<>) { + @words = &wordsplit($_); + $n += $#words + 1; +} +printf "%d\n", $n; diff --git a/tests/langbench/wc.py b/tests/langbench/wc.py new file mode 100644 index 0000000..d2a8b50 --- /dev/null +++ b/tests/langbench/wc.py @@ -0,0 +1,30 @@ +#!/usr/bin/python +import os +import sys + +def wordsplit(line): + list = [] + word = "" + for c in line: + if c.isspace(): + if len(word) > 0: + list.append(word) + word = "" + else: + word += c + if len(word) > 0: + list.append(word) + return list + +def main(): + n = 0 + for a in sys.argv[1:]: + f = open(a) + for line in f: + words = wordsplit(line) + n += len(words) + f.close() + print "%d\n" % n + +if __name__ == "__main__": + main() diff --git a/tests/langbench/wc.rb b/tests/langbench/wc.rb new file mode 100644 index 0000000..ef19635 --- /dev/null +++ b/tests/langbench/wc.rb @@ -0,0 +1,25 @@ +def wordsplit(line) + list = [] + word = "" + line.split('').each do |c| + if c =~ /\s/ + if word.length > 0 + list << word + end + word = "" + else + word += c + end + end + if word.length > 0 + list << word + end + return list +end + +n = 0 +while line = gets() + words = wordsplit(line) + n += words.length +end +printf("%d\n", n) diff --git a/tests/langbench/wc.tcl b/tests/langbench/wc.tcl new file mode 100644 index 0000000..5dc17aa --- /dev/null +++ b/tests/langbench/wc.tcl @@ -0,0 +1,36 @@ +proc wordsplit {str} { + set list {} + set word {} + foreach char [split $str {}] { + if {[string is space $char]} { + if {[string length $word] > 0} { + lappend list $word + } + set word {} + } else { + append word $char + } + } + if {[string length $word] > 0} { + lappend list $word + } + return $list +} + +proc doit {file} { + set f [open $file r] + fconfigure $f -translation binary + set buf "" + set n 0 + while {[gets $f buf] >= 0} { + set words [wordsplit $buf] + incr n [llength $words] + } + close $f + return $n +} +set total 0 +foreach file $argv { + incr total [doit $file] +} +puts $total diff --git a/tests/reg.test b/tests/reg.test index d040632..2f7e923 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -21,6 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]] ::tcltest::testConstraint testregexp [llength [info commands testregexp]] ::tcltest::testConstraint localeRegexp 0 +::tcltest::testConstraint classicre [string equal [interp regexp {}] classic] # This file uses some custom procedures, defined below, for regexp regression # testing. The name of the procedure indicates the general nature of the @@ -180,7 +181,7 @@ namespace eval RETest { # Share the generation of the list of test constraints so it is # done the same on all routes. proc TestConstraints {flags} { - set constraints [list testregexp] + set constraints [list testregexp classicre] variable regBug if {$regBug} { diff --git a/tests/regexp.test b/tests/regexp.test index 9fff262..ac6f8a3 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } - +interp regexp {} pcre unset -nocomplain foo testConstraint exec [llength [info commands exec]] @@ -247,13 +247,13 @@ test regexp-6.2 {regexp errors} { } {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexp-6.3 {regexp errors} { list [catch {regexp -gorp a} msg] $msg -} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} -test regexp-6.4 {regexp errors} { - list [catch {regexp a( b} msg] $msg -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} -test regexp-6.5 {regexp errors} { +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, -type, or --}} +test regexp-6.4 {regexp errors} -body { list [catch {regexp a( b} msg] $msg -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} +} -match glob -result {1 {couldn't compile*}} +test regexp-6.5 {regexp errors} -body { + list [catch {regexp a) b} msg] $msg +} -match glob -result {1 {couldn't compile*}} test regexp-6.6 {regexp errors} { list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg } {0 1} @@ -453,10 +453,10 @@ test regexp-11.4 {regsub errors} { } {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} -test regexp-11.6 {regsub errors} { +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, -type, or --}} +test regexp-11.6 {regsub errors} -body { list [catch {regsub -nocase a( b c d} msg] $msg -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} +} -match glob -result {1 {couldn't compile*}} test regexp-11.7 {regsub errors} -setup { unset -nocomplain f1 } -body { diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 01ef06d..088b73f 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -326,17 +326,17 @@ test regexpComp-6.3 {regexp errors} { evalInProc { list [catch {regexp -gorp a} msg] $msg } -} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} -test regexpComp-6.4 {regexp errors} { +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, -type, or --}} +test regexpComp-6.4 {regexp errors} -body { evalInProc { list [catch {regexp a( b} msg] $msg } -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} -test regexpComp-6.5 {regexp errors} { +} -match glob -result {1 {couldn't compile*}} +test regexpComp-6.5 {regexp errors} -body { evalInProc { - list [catch {regexp a( b} msg] $msg + list [catch {regexp a) b} msg] $msg } -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} +} -match glob -result {1 {couldn't compile*}} test regexpComp-6.6 {regexp errors} { evalInProc { list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg @@ -587,12 +587,12 @@ test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} -test regexpComp-11.6 {regsub errors} { +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, -type, or --}} +test regexpComp-11.6 {regsub errors} -body { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg } -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} +} -match glob -result {1 {couldn't compile*}} test regexpComp-11.7 {regsub errors} { evalInProc { unset -nocomplain f1 @@ -965,12 +965,12 @@ test regexpComp-24.8 {regexp command compiling tests} { regexp -- $re dogfod } } 0 -test regexpComp-24.9 {regexp command compiling tests} { +test regexpComp-24.9 {regexp command compiling tests} -body { evalInProc { set re "(" list [catch {regexp -- $re dogfod} msg] $msg } -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} +} -match glob -result {1 {couldn't compile*}} test regexpComp-24.10 {regexp command compiling tests} { # Bug 1902436 - last * escaped evalInProc { |