|
|
Author: coke
Date: Sun Jul 27 11:57:09 2008
New Revision: 29804
Added:
trunk/languages/tcl/runtime/builtin/break.pir
trunk/languages/tcl/runtime/builtin/cd.pir
trunk/languages/tcl/runtime/builtin/continue.pir
trunk/languages/tcl/runtime/builtin/eof.pir
trunk/languages/tcl/runtime/builtin/exit.pir
trunk/languages/tcl/runtime/builtin/flush.pir
trunk/languages/tcl/runtime/builtin/for.pir
trunk/languages/tcl/runtime/builtin/incr.pir
trunk/languages/tcl/runtime/builtin/join.pir
trunk/languages/tcl/runtime/builtin/llength.pir
trunk/languages/tcl/runtime/builtin/lrange.pir
trunk/languages/tcl/runtime/builtin/pwd.pir
trunk/languages/tcl/runtime/builtin/set.pir
trunk/languages/tcl/runtime/builtin/time.pir
trunk/languages/tcl/runtime/builtin/while.pir
Removed:
trunk/languages/tcl/src/builtin/
trunk/languages/tcl/tools/gen_inline.pl
Modified:
trunk/languages/tcl/config/makefiles/root.in
trunk/languages/tcl/runtime/builtin/proc.pir
trunk/languages/tcl/runtime/builtin/rename.pir
trunk/languages/tcl/src/grammar/expr/past2pir.tg
trunk/languages/tcl/tools/gen_builtins.pl
Log:
[tcl] http://code.google.com/p/partcl/issues/detail?id=59
Part of the eventual switch to PCT involves changing how we attempt to compile.
This reverts tcl to a pure runtime dispatch for each command; The ".tmt"
files we had been using to generate PIR to use in place of the runtime call
are now gone.
In most cases, just used the version that had been automatically generated by
the original system.
Modified: trunk/languages/tcl/config/makefiles/root.in
==============================================================================
--- trunk/languages/tcl/config/makefiles/root.in (original)
+++ trunk/languages/tcl/config/makefiles/root.in Sun Jul 27 11:57:09 2008
@@ -9,7 +9,6 @@
#CONDITIONED_LINE(darwin):# MACOSX_DEPLOYMENT_TARGET must be defined for OS X
compilation/linking
#CONDITIONED_LINE(darwin):export MACOSX_DEPLOYMENT_TARGET := @osx_version@
-C_BUILTIN = src/builtin
TCL_LIB = library
PMCBUILD = $(PERL) @build_dir@/tools/build/dynpmc.pl
OPSBUILD = $(PERL) @build_dir@/tools/build/dynoplibs.pl
@@ -42,29 +41,9 @@
tclarray \
tcldict
-GENERATED_INLINES = \
- $(C_BUILTIN)/break.pir \
- $(C_BUILTIN)/continue.pir \
- $(C_BUILTIN)/eof.pir \
- $(C_BUILTIN)/exit.pir \
- $(C_BUILTIN)/flush.pir \
- $(C_BUILTIN)/for.pir \
- $(C_BUILTIN)/incr.pir \
- $(C_BUILTIN)/join.pir \
- $(C_BUILTIN)/llength.pir \
- $(C_BUILTIN)/lrange.pir \
- $(C_BUILTIN)/pwd.pir \
- $(C_BUILTIN)/set.pir \
- $(C_BUILTIN)/time.pir \
- $(C_BUILTIN)/while.pir
-
RUNTIME_PIR = $(addprefix runtime/builtin/,$(notdir $(wildcard
languages/tcl/runtime/builtin/*.pir)))
DEPS = \
-$(C_BUILTIN)/cd.pir \
-$(C_BUILTIN)/expr.pir \
-$(C_BUILTIN)/list.pir \
-$(C_BUILTIN)/return.pir \
runtime/conversions.pir \
runtime/string_to_list.pir \
runtime/variables.pir \
@@ -85,12 +64,7 @@
tcl.pbc: $(PARROT) pmcs ops runtime/tcllib.pbc src/tclsh.pir
$(PARROT) --output=tcl.pbc src/tclsh.pir
-$(GENERATED_INLINES) : tools/gen_inline.pl
-
-.SUFFIXES : .pir .tmt .pg .tg .tcl
-
-.tmt.pir :
- $(PERL) tools/gen_inline.pl $< > $@
+.SUFFIXES : .pir .pg .tg .tcl
.tg.pir :
$(PARROT) $(TGE_DIR)/tgc.pir --output=$@ $<
@@ -129,7 +103,7 @@
@cd $(OPSDIR) && $(OPSBUILD) linklibs tcl ../binary$(O)
@cd $(OPSDIR) && $(OPSBUILD) copy "--destination=$(DESTDIR)" tcl
-runtime/builtins.pir: $(GENERATED_INLINES) $(DEPS) tools/gen_builtins.pl
+runtime/builtins.pir: $(DEPS) tools/gen_builtins.pl
$(PERL) tools/gen_builtins.pl > runtime/builtins.pir
runtime/tcllib.pbc: $(PARROT) runtime/tcllib.pir runtime/builtins.pir
$(CLASSES)
@@ -326,7 +300,6 @@
src/grammar/expr/expression.pir \
src/grammar/expr/past2pir.pir \
src/grammar/expr/pge2past.pir \
-$(GENERATED_INLINES) \
"$(OPSDIR)/*.c" \
"$(OPSDIR)/*.h" \
"src/*$(O)" \
Added: trunk/languages/tcl/runtime/builtin/break.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/break.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,22 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&break'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+
+ if argc != 0 goto bad_args
+
+ tcl_break
+
+bad_args:
+ tcl_error 'wrong # args: should be "break"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/languages/tcl/runtime/builtin/cd.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/cd.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,34 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&cd'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+
+ if argc >= 2 goto bad_args
+ if argc == 0 goto noargs
+
+ .local string dir
+ dir = argv[0]
+ goto cd_it
+
+noargs:
+ $P0 = new 'Env'
+ dir = $P0['HOME']
+
+cd_it:
+ $P0 = new 'OS'
+ $S0 = $P0.'chdir'(dir)
+ .return ($S0)
+
+bad_args:
+ tcl_error 'wrong # args: should be "cd ?dirName?"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/languages/tcl/runtime/builtin/continue.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/continue.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,22 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&continue'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+
+ if argc != 0 goto bad_args
+
+ tcl_continue
+
+bad_args:
+ tcl_error 'wrong # args: should be "continue"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/languages/tcl/runtime/builtin/eof.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/eof.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,30 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&eof'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+
+ if argc != 1 goto bad_args
+
+ .local pmc getChannel,channel
+ getChannel = get_root_global ['_tcl'], 'getChannel'
+
+ channel = shift argv
+ channel = getChannel(channel)
+
+ .local int eof
+ eof = isfalse channel
+
+ .return(eof)
+bad_args:
+ tcl_error 'wrong # args: should be "eof channelId"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/languages/tcl/runtime/builtin/exit.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/exit.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,36 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&exit'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+
+ if argc > 1 goto bad_args
+
+ .local int returnCode
+ returnCode = 0
+ if argc == 0 goto got_returnCode
+
+ .local pmc toInteger
+ toInteger = get_root_global ['_tcl'], 'toInteger'
+ .local pmc arg
+ arg = shift argv
+ arg = toInteger(arg)
+
+ returnCode = arg
+
+got_returnCode:
+
+ exit returnCode
+
+bad_args:
+ tcl_error 'wrong # args: should be "exit ?returnCode?"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/languages/tcl/runtime/builtin/flush.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/flush.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,29 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&flush'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+
+ if argc != 1 goto bad_args
+
+ .local pmc getChannel,channel
+ getChannel = get_root_global ['_tcl'], 'getChannel'
+
+ channel = shift argv
+ channel = getChannel(channel)
+
+ channel.'flush'()
+
+ .return('')
+bad_args:
+ tcl_error 'wrong # args: should be "flush channelId"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
Added: trunk/languages/tcl/runtime/builtin/for.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/for.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,66 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&for'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc != 4 goto bad_args
+ # get necessary conversion subs
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
+ .local pmc compileExpr
+ compileExpr = get_root_global ['_tcl'], 'compileExpr'
+ .local pmc a_start
+ a_start = argv[0]
+ a_start = compileTcl(a_start)
+ .local pmc a_test
+ a_test = argv[1]
+ a_test = compileExpr(a_test)
+ .local pmc a_next
+ a_next = argv[2]
+ a_next = compileTcl(a_next)
+ .local pmc a_command
+ a_command = argv[3]
+ a_command = compileTcl(a_command)
+ .local pmc R
+ .local pmc temp
+
+ .local pmc toBoolean
+ toBoolean = get_root_global ['_tcl'], 'toBoolean'
+temp = a_start()
+loop:
+temp = a_test()
+ $P0 = temp
+ $I0 = toBoolean($P0)
+ unless $I0 goto done
+ push_eh command_exception
+temp = a_command()
+ pop_eh
+continue:
+ push_eh next_exception
+temp = a_next()
+ pop_eh
+ goto loop
+
+command_exception:
+ .catch()
+ .get_return_code($I0)
+ if $I0 == .CONTROL_CONTINUE goto continue
+ if $I0 == .CONTROL_BREAK goto done
+ .rethrow()
+
+next_exception:
+ .catch()
+ .get_return_code($I0)
+ if $I0 == .CONTROL_BREAK goto done
+ .rethrow()
+
+done:
+ R = new 'String'
+ R = ''
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "for start test next command"'
+.end
Added: trunk/languages/tcl/runtime/builtin/incr.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/incr.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,38 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&incr'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc < 1 goto bad_args
+ if argc > 2 goto bad_args
+ # get necessary conversion subs
+ .local pmc toInteger
+ toInteger = get_root_global ['_tcl'], 'toInteger'
+ .local pmc readVar
+ readVar = get_root_global ['_tcl'], 'readVar'
+ .local pmc a_varName
+ a_varName = argv[0]
+ a_varName = readVar(a_varName)
+ a_varName = toInteger(a_varName)
+ .local pmc a_increment
+ if argc < 2 goto default_increment
+ a_increment = argv[1]
+ a_increment = toInteger(a_increment)
+ goto done_increment
+default_increment:
+ a_increment = new 'TclInt'
+ a_increment = 1
+done_increment:
+ .local pmc R
+ .local pmc temp
+
+a_varName += a_increment
+R = clone a_varName
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "incr varName ?increment?"'
+.end
+
Added: trunk/languages/tcl/runtime/builtin/join.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/join.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,32 @@
+.sub '&join'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc < 1 goto bad_args
+ if argc > 2 goto bad_args
+ # get necessary conversion subs
+ .local pmc toList
+ toList = get_root_global ['_tcl'], 'toList'
+ .local pmc a_list
+ a_list = argv[0]
+ a_list = toList(a_list)
+ .local pmc a_joinString
+ if argc < 2 goto default_joinString
+ a_joinString = argv[1]
+ goto done_joinString
+default_joinString:
+ a_joinString = new 'TclString'
+ a_joinString = ' '
+done_joinString:
+ .local pmc R
+ .local pmc temp
+
+$S0 = a_joinString
+$S0 = join $S0, a_list
+R = new 'TclString'
+R = $S0
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "join list ?joinString?"'
+.end
Added: trunk/languages/tcl/runtime/builtin/llength.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/llength.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,25 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&llength'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc != 1 goto bad_args
+ # get necessary conversion subs
+ .local pmc toList
+ toList = get_root_global ['_tcl'], 'toList'
+ .local pmc a_list
+ a_list = argv[0]
+ a_list = toList(a_list)
+ .local pmc R
+ .local pmc temp
+
+$I0 = elements a_list
+R = new 'TclInt'
+R = $I0
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "llength list"'
+.end
Added: trunk/languages/tcl/runtime/builtin/lrange.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/lrange.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,57 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&lrange'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc != 3 goto bad_args
+ # get necessary conversion subs
+ .local pmc toList
+ toList = get_root_global ['_tcl'], 'toList'
+ .local pmc a_list
+ a_list = argv[0]
+ a_list = toList(a_list)
+ .local pmc a_first
+ a_first = argv[1]
+ .local pmc a_last
+ a_last = argv[2]
+ .local pmc R
+ .local pmc temp
+
+ .local pmc getIndex
+ getIndex = get_root_global ['_tcl'], 'getIndex'
+
+ .local int from, to
+ from = getIndex(a_first, a_list)
+ to = getIndex(a_last, a_list)
+
+ if from < 0 goto set_first
+have_first:
+ $I0 = elements a_list
+ if $I0 < to goto set_last
+
+ goto have_indices
+
+set_first:
+ from = 0
+ goto have_first
+
+set_last:
+ to = $I0 - 1
+
+have_indices:
+ $I0 = from
+ R = new 'TclList'
+loop:
+ if $I0 > to goto end
+ $P0 = a_list[$I0]
+ push R, $P0
+ inc $I0
+ goto loop
+end:
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "lrange list first last"'
+.end
Modified: trunk/languages/tcl/runtime/builtin/proc.pir
==============================================================================
--- trunk/languages/tcl/runtime/builtin/proc.pir (original)
+++ trunk/languages/tcl/runtime/builtin/proc.pir Sun Jul 27 11:57:09 2008
@@ -46,7 +46,7 @@
if $I0 == 0 goto create
name = pop ns
- if $I0 == 1 goto root
+ if $I0 == 1 goto create
$P0 = get_hll_namespace ns
if null $P0 goto unknown_namespace
@@ -55,22 +55,6 @@
namespace .= "']"
goto create
-root:
- # check to see if this is inlinable
- # if it is, we need to update the epoch
- $S0 = name
- $P1 = get_root_global ['_tcl'; 'builtins'], $S0
- if null $P1 goto create
-
- .local pmc epoch
- epoch = get_root_global ['_tcl'], 'epoch'
- inc epoch
-
- # now we need to delete the helper sub
- # so we don't try to inline anything else
- $P1 = get_root_namespace ['_tcl'; 'builtins']
- delete $P1[$S0]
-
create:
code.emit(<<'END_PIR', namespace, name)
.sub 'xxx' :anon
Added: trunk/languages/tcl/runtime/builtin/pwd.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/pwd.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,26 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&pwd'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc != 0 goto bad_args
+ # get necessary conversion subs
+ .local pmc R
+ .local pmc temp
+
+R = new 'OS'
+R = R.'cwd'()
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "pwd"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
Modified: trunk/languages/tcl/runtime/builtin/rename.pir
==============================================================================
--- trunk/languages/tcl/runtime/builtin/rename.pir (original)
+++ trunk/languages/tcl/runtime/builtin/rename.pir Sun Jul 27 11:57:09 2008
@@ -37,7 +37,7 @@
delete_sub:
delete ns[$S0]
- if delete_only goto delete_builtin
+ if delete_only goto return
add_sub:
# Create the new sub
@@ -53,19 +53,8 @@
set_new_sub:
ns[$S0] = sub
-
-delete_builtin:
- builtin = get_root_global ['_tcl'; 'builtins'], oldName
- if null builtin goto return
-
- $P0 = get_root_namespace ['_tcl'; 'builtins']
- delete $P0[oldName]
-
if delete_only goto return
-add_builtin:
- set_root_global ['_tcl'; 'builtins'], newName, builtin
-
return:
.return('')
Added: trunk/languages/tcl/runtime/builtin/set.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/set.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,48 @@
+.HLL 'Tcl', 'tcl_group'
+.namespace []
+
+.sub '&set'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc < 1 goto bad_args
+ if argc > 2 goto bad_args
+ # get necessary conversion subs
+ .local pmc a_varName
+ a_varName = argv[0]
+ .local pmc a_newValue
+ if argc < 2 goto default_newValue
+ a_newValue = argv[1]
+ goto done_newValue
+default_newValue:
+ null a_newValue
+done_newValue:
+ .local pmc R
+ .local pmc temp
+
+ if null a_newValue goto read_var
+
+ .local pmc set
+ set = get_root_global ['_tcl'], 'setVar'
+ R = set(a_varName, a_newValue)
+ goto end
+
+read_var:
+ .local pmc read
+ read = get_root_global ['_tcl'], 'readVar'
+ R = read(a_varName)
+
+end:
+ R = clone R
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "set varName ?newValue?"'
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
Added: trunk/languages/tcl/runtime/builtin/time.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/time.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,71 @@
+.sub '&time'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc < 1 goto bad_args
+ if argc > 2 goto bad_args
+ # get necessary conversion subs
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
+ .local pmc toInteger
+ toInteger = get_root_global ['_tcl'], 'toInteger'
+ .local pmc a_command
+ a_command = argv[0]
+ a_command = compileTcl(a_command)
+ .local pmc a_count
+ if argc < 2 goto default_count
+ a_count = argv[1]
+ a_count = toInteger(a_count)
+ goto done_count
+default_count:
+ a_count = new 'TclInt'
+ a_count = 1
+done_count:
+ .local pmc R
+ .local pmc temp
+
+ $I0 = a_count
+ if $I0 > 0 goto time_something
+
+ R = new 'TclString'
+ R = '0 microseconds per iteration'
+ goto time_end
+
+time_something:
+ .local num t
+ t = time
+time_loop:
+ if $I0 == 0 goto time_done
+
+temp = a_command()
+
+ dec $I0
+ goto time_loop
+
+time_done:
+ $N0 = time
+ t = $N0 - t
+ t *= 1000000
+
+ $N0 = a_count
+ t /= $N0
+ $I0 = t
+ $S0 = $I0
+ $S0 .= ' microseconds per iteration'
+
+ R = new 'TclString'
+ R = $S0
+time_end:
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "time command ?count?"'
+.end
+
+
+# Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
+
Added: trunk/languages/tcl/runtime/builtin/while.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/runtime/builtin/while.pir Sun Jul 27 11:57:09 2008
@@ -0,0 +1,48 @@
+.sub '&while'
+ .param pmc argv :slurpy
+
+ .local int argc
+ argc = elements argv
+ if argc != 2 goto bad_args
+ # get necessary conversion subs
+ .local pmc compileTcl
+ compileTcl = get_root_global ['_tcl'], 'compileTcl'
+ .local pmc compileExpr
+ compileExpr = get_root_global ['_tcl'], 'compileExpr'
+ .local pmc a_test
+ a_test = argv[0]
+ a_test = compileExpr(a_test)
+ .local pmc a_command
+ a_command = argv[1]
+ a_command = compileTcl(a_command)
+ .local pmc R
+ .local pmc temp
+
+ .local pmc toBoolean
+ toBoolean = get_root_global ['_tcl'], 'toBoolean'
+while_loop:
+temp = a_test()
+ $P0 = temp
+ $I0 = toBoolean($P0)
+ unless $I0 goto while_loop_done
+
+ push_eh while_loop_exception
+temp = a_command()
+ pop_eh
+
+ goto while_loop
+
+while_loop_exception:
+ .catch()
+ .get_return_code($I0)
+ if $I0 == .CONTROL_CONTINUE goto while_loop
+ if $I0 == .CONTROL_BREAK goto while_loop_done
+ .rethrow()
+
+while_loop_done:
+ R = new 'TclString'
+ R = ''
+ .return(R)
+bad_args:
+ tcl_error 'wrong # args: should be "while test command"'
+.end
Modified: trunk/languages/tcl/src/grammar/expr/past2pir.tg
==============================================================================
--- trunk/languages/tcl/src/grammar/expr/past2pir.tg (original)
+++ trunk/languages/tcl/src/grammar/expr/past2pir.tg Sun Jul 27 11:57:09 2008
@@ -208,9 +208,6 @@
$P0 = shift iter
name = $P0['value']
- .local int has_expand
- has_expand = 0
-
iter_loop:
unless iter goto iter_done
$P1 = shift iter
@@ -219,13 +216,10 @@
push args, reg
pir .= $P0
$S0 = typeof $P1
- if $S0 == 'PAST::Expand' goto iter_expand
+ if $S0 == 'PAST::Expand' goto iter_loop
unless $S0 == 'PAST::Var' goto iter_loop
pir.emit(" %0 = clone %0", reg)
goto iter_loop
- iter_expand:
- has_expand = 1
- goto iter_loop
iter_done:
.local string retval
retval = pir.unique('$P')
@@ -237,22 +231,7 @@
$P0 = shift children
$S0 = $P0['value']
- if has_expand goto dynamic
- $P1 = get_root_global ['_tcl'; 'builtins'], $S0
- if null $P1 goto dynamic
-
- $P0 = $P1(retval, children,args)
- if null $P0 goto dynamic
-
- .local pmc epoch
- epoch = get_root_global ['_tcl'], 'epoch'
- $S0 = pir.unique('dynamic_')
- pir.emit(' if epoch != %0 goto %1', epoch, $S0)
- pir .= $P0
- pir.emit(' goto %0', done_)
- pir.emit('%0:', $S0)
- dynamic:
.local string ns
ns = ''
$S0 = join ", ", args
Modified: trunk/languages/tcl/tools/gen_builtins.pl
==============================================================================
--- trunk/languages/tcl/tools/gen_builtins.pl (original)
+++ trunk/languages/tcl/tools/gen_builtins.pl Sun Jul 27 11:57:09 2008
@@ -8,7 +8,6 @@
use lib qw(lib);
my $static_dir = 'runtime/builtin';
-my $dynamic_dir = 'src/builtin';
print <<EOH;
# This file automatically generated by $0.
@@ -18,26 +17,10 @@
# commands that are in Tcl's :: namespace directly
my @static_cmds = pir_cmds_in_dir($static_dir);
-# subroutines that generate the PIR for Tcl commands
-my @dynamic_cmds = pir_cmds_in_dir($dynamic_dir);
-
print " .HLL 'tcl', 'tcl_group'\n";
-print " .include 'languages/tcl/$dynamic_dir/$_.pir'\n" for @dynamic_cmds;
-
-#print <<'END_PIR';
-#
-#.HLL 'tcl', 'tcl_group'
-#.namespace []
-#
-#END_PIR
-
print " .include 'languages/tcl/$static_dir/$_.pir'\n" for @static_cmds;
-# For every builtin with an inline'd version and no interpreted version,
-# create a shim for the interpreted version that automatically calls
-# the inline'd version, compiles the result and invokes it.
-
sub pir_cmds_in_dir {
my ($dir) = @_;
|
|