|
|
Author: Whiteknight
Date: Thu Jul 24 13:41:24 2008
New Revision: 29730
Removed:
branches/gsoc_pdd09/languages/tcl/runtime/list_to_string.pir
Modified:
branches/gsoc_pdd09/MANIFEST
branches/gsoc_pdd09/config/gen/call_list/misc.in
branches/gsoc_pdd09/config/init/hints/darwin.pm
branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data
branches/gsoc_pdd09/languages/tcl/config/makefiles/root.in
branches/gsoc_pdd09/languages/tcl/lib/skipped_tests.tcl
branches/gsoc_pdd09/languages/tcl/lib/test_more.tcl
branches/gsoc_pdd09/languages/tcl/runtime/builtin/catch.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/dict.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/eval.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/expr.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/fileevent.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/foreach.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/gets.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/if.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/info.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/lindex.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/linsert.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/lreplace.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/lset.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/namespace.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/parray.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/proc.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/puts.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/source.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/string.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/subst.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/switch.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/trace.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/uplevel.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/upvar.pir
branches/gsoc_pdd09/languages/tcl/runtime/builtin/variable.pir
branches/gsoc_pdd09/languages/tcl/runtime/conversions.pir
branches/gsoc_pdd09/languages/tcl/runtime/options.pir
branches/gsoc_pdd09/languages/tcl/runtime/string_to_list.pir
branches/gsoc_pdd09/languages/tcl/runtime/tcllib.pir
branches/gsoc_pdd09/languages/tcl/runtime/variables.pir
branches/gsoc_pdd09/languages/tcl/src/builtin/expr.pir
branches/gsoc_pdd09/languages/tcl/src/builtin/lrange.tmt
branches/gsoc_pdd09/languages/tcl/src/grammar/expr/past.pir
branches/gsoc_pdd09/languages/tcl/src/pmc/tcldict.pmc
branches/gsoc_pdd09/languages/tcl/src/tclsh.pir
branches/gsoc_pdd09/languages/tcl/t/cmd_binary.t
branches/gsoc_pdd09/languages/tcl/tools/gen_inline.pl
branches/gsoc_pdd09/src/libnci_test.def
branches/gsoc_pdd09/src/nci_test.c
branches/gsoc_pdd09/t/pmc/nci.t
branches/gsoc_pdd09/tools/build/nativecall.pl
Log:
[gsoc_pdd09] updating to trunk r29729
Modified: branches/gsoc_pdd09/MANIFEST
==============================================================================
--- branches/gsoc_pdd09/MANIFEST (original)
+++ branches/gsoc_pdd09/MANIFEST Thu Jul 24 13:41:24 2008
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Tue Jul 22 18:07:34 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Thu Jul 24 03:13:28 2008 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -2545,7 +2545,6 @@
languages/tcl/runtime/builtin/variable.pir [tcl]
languages/tcl/runtime/builtin/vwait.pir [tcl]
languages/tcl/runtime/conversions.pir [tcl]
-languages/tcl/runtime/list_to_string.pir [tcl]
languages/tcl/runtime/options.pir [tcl]
languages/tcl/runtime/string_to_list.pir [tcl]
languages/tcl/runtime/tcllib.pir [tcl]
Modified: branches/gsoc_pdd09/config/gen/call_list/misc.in
==============================================================================
--- branches/gsoc_pdd09/config/gen/call_list/misc.in (original)
+++ branches/gsoc_pdd09/config/gen/call_list/misc.in Thu Jul 24 13:41:24 2008
@@ -353,3 +353,6 @@
i JOt
i Jt
i Ji
+
+v Vi
+v p
Modified: branches/gsoc_pdd09/config/init/hints/darwin.pm
==============================================================================
--- branches/gsoc_pdd09/config/init/hints/darwin.pm (original)
+++ branches/gsoc_pdd09/config/init/hints/darwin.pm Thu Jul 24 13:41:24 2008
@@ -20,7 +20,7 @@
# requested by command-line options and force a single, native
# architecture to being the default build.
my @flags = qw(ccflags linkflags ldflags ld_share_flags ld_load_flags);
- my @arches = qw(i386 ppc ppc64 x86_64);
+ my @arches = qw(i386 ppc64 ppc x86_64);
print "\nChecking for -arch flags not explicitly added:\n" if $verbose;
for my $flag (@flags) {
Modified: branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data
==============================================================================
--- branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data
(original)
+++ branches/gsoc_pdd09/languages/perl6/t/spectest_regression.data Thu Jul
24 13:41:24 2008
@@ -55,8 +55,11 @@
S06-signature/named-placeholders.t # pure
S06-signature/positional-placeholders.t # pure
S06-signature/slurpy-placeholders.t # pure
+S06-traits/is-copy.t # pure
+S06-traits/is-rw.t
S12-class/anonymous.t # pure
S12-class/attributes.t # pure
+S12-class/inheritance.t
S12-class/inheritance-class-methods.t
S12-class/instantiate.t # pure
S12-class/parent_attributes.t # pure
Modified: branches/gsoc_pdd09/languages/tcl/config/makefiles/root.in
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/config/makefiles/root.in (original)
+++ branches/gsoc_pdd09/languages/tcl/config/makefiles/root.in Thu Jul 24
13:41:24 2008
@@ -66,7 +66,6 @@
$(C_BUILTIN)/list.pir \
$(C_BUILTIN)/return.pir \
runtime/conversions.pir \
-runtime/list_to_string.pir \
runtime/string_to_list.pir \
runtime/variables.pir \
runtime/options.pir \
Modified: branches/gsoc_pdd09/languages/tcl/lib/skipped_tests.tcl
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/lib/skipped_tests.tcl (original)
+++ branches/gsoc_pdd09/languages/tcl/lib/skipped_tests.tcl Thu Jul 24
13:41:24 2008
@@ -1,11 +1,35 @@
# skipped_tests - these are all the tests that the partcl implementation
-# cannot pass. Some of the tests cause harness failures (see RT#40716),
-# others simply require some functionality that we haven't implemented yet.
+# not only cannot pass, but cannot compile, or causes a parrot segfault, etc.
+# must use exact test names.
+#
+# todo_tests - these are the tests that are known to fail because they
+# require a feature we haven't implemented yet. Can use globs to specify
+# a range of skippable tests.
#
# stored as a dictionary, with the reason as a key, and the list of tests
# that require the feature (or cause the listed error) as values.
-set skipped_tests [dict create \
+set todo_tests [dict create \
+ {list to string improvements} {
+ list-1.1[23] list-1.26
+ } {parsing errors} {
+ list-1.1[56]
+ } {[trace]} {
+ append-7.[12345]
+ appendComp-7.[123456789]
+ if-10.6
+ lset-1.3 lset-5.[12]
+ } {stacktrace support} {
+ apply-2.[2345] apply-5.1
+ if-5.3 if-6.4
+ } {tcltest: need better [testevalex]} {
+ lset-2.2 lset-7.[12] lset-10.3 lset-13.[012] lset-14.[12]
+ } {[apply]} {
+ apply-[4678].*
+ }
+]
+
+set skip_tests [dict create \
{[binary]} {
string-5.14 string-5.15 string-5.16 string-12.21
stringComp-5.14 stringComp-5.15 stringComp-5.16 stringComp-9.7
@@ -14,20 +38,13 @@
} {[subst]} {
parse-18.9 parse-18.12
} {[trace]} {
- append-7.1 append-7.2 append-7.3 append-7.4 append-7.5
- appendComp-7.1 appendComp-7.2 appendComp-7.3 appendComp-7.4 appendComp-7.5
- appendComp-7.6 appendComp-7.7 appendComp-7.8 appendComp-7.9
- if-10.6
- lset-1.3 lset-5.1 lset-5.2
} {stacktrace support} {
- apply-2.2 apply-2.3 apply-2.4 apply-2.5 apply-5.1
basic-46.1
cmdMZ-return-2.10 cmdMZ-3.5 cmdMZ-5.7
dict-14.12 dict-17.13
error-1.3 error-2.3 error-2.6 error-4.2 error-4.3 error-4.4
eval-2.5
iocmd-12.6
- if-5.3 if-6.4
incr-2.30 incr-2.31
incr-old-2.4 incr-old-2.5
misc-1.2
@@ -88,7 +105,7 @@
namespace-27.2 namespace-27.3
} {nested dictionaries} {
dict-3.5 dict-3.6 dict-3.7 dict-3.8 dict-3.9 dict-3.10 dict-9.3 dict-9.4
- dict-9.5 dict-15.3 dict-15.5 dict-16.4
+ dict-9.5 dict-15.3 dict-15.5 dict-16.4 dict-21.16
} {support for the variable named ""} {
var-6.3 var-7.12 var-12.1
} {Cannot get character past end of string} {
@@ -231,7 +248,6 @@
# stored as an array of test name -> reason pairs.
array set abort_after {
- apply-2.1 {}
assocd-1.1 {}
async-1.1 {}
autoMkindex-1.1 {}
Modified: branches/gsoc_pdd09/languages/tcl/lib/test_more.tcl
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/lib/test_more.tcl (original)
+++ branches/gsoc_pdd09/languages/tcl/lib/test_more.tcl Thu Jul 24 13:41:24 2008
@@ -121,29 +121,51 @@
# A placeholder that simulates the real tcltest's exported test proc.
proc test {num description args} {
- global skipped_tests
+ global skip_tests
+ global todo_tests
global abort_after
- if {![info exists skipped_tests]} {
+ if {![info exists skip_tests]} {
# get listing of all the tests we can't run.
source lib/skipped_tests.tcl
}
set full_desc "$num $description"
- set should_skip [dict filter $skipped_tests script {K V} {
+ set should_skip [dict filter $skip_tests script {K V} {
set val [lsearch -exact $V $num]
expr {$val != -1}
}]
- set reason [dict keys $should_skip]
+ set skip_reason [dict keys $should_skip]
- if {[string length $reason]} {
- pass $full_desc [list SKIP $reason]
+ set should_todo [dict filter $todo_tests script {K V} {
+ set matched no
+ foreach element $V {
+ if {[string match $element $num]} {
+ set matched yes
+ break
+ }
+ }
+ set matched
+ }]
+
+ set todo_reason [dict keys $should_todo]
+
+ if {[string length $skip_reason]} {
+ pass $full_desc [list SKIP $skip_reason]
} elseif {[llength $args] == 2} {
- eval_is [lindex $args 0] [lindex $args 1] $full_desc
+ if {[string length $todo_reason]} {
+ eval_is [lindex $args 0] [lindex $args 1] $full_desc "TODO
{$todo_reason}"
+ } else {
+ eval_is [lindex $args 0] [lindex $args 1] $full_desc
+ }
} elseif {[llength $args] == 3} {
# XXX : we're just skipping the constraint here...
- eval_is [lindex $args 1] [lindex $args 2] $full_desc
+ if {[string length $todo_reason]} {
+ eval_is [lindex $args 1] [lindex $args 2] $full_desc "TODO
{$todo_reason}"
+ } else {
+ eval_is [lindex $args 1] [lindex $args 2] $full_desc
+ }
} else {
# Skip test if too many or two few args.
pass $full_desc [list SKIP {can't deal with this version of test yet}]
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/catch.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/catch.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/catch.pir Thu Jul 24
13:41:24 2008
@@ -16,15 +16,15 @@
$P0 = getinterp
ns = $P0['namespace'; 1]
- .local pmc __script
- __script = get_root_global ['_tcl'], '__script'
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
if argc == 0 goto bad_args
if argc > 3 goto bad_args
code = argv[0]
push_eh non_ok
- $P2 = __script(code, 'ns' => ns)
+ $P2 = compileTcl(code, 'ns' => ns)
code_retval = $P2()
retval = .CONTROL_OK
pop_eh
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/dict.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/dict.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/dict.pir Thu Jul 24
13:41:24 2008
@@ -204,9 +204,9 @@
options[1] = 'script'
options[2] = 'value'
- .local pmc select_option, __script, toBoolean
+ .local pmc select_option, compileTcl, toBoolean
select_option = get_root_global ['_tcl'], 'select_option'
- __script = get_root_global ['_tcl'], '__script'
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
toBoolean = get_root_global ['_tcl'], 'toBoolean'
.local pmc option
option = shift argv
@@ -270,7 +270,7 @@
.local pmc retval
retval = new 'TclDict'
.local pmc body_proc
- body_proc = __script(body)
+ body_proc = compileTcl(body)
.local pmc check_key,check_value
script_loop:
@@ -321,7 +321,7 @@
.local pmc set, script
set = get_root_global ['_tcl'], 'setVar'
- script = get_root_global ['_tcl'], '__script'
+ script = get_root_global ['_tcl'], 'compileTcl'
.local pmc varNames
.local string keyVar, valueVar
@@ -339,7 +339,7 @@
.local pmc body,code
body = shift argv
- code = __script(body)
+ code = compileTcl(body)
.local pmc iterator
iterator = new 'Iterator', dictionary
@@ -903,7 +903,7 @@
done_key_loop:
# run the body of the script. save the return vaalue.
.local pmc retval
- $P1 = __script(body)
+ $P1 = compileTcl(body)
retval = $P1()
# go through the varnames, setting the appropriate keys to those values.
@@ -1028,7 +1028,7 @@
goto alias_keys
done_alias:
.local pmc retval
- $P1 = __script(body)
+ $P1 = compileTcl(body)
retval = $P1()
iterator = new 'Iterator', dictionary
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/eval.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/eval.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/eval.pir Thu Jul 24
13:41:24 2008
@@ -18,12 +18,12 @@
$P0 = getinterp
ns = $P0['namespace'; 1]
- .local pmc __script
- __script = get_root_global ['_tcl'], '__script'
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
.local string code
code = join ' ', argv
- $P2 = __script(code, 'ns'=>ns)
+ $P2 = compileTcl(code, 'ns'=>ns)
.return $P2()
bad_args:
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/expr.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/expr.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/expr.pir Thu Jul 24
13:41:24 2008
@@ -14,8 +14,8 @@
.local int argc
.local int looper
- .local pmc __expr
- __expr = get_root_global ['_tcl'], '__expr'
+ .local pmc compileExpr
+ compileExpr = get_root_global ['_tcl'], 'compileExpr'
expr = ''
looper = 0
@@ -29,7 +29,7 @@
$P0 = getinterp
ns = $P0['namespace'; 1]
- $P1 = __expr(expr, 'ns'=>ns)
+ $P1 = compileExpr(expr, 'ns'=>ns)
$P2 = $P1()
.return ($P2)
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/fileevent.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/fileevent.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/fileevent.pir Thu Jul
24 13:41:24 2008
@@ -10,9 +10,9 @@
if argc < 2 goto badargs
if argc > 3 goto badargs
- .local pmc __channel, __script
- __channel = get_root_global ['_tcl'], '__channel'
- __script = get_root_global ['_tcl'], '__script'
+ .local pmc getChannel, compileTcl
+ getChannel = get_root_global ['_tcl'], 'getChannel'
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
.local pmc channel, script
.local string event
@@ -26,13 +26,13 @@
tcl_error $S0
readable:
- channel = __channel(channel)
+ channel = getChannel(channel)
if argc == 2 goto readable_2
.local pmc script
script = args[2]
- script = __script(script)
+ script = compileTcl(script)
.local pmc events
events = get_root_global ['_tcl'], 'events'
@@ -47,7 +47,7 @@
.return('')
writable:
- channel = __channel(channel)
+ channel = getChannel(channel)
.return('')
badargs:
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/foreach.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/foreach.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/foreach.pir Thu Jul
24 13:41:24 2008
@@ -17,16 +17,16 @@
$P0 = getinterp
ns = $P0['namespace'; 1]
- .local pmc toList, __script, setVar
+ .local pmc toList, compileTcl, setVar
toList = get_root_global ['_tcl'], 'toList'
- __script = get_root_global ['_tcl'], '__script'
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
setVar = get_root_global ['_tcl'], 'setVar'
.local pmc varLists, lists, command
varLists = new 'TclList'
lists = new 'TclList'
command = pop argv
- command = __script(command, 'ns'=>ns)
+ command = compileTcl(command, 'ns'=>ns)
.local int iterations
iterations = 0
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/gets.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/gets.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/gets.pir Thu Jul 24
13:41:24 2008
@@ -18,11 +18,11 @@
.local string channelID
channelID = argv[0]
- .local pmc __channel
- __channel = get_root_global ['_tcl'], '__channel'
+ .local pmc getChannel
+ getChannel = get_root_global ['_tcl'], 'getChannel'
.local pmc io
- io = __channel(channelID)
+ io = getChannel(channelID)
$S0 = typeof io
if $S0 == 'TCPStream' goto stream
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/if.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/if.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/if.pir Thu Jul 24
13:41:24 2008
@@ -10,8 +10,8 @@
.local int argc
argc = elements argv
- .local pmc __expr
- __expr = get_root_global ['_tcl'], '__expr'
+ .local pmc compileExpr
+ compileExpr = get_root_global ['_tcl'], 'compileExpr'
if argc == 0 goto no_args
@@ -26,7 +26,7 @@
# convert to the expression to a Sub
$S0 = argv[0]
- $P0 = __expr($S0, 'ns'=>ns)
+ $P0 = compileExpr($S0, 'ns'=>ns)
$I0 = 1
if $I0 == argc goto no_script
@@ -61,7 +61,7 @@
# convert to the expression to a Sub
$S0 = argv[$I0]
- $P0 = __expr($S0)
+ $P0 = compileExpr($S0)
inc $I0
if $I0 == argc goto no_script
@@ -90,8 +90,8 @@
arg_end:
# now we can do the actual evaluation
- .local pmc __script, toBoolean
- __script = get_root_global ['_tcl'], '__script'
+ .local pmc compileTcl, toBoolean
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
toBoolean = get_root_global ['_tcl'], 'toBoolean'
.local pmc cond
@@ -104,7 +104,7 @@
$P1 = cond()
$I1 = toBoolean($P1)
unless $I1 goto next
- $P0 = __script(code, 'ns'=>ns)
+ $P0 = compileTcl(code, 'ns'=>ns)
.return $P0()
next:
@@ -129,7 +129,7 @@
else:
inc $I0
code = argv[$I0]
- $P0 = __script(code, 'ns'=>ns)
+ $P0 = compileTcl(code, 'ns'=>ns)
.return $P0()
extra_words_after_else:
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/info.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/info.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/info.pir Thu Jul 24
13:41:24 2008
@@ -77,12 +77,12 @@
.local string procname
procname = shift argv
- .local pmc __namespace
- __namespace = get_root_global ['_tcl'], '__namespace'
+ .local pmc splitNamespace
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
.local pmc ns
.local string name
- ns = __namespace(procname)
+ ns = splitNamespace(procname)
name = pop ns
name = '&' . name
@@ -116,12 +116,12 @@
.local string procname
procname = argv[0]
- .local pmc __namespace
- __namespace = get_root_global ['_tcl'], '__namespace'
+ .local pmc splitNamespace
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
.local pmc ns
.local string name
- ns = __namespace(procname)
+ ns = splitNamespace(procname)
name = pop ns
name = '&' . name
@@ -151,7 +151,7 @@
.local pmc body
body = argv[0]
push_eh nope
- $P1 = __script(body)
+ $P1 = compileTcl(body)
pop_eh
.return(1)
@@ -186,12 +186,12 @@
.local pmc setVar
setVar = get_root_global ['_tcl'], 'setVar'
- .local pmc __namespace
- __namespace = get_root_global ['_tcl'], '__namespace'
+ .local pmc splitNamespace
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
.local pmc ns
.local string name
- ns = __namespace(procname)
+ ns = splitNamespace(procname)
name = pop ns
name = '&' . name
@@ -474,15 +474,15 @@
.return($I0)
find_level:
- .local pmc toInteger, __call_level
+ .local pmc toInteger, getCallLevel
toInteger = get_root_global ['_tcl'], 'toInteger'
- __call_level = get_root_global ['_tcl'], '__call_level'
+ getCallLevel = get_root_global ['_tcl'], 'getCallLevel'
.local pmc level
level = shift argv
level = toInteger(level)
if level >= 0 goto find_info_level
- level = __call_level(level)
+ level = getCallLevel(level)
.return(level)
find_info_level:
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/lindex.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/lindex.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/lindex.pir Thu Jul
24 13:41:24 2008
@@ -11,9 +11,9 @@
argc = argv
if argc < 1 goto bad_args
- .local pmc toList, __index
+ .local pmc toList, getIndex
toList = get_root_global ['_tcl'], 'toList'
- __index = get_root_global ['_tcl'], '__index'
+ getIndex = get_root_global ['_tcl'], 'getIndex'
.local pmc list
list = argv[0]
@@ -49,7 +49,7 @@
list = toList(list)
$P0 = indices[$I1]
- index = __index($P0, list)
+ index = getIndex($P0, list)
$I2 = elements list
if index >= $I2 goto empty
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/linsert.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/linsert.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/linsert.pir Thu Jul
24 13:41:24 2008
@@ -22,11 +22,11 @@
.local string position
position = shift argv
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
.local int the_index
- the_index = __index(position, the_list)
+ the_index = getIndex(position, the_list)
$S0 = substr position, 0, 3
if $S0 != 'end' goto next
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/lreplace.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/lreplace.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/lreplace.pir Thu Jul
24 13:41:24 2008
@@ -11,9 +11,9 @@
argc = elements argv
if argc < 3 goto bad_args
- .local pmc list, toList, retval, iterator, __index
+ .local pmc list, toList, retval, iterator, getIndex
toList = get_root_global ['_tcl'], 'toList'
- __index = get_root_global ['_tcl'], '__index'
+ getIndex = get_root_global ['_tcl'], 'getIndex'
$P0 = shift argv
list = toList($P0)
list = clone list
@@ -23,9 +23,9 @@
.local int first, last, count
$S0 = shift argv
- first = __index($S0,list)
+ first = getIndex($S0,list)
$S0 = shift argv
- last = __index($S0,list)
+ last = getIndex($S0,list)
if size == 0 goto empty
if last < size goto first_1
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/lset.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/lset.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/lset.pir Thu Jul 24
13:41:24 2008
@@ -31,8 +31,8 @@
if argc == 1 goto replace
lset:
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
unless argc == 2 goto iterate
$P0 = argv[1]
@@ -56,7 +56,7 @@
if $I0 == $I1 goto outer_loop
$P0 = indices[$I0]
- $I2 = __index($P0, list)
+ $I2 = getIndex($P0, list)
if $I2 < 0 goto out_of_range
$I3 = elements list
if $I2 >= $I3 goto out_of_range
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/namespace.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/namespace.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/namespace.pir Thu Jul
24 13:41:24 2008
@@ -76,9 +76,9 @@
argc = argv
if argc goto bad_args
- .local pmc ns, __namespace
- __namespace = get_root_global ['_tcl'], '__namespace'
- ns = __namespace('')
+ .local pmc ns, splitNamespace
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
+ ns = splitNamespace('')
$S0 = join '::', ns
$S0 = '::' . $S0
.return($S0)
@@ -95,15 +95,15 @@
# no arg delete does nothing
if argc == 0 goto return
- .local pmc __namespace, ns_root
- __namespace = get_root_global ['_tcl'], '__namespace'
+ .local pmc splitNamespace, ns_root
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
ns_root = get_root_namespace ['tcl']
$I0 = 0
delete_loop:
if $I0 == argc goto return
$S0 = argv[$I0]
- $P0 = __namespace($S0)
+ $P0 = splitNamespace($S0)
$I1 = 0
$I2 = elements $P0
dec $I2
@@ -245,11 +245,11 @@
unshift $P0, 'namespace'
unshift info_level, $P0
- .local pmc ns, __namespace
- __namespace = get_root_global ['_tcl'], '__namespace'
+ .local pmc ns, splitNamespace
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
ns = shift argv
- ns = __namespace(ns, 1)
+ ns = splitNamespace(ns, 1)
.local string namespace
namespace = ''
@@ -261,11 +261,11 @@
namespace .= "']"
global_ns:
- .local pmc __script, code
- __script = get_root_global ['_tcl'], '__script'
+ .local pmc compileTcl, code
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
code = new 'CodeString'
$S0 = join ' ', argv
- ($S0, $S1) = __script($S0, 'pir_only'=>1)
+ ($S0, $S1) = compileTcl($S0, 'pir_only'=>1)
$I0 = code.unique()
code.emit(<<'END_PIR', namespace, $S0, $I0, $S1)
.HLL 'tcl', 'tcl_group'
@@ -327,15 +327,15 @@
.local pmc list
list = new 'TclList'
- .local pmc __namespace, ns, ns_name
+ .local pmc splitNamespace, ns, ns_name
.local string name
- __namespace = get_root_global ['_tcl'], '__namespace'
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
name = ''
if argc == 0 goto getname
name = argv[0]
getname:
- ns_name = __namespace(name, 1)
+ ns_name = splitNamespace(name, 1)
unshift ns_name, 'tcl'
ns = get_root_namespace ns_name
@@ -455,9 +455,9 @@
name = argv[0]
get_parent:
- .local pmc ns, __namespace
- __namespace = get_root_global ['_tcl'], '__namespace'
- ns = __namespace(name)
+ .local pmc ns, splitNamespace
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
+ ns = splitNamespace(name)
if $S0 != '' goto no_pop
# for when someone calls [namespace current] from ::
push_eh current_in_root
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/parray.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/parray.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/parray.pir Thu Jul
24 13:41:24 2008
@@ -26,7 +26,7 @@
$P99 = open $S0, '<'
$S0 = $P99.'slurp'('')
- script = get_root_global ['_tcl'], '__script'
+ script = get_root_global ['_tcl'], 'compileTcl'
# compile to PIR and put the sub in place...
$P1 = script($S0)
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/proc.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/proc.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/proc.pir Thu Jul 24
13:41:24 2008
@@ -21,11 +21,11 @@
args = argv[1]
body = argv[2]
- .local pmc pir_compiler, __script, toList, __namespace
+ .local pmc pir_compiler, compileTcl, toList, splitNamespace
pir_compiler = compreg 'PIR'
- __script = get_root_global ['_tcl'], '__script'
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
toList = get_root_global ['_tcl'], 'toList'
- __namespace = get_root_global ['_tcl'], '__namespace'
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
.local pmc code, args_code, defaults
.local string namespace
@@ -41,7 +41,7 @@
if full_name == '' goto create
- ns = __namespace(full_name, 1)
+ ns = splitNamespace(full_name, 1)
$I0 = elements ns
if $I0 == 0 goto create
name = pop ns
@@ -209,7 +209,7 @@
# Save the parsed body.
.local string parsed_body, body_reg
- (parsed_body, body_reg) = __script(body, 'pir_only'=>1)
+ (parsed_body, body_reg) = compileTcl(body, 'pir_only'=>1)
code .= parsed_body
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/puts.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/puts.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/puts.pir Thu Jul 24
13:41:24 2008
@@ -15,8 +15,8 @@
.local int utf8
utf8 = find_encoding 'utf8'
- .local pmc __channel, io
- __channel = get_root_global ['_tcl'], '__channel'
+ .local pmc getChannel, io
+ getChannel = get_root_global ['_tcl'], 'getChannel'
if argc == 1 goto one_arg
if argc == 2 goto two_arg
@@ -26,7 +26,7 @@
if $S1 != '-nonewline' goto bad_option
$S2 = argv[1]
- io = __channel($S2)
+ io = getChannel($S2)
$S3 = argv[2]
$S3 = trans_encoding $S3, utf8
@@ -51,7 +51,7 @@
goto done
two_arg_channel:
- io = __channel($S2)
+ io = getChannel($S2)
io.'say'($S3)
goto done
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/source.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/source.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/source.pir Thu Jul
24 13:41:24 2008
@@ -24,9 +24,9 @@
interp = getinterp
ns = interp['namespace';1]
- .local pmc __script, code
- __script = get_root_global ['_tcl'], '__script'
- code = __script ( file_contents, 'ns' => ns, 'bsnl' => 1)
+ .local pmc compileTcl, code
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
+ code = compileTcl ( file_contents, 'ns' => ns, 'bsnl' => 1)
.return code()
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/string.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/string.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/string.pir Thu Jul
24 13:41:24 2008
@@ -79,11 +79,11 @@
$I0 = 0
if argc == 2 goto first_do
$S3 = argv[2]
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
- $I0 = __index($S3,$S2)
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
+ $I0 = getIndex($S3,$S2)
if $I0 >0 goto first_do
- $I0 = 0 # XXX should this be done in __index?
+ $I0 = 0 # XXX should this be done in getIndex?
first_do:
.local int index_1
@@ -111,9 +111,9 @@
if argc == 2 goto last_do
$S3 = argv[2]
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
- $I1 = __index($S3,$S2)
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
+ $I1 = getIndex($S3,$S2)
if $I1 > $I0 goto last_do
$I0 = $I1
@@ -152,9 +152,9 @@
if argc != 2 goto bad_index
$S1 = argv[0]
$S2 = argv[1]
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
- $I0 = __index($S2,$S1)
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
+ $I0 = getIndex($S2,$S1)
index_1 = length $S1
inc index_1
if $I0 > index_1 goto index_null
@@ -191,17 +191,17 @@
$I3 = $I1
if argc == 1 goto tolower_do
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
$S2 = argv[1]
- $I2 = __index($S2, $S1)
+ $I2 = getIndex($S2, $S1)
# if just the first is specified, the last is the same (tclsh says so)
$I3 = $I2
if argc == 2 goto tolower_do
$S3 = argv[2]
- $I3 = __index($S3, $S1)
+ $I3 = getIndex($S3, $S1)
tolower_do:
if $I2 > $I1 goto tolower_return
@@ -244,17 +244,17 @@
$I3 = $I1
if argc == 1 goto toupper_do
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
$S2 = argv[1]
- $I2 = __index($S2, $S1)
+ $I2 = getIndex($S2, $S1)
# if just the first is specified, the last is the same (tclsh says so)
$I3 = $I2
if argc == 2 goto toupper_do
$S3 = argv[2]
- $I3 = __index($S3, $S1)
+ $I3 = getIndex($S3, $S1)
toupper_do:
if $I2 > $I1 goto toupper_return
@@ -296,17 +296,17 @@
$I3 = $I1
if argc == 1 goto totitle_do
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
$S2 = argv[1]
- $I2 = __index($S2, $S1)
+ $I2 = getIndex($S2, $S1)
# if just the first is specified, the last is the same (tclsh says so)
$I3 = $I2
if argc == 2 goto totitle_do
$S3 = argv[2]
- $I3 = __index($S3, $S1)
+ $I3 = getIndex($S3, $S1)
totitle_do:
if $I2 > $I1 goto totitle_return
@@ -376,12 +376,12 @@
last_index = length teh_string
dec last_index
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
.local int first_i, last_i
- first_i = __index(first_s, teh_string)
- last_i = __index(last_s, teh_string)
+ first_i = getIndex(first_s, teh_string)
+ last_i = getIndex(last_s, teh_string)
if first_i > last_i goto done
@@ -827,8 +827,8 @@
.local int len
.local pmc retval
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
argc = argv
if argc > 4 goto bad_args
@@ -842,12 +842,12 @@
$S4 = ''
low_s = argv[1]
- low = __index(low_s, the_string)
+ low = getIndex(low_s, the_string)
if low >= string_len goto replace_done
high_s = argv[2]
- high = __index(high_s, the_string)
+ high = getIndex(high_s, the_string)
if high < low goto replace_done
@@ -1091,9 +1091,9 @@
str = argv[0]
idx = argv[1]
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
- idx = __index(idx, str)
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
+ idx = getIndex(idx, str)
$I0 = length str
$I0 -= idx
@@ -1121,13 +1121,13 @@
str = argv[0]
idx = argv[1]
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
- idx = __index(idx, str)
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
+ idx = getIndex(idx, str)
.local int pos
pos = idx
- # XXX should these checks be in __index itself?
+ # XXX should these checks be in getIndex itself?
if pos >0 goto check_upper
pos = 0
goto pre_loop
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/subst.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/subst.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/subst.pir Thu Jul 24
13:41:24 2008
@@ -35,10 +35,10 @@
astgrammar = new 'TclExpr::PAST::Grammar'
pirgrammar = new 'TclExpr::PIR::Grammar'
- .local pmc __namespace, ns
+ .local pmc splitNamespace, ns
.local string namespace
- __namespace = get_root_global ['_tcl'], '__namespace'
- ns = __namespace('', 2)
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
+ ns = splitNamespace('', 2)
namespace = ''
$I0 = elements ns
if $I0 == 0 goto loop
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/switch.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/switch.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/switch.pir Thu Jul
24 13:41:24 2008
@@ -142,9 +142,9 @@
code = shift body
body_match:
if code == '-' goto fallthrough
- .local pmc __script
- __script = get_root_global ['_tcl'], '__script'
- $P1 = __script(code)
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
+ $P1 = compileTcl(code)
.return $P1()
extra_pattern:
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/trace.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/trace.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/trace.pir Thu Jul 24
13:41:24 2008
@@ -1,18 +1,11 @@
-# RT#40703: Stub
-# help tcltest compile
-
-.HLL '_Tcl', 'tcl_group'
+.HLL 'Tcl', 'tcl_group'
.namespace []
-.sub 'trace'
- .param string retval
- .param pmc raw_args
- .param pmc argv
-
+.sub '&trace'
+ .param pmc argv :slurpy
.return('')
.end
-
# Local Variables:
# mode: pir
# fill-column: 100
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/uplevel.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/uplevel.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/uplevel.pir Thu Jul
24 13:41:24 2008
@@ -14,9 +14,9 @@
argc = elements argv
if argc == 0 goto bad_args
- .local pmc __script, __call_level
- __script = get_root_global ['_tcl'], '__script'
- __call_level = get_root_global ['_tcl'], '__call_level'
+ .local pmc compileTcl, getCallLevel
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
+ getCallLevel = get_root_global ['_tcl'], 'getCallLevel'
# save the old call level
.local pmc call_chain
@@ -28,7 +28,7 @@
new_call_level = argv[0]
.local int defaulted
- (new_call_level,defaulted) = __call_level(new_call_level)
+ (new_call_level,defaulted) = getCallLevel(new_call_level)
if defaulted == 1 goto skip
# if we only have a level, then we don't have a command to run!
@@ -56,7 +56,7 @@
# if we get an exception, we have to reset the environment
.local pmc retval
push_eh restore_and_rethrow
- $P0 = __script($S0)
+ $P0 = compileTcl($S0)
retval = $P0()
pop_eh
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/upvar.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/upvar.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/upvar.pir Thu Jul 24
13:41:24 2008
@@ -11,15 +11,15 @@
argc = elements argv
if argc < 2 goto bad_args
- .local pmc __call_level, call_chain
+ .local pmc getCallLevel, call_chain
.local int call_level
- __call_level = get_root_global ['_tcl'], '__call_level'
+ getCallLevel = get_root_global ['_tcl'], 'getCallLevel'
call_chain = get_root_global ['_tcl'], 'call_chain'
call_level = elements call_chain
.local int new_call_level, defaulted
$P0 = argv[0]
- (new_call_level,defaulted) = __call_level($P0)
+ (new_call_level,defaulted) = getCallLevel($P0)
if defaulted == 1 goto skip
$P1 = shift argv
dec argc
@@ -87,7 +87,7 @@
.local pmc ns
.local string name
- ns = __namespace(new_var, 1)
+ ns = splitNamespace(new_var, 1)
name = pop ns
name = '$' . name
Modified: branches/gsoc_pdd09/languages/tcl/runtime/builtin/variable.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/builtin/variable.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/builtin/variable.pir Thu Jul
24 13:41:24 2008
@@ -11,10 +11,10 @@
argc = elements argv
if argc == 0 goto bad_args
- .local pmc findVar, storeVar, __namespace
+ .local pmc findVar, storeVar, splitNamespace
findVar = get_root_global ['_tcl'], 'findVar'
storeVar = get_root_global ['_tcl'], 'storeVar'
- __namespace = get_root_global ['_tcl'], '__namespace'
+ splitNamespace = get_root_global ['_tcl'], 'splitNamespace'
.local pmc iter, name, value, ns
iter = new 'Iterator', argv
@@ -37,7 +37,7 @@
unless iter goto no_value
value = shift iter
- ns = __namespace(name)
+ ns = splitNamespace(name)
$S0 = ns[-1]
# store as a lexical *and* a global
storeVar($S0, value)
@@ -45,7 +45,7 @@
goto loop
no_value:
- ns = __namespace(name)
+ ns = splitNamespace(name)
$S0 = ns[-1]
# if the variable exists, just insert it as a lexical
# otherwise, create a new Undef and insert it as both lexical and global
Modified: branches/gsoc_pdd09/languages/tcl/runtime/conversions.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/conversions.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/conversions.pir Thu Jul 24
13:41:24 2008
@@ -57,7 +57,7 @@
.sub toDict :multi(_)
.param pmc value
- $P0 = __stringToDict(value)
+ $P0 = stringToDict(value)
copy value, $P0
.return(value)
@@ -185,14 +185,14 @@
rethrow $P99 # preserves the invalid octal message.
.end
-=head2 _Tcl::__index
+=head2 _Tcl::getIndex
Given a tcl string index and an List pmc, return the corresponding numeric
index.
=cut
-.sub __index
+.sub getIndex
.param string idx
.param pmc list
@@ -249,13 +249,13 @@
tcl_error $S0
.end
-=head2 _Tcl::__channel
+=head2 _Tcl::getChannel
Given a string, return the appropriate channel.
=cut
-.sub __channel
+.sub getChannel
.param string channelID
.local pmc channels
@@ -283,13 +283,13 @@
.end
-=head2 _Tcl::__expr
+=head2 _Tcl::compileExpr
Given an expression, return a subroutine, or optionally, the raw PIR
=cut
-.sub __expr
+.sub compileExpr
.param string expression
.param int pir_only :named('pir_only') :optional
.param pmc ns :named('ns') :optional
@@ -372,13 +372,13 @@
tcl_error "empty expression\nin expression \"\""
.end
-=head2 _Tcl::__script
+=head2 _Tcl::compileTcl
Given a chunk of tcl code, return a subroutine.
=cut
-.sub __script
+.sub compileTcl
.param string code
.param int pir_only :named('pir_only') :optional
.param pmc ns :named('ns') :optional
@@ -475,13 +475,13 @@
tcl_error $S0
.end
-=head2 _Tcl::__namespace
+=head2 _Tcl::splitNamespace
Given a string namespace, return an array of names.
=cut
-.sub __namespace
+.sub splitNamespace
.param string name
.param int depth :optional
.param int has_depth :opt_flag
@@ -583,7 +583,7 @@
.return(0)
.end
-=head2 _Tcl::__call_level
+=head2 _Tcl::getCallLevel
Given a pmc containing the tcl-style call level, return an int-like pmc
indicating the parrot-style level, and an integer with a boolean 0/1 -
@@ -591,7 +591,7 @@
=cut
-.sub __call_level
+.sub getCallLevel
.param pmc tcl_level
.local pmc parrot_level, defaulted, orig_level
defaulted = new 'Integer'
Modified: branches/gsoc_pdd09/languages/tcl/runtime/options.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/options.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/options.pir Thu Jul 24
13:41:24 2008
@@ -50,31 +50,45 @@
check_partial:
$I1 = elements partials
- if $I1 == 0 goto no_match
- if $I1 >1 goto ambiguous
+ if type_name == 'subcommand' goto check_subcommand
+ if $I1 == 0 goto no_match_option
+ if $I1 >1 goto ambiguous_option
+ option = partials[0]
+
+check_subcommand:
+ if $I1 != 1 goto unknown_subcommand
option = partials[0]
got_match:
.return (option)
-no_match:
+no_match_option:
error = 'bad '
error .= type_name
error .= ' "'
error .= choice
error .= '": must be '
- $S1 = __options_to_string(options)
+ $S1 = optionsToString(options)
error .= $S1
tcl_error error
-ambiguous:
+ambiguous_option:
error = 'ambiguous '
error .= type_name
error .= ' "'
error .= choice
error .= '": must be '
- # $S1 = __options_to_string(partials) # Now, I like this better...
- $S1 = __options_to_string(options)
+ $S1 = optionsToString(options)
+ error .= $S1
+ tcl_error error
+
+unknown_subcommand:
+ error = 'unknown or ambiguous '
+ error .= type_name
+ error .= ' "'
+ error .= choice
+ error .= '": must be '
+ $S1 = optionsToString(options)
error .= $S1
tcl_error error
.end
@@ -187,7 +201,7 @@
$S1 .= ' "-'
$S1 .= arg
$S1 .= '": must be '
- $S2 = __switches_to_string(switches)
+ $S2 = switchesToString(switches)
$S1 .= $S2
tcl_error $S1
loop_next:
@@ -204,7 +218,7 @@
.return (results)
.end
-.sub __options_to_string
+.sub optionsToString
.param pmc options
# uncomment this if folks start passing in un-ordered lists...
@@ -240,8 +254,8 @@
.return (error)
.end
-# Similar to __option_to_string. Refactor??
-.sub __switches_to_string
+# Similar to optionsToString. Refactor??
+.sub switchesToString
.param pmc switches
# uncomment this if folks start passing in un-ordered lists...
Modified: branches/gsoc_pdd09/languages/tcl/runtime/string_to_list.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/string_to_list.pir
(original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/string_to_list.pir Thu Jul
24 13:41:24 2008
@@ -53,7 +53,7 @@
tcl_error 'missing value to go with key'
.end
-.sub __stringToDict
+.sub stringToDict
.param string str
.local pmc list
Modified: branches/gsoc_pdd09/languages/tcl/runtime/tcllib.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/tcllib.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/tcllib.pir Thu Jul 24
13:41:24 2008
@@ -27,7 +27,6 @@
# library files (HLL: _Tcl)
.include 'languages/tcl/runtime/conversions.pir'
-.include 'languages/tcl/runtime/list_to_string.pir'
.include 'languages/tcl/runtime/string_to_list.pir'
.include 'languages/tcl/runtime/variables.pir'
.include 'languages/tcl/runtime/options.pir'
@@ -242,7 +241,7 @@
set_hll_global 'colons', colons
# register the TCL compiler.
- $P1 = get_root_global ['_tcl'], '__script'
+ $P1 = get_root_global ['_tcl'], 'compileTcl'
compreg 'TCL', $P1
# Setup a global to keep a unique id for compiled subs.
Modified: branches/gsoc_pdd09/languages/tcl/runtime/variables.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/runtime/variables.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/runtime/variables.pir Thu Jul 24
13:41:24 2008
@@ -307,7 +307,7 @@
absolute = 1
global_var:
depth += 2
- ns = __namespace(name, depth)
+ ns = splitNamespace(name, depth)
$S0 = pop ns
$S0 = '$' . $S0
@@ -393,7 +393,7 @@
global_var:
depth += 2
- ns = __namespace(name, depth)
+ ns = splitNamespace(name, depth)
name = pop ns
name = '$' . name
Modified: branches/gsoc_pdd09/languages/tcl/src/builtin/expr.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/src/builtin/expr.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/src/builtin/expr.pir Thu Jul 24
13:41:24 2008
@@ -27,12 +27,12 @@
end:
arg = join ' ', raw_args
- .local pmc __expr
- __expr = get_root_global ['_tcl'], '__expr'
+ .local pmc compileExpr
+ compileExpr = get_root_global ['_tcl'], 'compileExpr'
# make sure errors happen at runtime
push_eh exception
- ($P0, $S0) = __expr(arg, 'pir_only'=>1)
+ ($P0, $S0) = compileExpr(arg, 'pir_only'=>1)
pop_eh
pir = new 'CodeString'
pir .= $P0
Modified: branches/gsoc_pdd09/languages/tcl/src/builtin/lrange.tmt
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/src/builtin/lrange.tmt (original)
+++ branches/gsoc_pdd09/languages/tcl/src/builtin/lrange.tmt Thu Jul 24
13:41:24 2008
@@ -1,11 +1,11 @@
[lrange list:list first last]
- .local pmc __index
- __index = get_root_global ['_tcl'], '__index'
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
.local int from, to
- from = __index($first, $list)
- to = __index($last, $list)
+ from = getIndex($first, $list)
+ to = getIndex($last, $list)
if from < 0 goto set_first
have_first:
Modified: branches/gsoc_pdd09/languages/tcl/src/grammar/expr/past.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/src/grammar/expr/past.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/src/grammar/expr/past.pir Thu Jul 24
13:41:24 2008
@@ -29,13 +29,13 @@
.namespace [ 'PAST' ]
-=item C<__onload()>
+=item C<onload()>
Creates the C<PAST::*> classes.
=cut
-.sub '__onload' :load
+.sub 'onload' :load :anon
.local pmc base
$P0 = get_class 'Hash'
base = subclass $P0, 'PAST::Node'
@@ -66,7 +66,7 @@
=over 4
-=item C<__init()>
+=item C<init()>
Initializes a new C<PAST::Node> object.
Modified: branches/gsoc_pdd09/languages/tcl/src/pmc/tcldict.pmc
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/src/pmc/tcldict.pmc (original)
+++ branches/gsoc_pdd09/languages/tcl/src/pmc/tcldict.pmc Thu Jul 24
13:41:24 2008
@@ -34,27 +34,27 @@
=item C<STRING *get_string()>
-Returns the dict as a string
+Returns the dict as a string. Take advantage of the heavy lifting already
+present in TclList.
=cut
*/
VTABLE STRING* get_string() {
- PMC *dictToString, *namespace;
- STRING *_tcl_namespace, *sub;
+ PMC *list, *iterator, *value;
+ STRING *key;
- _tcl_namespace = string_from_cstring(INTERP, "_tcl", 4);
- sub = string_from_cstring(INTERP, "dictToString", 14);
-
- namespace = INTERP->root_namespace;
- namespace = VTABLE_get_pmc_keyed_str(INTERP, namespace,
_tcl_namespace);
- dictToString = VTABLE_get_pmc_keyed_str(INTERP, namespace, sub);
-
- CONTEXT(interp)->constants =
- PMC_sub(dictToString)->seg->const_table->constants;
- return (STRING *)Parrot_runops_fromc_args(INTERP, dictToString, "SP",
SELF);
+ list = pmc_new(INTERP, pmc_type(INTERP, CONST_STRING(INTERP,
"TclList")));
+ iterator = SELF.get_iter();
+ while (VTABLE_get_bool(INTERP, iterator)) {
+ key = VTABLE_shift_string(INTERP, iterator);
+ VTABLE_push_string(INTERP, list, key);
+ value = VTABLE_get_pmc_keyed_str(INTERP, SELF, key);
+ VTABLE_push_string(INTERP, list, VTABLE_get_string(INTERP,
value));
+ }
+ return VTABLE_get_string(INTERP, list);
}
}
Modified: branches/gsoc_pdd09/languages/tcl/src/tclsh.pir
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/src/tclsh.pir (original)
+++ branches/gsoc_pdd09/languages/tcl/src/tclsh.pir Thu Jul 24 13:41:24 2008
@@ -42,8 +42,8 @@
tcl_interactive = new 'Integer'
store_global '$tcl_interactive', tcl_interactive
- .local pmc __script
- __script = get_root_global ['_tcl'], '__script'
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
.local pmc get_options
get_options = new 'Getopt::Obj'
@@ -82,19 +82,19 @@
.local int level
level = 1
input_loop:
- $P0 = __prompt(level, readlineInd)
+ $P0 = prompt(level, readlineInd)
if null $P0 goto done
$S0 = $P0
$S0 .= "\n" # add back in the newline the prompt chomped
input_line .= $S0
- # could probably avoid calling __script 2x here...
+ # could probably avoid calling compileTcl 2x here...
unless dump_only goto execute_line
.local string _pir
- _pir = __script(input_line, 'pir_only'=>1, 'bsnl'=>1)
+ _pir = compileTcl(input_line, 'pir_only'=>1, 'bsnl'=>1)
say _pir
execute_line:
push_eh loop_error
- $P2 = __script(input_line)
+ $P2 = compileTcl(input_line)
retval = $P2()
pop_eh
# print out the result of the evaluation.
@@ -137,14 +137,14 @@
.set_tcl_argv()
unless dump_only goto run_file
push_eh file_error
- ($S0,$I0) = __script(contents, 'pir_only'=>1, 'bsnl'=>1, 'wrapper'=>1)
+ ($S0,$I0) = compileTcl(contents, 'pir_only'=>1, 'bsnl'=>1, 'wrapper'=>1)
pop_eh
print $S0
goto done
run_file:
push_eh file_error
- $P2 = __script(contents, 'bsnl' => 1)
+ $P2 = compileTcl(contents, 'bsnl' => 1)
$P2()
pop_eh
goto done
@@ -161,14 +161,14 @@
.local string tcl_code
tcl_code = opt['e']
if dump_only goto oneliner_dump
- $P3 = __script(tcl_code)
+ $P3 = compileTcl(tcl_code)
push_eh file_error
$P3()
pop_eh
goto done
oneliner_dump:
- ($S0,$I0) = __script(tcl_code, 'pir_only'=>1, 'bsnl'=>1, 'wrapper'=>1)
+ ($S0,$I0) = compileTcl(tcl_code, 'pir_only'=>1, 'bsnl'=>1, 'wrapper'=>1)
print $S0
done:
@@ -198,7 +198,7 @@
.rethrow()
.end
-.sub __prompt
+.sub prompt
.param int level
.param int readlineInd
@@ -219,15 +219,15 @@
$S0 = level
varname .= $S0
- .local pmc __script
- __script = get_root_global ['_tcl'], '__script'
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
# XXX Should trap the printed output here, and then display
# it using the readilne prompt, like everything else.
# XXX Should be testing this
push_eh no_prompt
$P0 = find_global varname
- $P2 = __script($P0)
+ $P2 = compileTcl($P0)
$P2()
pop_eh
Modified: branches/gsoc_pdd09/languages/tcl/t/cmd_binary.t
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/t/cmd_binary.t (original)
+++ branches/gsoc_pdd09/languages/tcl/t/cmd_binary.t Thu Jul 24 13:41:24 2008
@@ -10,7 +10,7 @@
__DATA__
source lib/test_more.tcl
-plan 2 ; # was 14, skipping the last 12 tests.
+plan 14
eval_is {binary} {wrong # args: should be "binary option ?arg arg ...?"} \
{binary: no args}
@@ -18,23 +18,20 @@
eval_is {binary foo} {bad option "foo": must be format or scan} \
{binary: bad subcommand}
-
# we test the default precision (which is special) elsewhere
# so just set a precision to work around a bug
set tcl_precision 17
-exit; # $d isn't getting set here, which kills the rest of the tests...
-
binary scan [binary format dccc -1.3 6 7 8] dcc* d c c*
-is $d -1.3 {binary: reversible d}
-is $c 6 {binary: reversible c}
-is ${c*} {7 8} {binary: scan [format cc] c*}
+is $d -1.3 {binary: reversible d} {TODO borked}
+is $c 6 {binary: reversible c} {TODO borked}
+is ${c*} {7 8} {binary: scan [format cc] c*} {TODO borked}
binary scan [binary format f -1.3] f f
-is $f -1.2999999523162842 {binary: reversible f}
+is $f -1.2999999523162842 {binary: reversible f} {TODO borked}
binary scan [binary format n 9] n n
-is $n 9 {binary: reversible n}
+is $n 9 {binary: reversible n} {TODO borked}
binary scan {foo bar} aa* first rest
is [list $first $rest] {f {oo bar}} {binary: scan aa*}
@@ -51,4 +48,4 @@
is $string2 b {binary: format a4a, scan a3ca}
# segfault misc.
-is [proc a {} { binary scan \x80 d joe } ; a] {} {BOOM?}
+is [proc a {} { binary scan \x80 d joe } ; a] {0} {BOOM?} {TODO borked}
Modified: branches/gsoc_pdd09/languages/tcl/tools/gen_inline.pl
==============================================================================
--- branches/gsoc_pdd09/languages/tcl/tools/gen_inline.pl (original)
+++ branches/gsoc_pdd09/languages/tcl/tools/gen_inline.pl Thu Jul 24
13:41:24 2008
@@ -37,11 +37,11 @@
# type subroutine
bool => 'toBoolean',
- channel => '__channel',
- expr => '__expr',
+ channel => 'getChannel',
+ expr => 'compileExpr',
int => 'toInteger',
list => 'toList',
- script => '__script',
+ script => 'compileTcl',
var => 'readVar',
);
Modified: branches/gsoc_pdd09/src/libnci_test.def
==============================================================================
--- branches/gsoc_pdd09/src/libnci_test.def (original)
+++ branches/gsoc_pdd09/src/libnci_test.def Thu Jul 24 13:41:24 2008
@@ -32,6 +32,8 @@
nci_vP
nci_vpii
nci_vv
+ nci_vVi
+ nci_vp
nci_cb_C1
nci_cb_C2
nci_cb_C3
Modified: branches/gsoc_pdd09/src/nci_test.c
==============================================================================
--- branches/gsoc_pdd09/src/nci_test.c (original)
+++ branches/gsoc_pdd09/src/nci_test.c Thu Jul 24 13:41:24 2008
@@ -58,6 +58,10 @@
int w, h;
} Rect_Like;
+typedef struct Opaque {
+ int x;
+} Opaque;
+
/* Function declarations.
*** If you add a new test function here,
@@ -98,6 +102,8 @@
PARROT_API void nci_vP(void *);
PARROT_API void nci_vpii(Outer *, int, int);
PARROT_API void nci_vv(void);
+PARROT_API void nci_vVi(Opaque**, int);
+PARROT_API void nci_vp(Opaque*);
/* Declarations for callback tests */
@@ -1044,6 +1050,47 @@
nci_dlvar_int *= 3;
}
+/*
+
+=item C<PARROT_API void
+nci_vVi(Opaque**, int)>
+
+Test an NCI opaque struct out value.
+
+=cut
+
+*/
+
+PARROT_API void
+nci_vVi(Opaque **outOpaque, int x)
+{
+ static Opaque opaque;
+ opaque.x = x;
+ *outOpaque = &opaque;
+}
+
+/*
+
+=item C<PARROT_API int
+nci_vp(Opaque*)>
+
+Test that a previously generated opaque struct gets passed back
+to an NCI function correctly.
+
+=cut
+
+*/
+
+PARROT_API void
+nci_vp(Opaque *inOpaque)
+{
+ if (inOpaque)
+ printf("got %d\n", inOpaque->x);
+ else
+ printf("got null");
+}
+
+
#ifdef TEST
char l2 = 4;
Modified: branches/gsoc_pdd09/t/pmc/nci.t
==============================================================================
--- branches/gsoc_pdd09/t/pmc/nci.t (original)
+++ branches/gsoc_pdd09/t/pmc/nci.t Thu Jul 24 13:41:24 2008
@@ -6,7 +6,7 @@
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
-use Parrot::Test tests => 65;
+use Parrot::Test tests => 66;
use Parrot::Config qw(%PConfig);
=head1 NAME
@@ -2645,6 +2645,29 @@
3
OUTPUT
+pir_output_is( << 'CODE', << 'OUTPUT', "nci_vVi - void** out parameter" );
+.sub test :main
+ .local string library_name
+ library_name = 'libnci_test'
+ .local pmc libnci_test
+ libnci_test = loadlib library_name
+
+ .local pmc nci_vVi
+ nci_vVi = dlfunc libnci_test, "nci_vVi", "vVi"
+
+ .local pmc nci_vp
+ nci_vp = dlfunc libnci_test, "nci_vp", "vp"
+
+ .local pmc opaque
+ opaque = new 'Pointer'
+ $I0 = 10
+ nci_vVi(opaque, $I0)
+ nci_vp(opaque)
+.end
+CODE
+got 10
+OUTPUT
+
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
Modified: branches/gsoc_pdd09/tools/build/nativecall.pl
==============================================================================
--- branches/gsoc_pdd09/tools/build/nativecall.pl (original)
+++ branches/gsoc_pdd09/tools/build/nativecall.pl Thu Jul 24 13:41:24 2008
@@ -82,6 +82,7 @@
B => "void **",
L => "long *",
T => "char **",
+ V => "void **",
'@' => "PMC *", # slurpy array
);
@@ -186,6 +187,7 @@
N => "N",
B => "S",
v => "v",
+ V => "P",
J => "",
'@' => '@',
);
@@ -439,6 +441,11 @@
push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);";
return "PMC_data(t_$temp_num)";
};
+ /V/ && do {
+ push @{$temps_ref}, "PMC *t_$temp_num;";
+ push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);";
+ return "(void**)&PMC_data(t_$temp_num)";
+ };
/i/ && do {
push @{$temps_ref}, "int t_$temp_num;";
push @{$extra_preamble_ref}, "t_$temp_num = (int)GET_NCI_I($reg_num);";
|
|