Author: leo
Date: Tue Aug 2 02:26:10 2005
New Revision: 8764
Added:
branches/leo-ctx5/languages/lazy-k/
- copied from r8763, trunk/languages/lazy-k/
branches/leo-ctx5/languages/lazy-k/README
- copied unchanged from r8763, trunk/languages/lazy-k/README
branches/leo-ctx5/languages/lazy-k/calc.lazy (props changed)
- copied unchanged from r8763, trunk/languages/lazy-k/calc.lazy
branches/leo-ctx5/languages/lazy-k/lazy.pir (props changed)
- copied unchanged from r8763, trunk/languages/lazy-k/lazy.pir
branches/leo-ctx5/languages/lazy-k/powers2.lazy (props changed)
- copied unchanged from r8763, trunk/languages/lazy-k/powers2.lazy
branches/leo-ctx5/languages/lazy-k/test.sh (props changed)
- copied unchanged from r8763, trunk/languages/lazy-k/test.sh
branches/leo-ctx5/languages/tcl/lib/parser.pir
- copied unchanged from r8763, trunk/languages/tcl/lib/parser.pir
branches/leo-ctx5/languages/tcl/lib/tclcommand.pir
- copied unchanged from r8763, trunk/languages/tcl/lib/tclcommand.pir
branches/leo-ctx5/languages/tcl/lib/tclconst.pir
- copied unchanged from r8763, trunk/languages/tcl/lib/tclconst.pir
branches/leo-ctx5/languages/tcl/lib/tclvar.pir
- copied unchanged from r8763, trunk/languages/tcl/lib/tclvar.pir
Removed:
branches/leo-ctx5/languages/tcl/classes/tclparser.pmc
Modified:
branches/leo-ctx5/CREDITS
branches/leo-ctx5/MANIFEST
branches/leo-ctx5/build_tools/pmc2c.pl
branches/leo-ctx5/compilers/pge/demo.pir
branches/leo-ctx5/config/gen/makefiles/tcl.in
branches/leo-ctx5/languages/LANGUAGES.STATUS
branches/leo-ctx5/languages/tcl/lib/commands/catch.pir
branches/leo-ctx5/languages/tcl/lib/commands/eval.pir
branches/leo-ctx5/languages/tcl/lib/commands/for.pir
branches/leo-ctx5/languages/tcl/lib/commands/foreach.pir
branches/leo-ctx5/languages/tcl/lib/commands/if.pir
branches/leo-ctx5/languages/tcl/lib/commands/proc.pir
branches/leo-ctx5/languages/tcl/lib/commands/puts.pir
branches/leo-ctx5/languages/tcl/lib/commands/source.pir
branches/leo-ctx5/languages/tcl/lib/commands/time.pir
branches/leo-ctx5/languages/tcl/lib/commands/while.pir
branches/leo-ctx5/languages/tcl/lib/expression.pir
branches/leo-ctx5/languages/tcl/lib/interpret.pir
branches/leo-ctx5/languages/tcl/lib/list_to_string.pir
branches/leo-ctx5/languages/tcl/lib/string_to_list.pir
branches/leo-ctx5/languages/tcl/lib/tcl.p6r
branches/leo-ctx5/languages/tcl/lib/tclword.pir
branches/leo-ctx5/languages/tcl/t/tcl_command_subst.t
branches/leo-ctx5/languages/tcl/tcl.pir
branches/leo-ctx5/languages/tcl/tcl.pir_template
branches/leo-ctx5/languages/tcl/tcl.pl
branches/leo-ctx5/runtime/parrot/library/dumper.imc
branches/leo-ctx5/t/library/dumper.t
Log:
merge -r8757:8763 from trunk; resolve to conflicts in
tcl/lib/commands/while.pir and tcl/lib/interpret.pir
Modified: branches/leo-ctx5/CREDITS
==============================================================================
--- branches/leo-ctx5/CREDITS (original)
+++ branches/leo-ctx5/CREDITS Tue Aug 2 02:26:10 2005
@@ -185,7 +185,9 @@ D: Lexical pads, CPS.
N: Jonathan Stowe
N: Jonathan Worthington
-D: Win32 building
+D: Win32 dynclasses support, Win32 fixes and various other patches
+E: [EMAIL PROTECTED]
+W: http://www.jwcs.net/~jonathan/
N: Jos Visser
D: fortytwo opcode
@@ -287,6 +289,9 @@ N: Ritz Daniel
N: Robert Spier
D: Keeps us running
+N: Roland Illing
+D: Building Parrot with pkgsrc
+
N: Ron Blaschke
D: Win32 patches
Modified: branches/leo-ctx5/MANIFEST
==============================================================================
--- branches/leo-ctx5/MANIFEST (original)
+++ branches/leo-ctx5/MANIFEST Tue Aug 2 02:26:10 2005
@@ -1026,6 +1026,11 @@ languages/jako/string.jako
languages/jako/sys.jako [jako]
languages/jako/t/assign.jako [jako]
languages/jako/t/data_decl.jako [jako]
+languages/lazy-k/README [lazy-k]
+languages/lazy-k/calc.lazy [lazy-k]
+languages/lazy-k/lazy.pir [lazy-k]
+languages/lazy-k/powers2.lazy [lazy-k]
+languages/lazy-k/test.sh [lazy-k]
languages/lisp/t/test.l [lisp]
languages/lisp/lisp/logic.l [lisp]
languages/lisp/lisp/core.l [lisp]
@@ -1358,7 +1363,6 @@ languages/tcl/classes/tclint.pmc
languages/tcl/classes/tcllist.pmc [tcl]
languages/tcl/classes/tclstring.pmc [tcl]
languages/tcl/classes/tclobject.pmc [tcl]
-languages/tcl/classes/tclparser.pmc [tcl]
languages/tcl/docs/expr.pod [tcl]
languages/tcl/docs/hacks.pod [tcl]
languages/tcl/docs/howto.pod [tcl]
@@ -1417,7 +1421,11 @@ languages/tcl/lib/interpret.pir
languages/tcl/lib/list.pir [tcl]
languages/tcl/lib/list_to_string.pir [tcl]
languages/tcl/lib/macros/is_space.pir [tcl]
+languages/tcl/lib/parser.pir [tcl]
languages/tcl/lib/string_to_list.pir [tcl]
+languages/tcl/lib/tclcommand.pir [tcl]
+languages/tcl/lib/tclconst.pir [tcl]
+languages/tcl/lib/tclvar.pir [tcl]
languages/tcl/lib/tclword.pir [tcl]
languages/tcl/lib/tcl.p6r [tcl]
languages/tcl/lib/variables.pir [tcl]
Modified: branches/leo-ctx5/build_tools/pmc2c.pl
==============================================================================
--- branches/leo-ctx5/build_tools/pmc2c.pl (original)
+++ branches/leo-ctx5/build_tools/pmc2c.pl Tue Aug 2 02:26:10 2005
@@ -269,6 +269,10 @@ main();
sub find_file {
my ($include, $file, $die_unless_found) = @_;
+ if (File::Spec->file_name_is_absolute($file) && -e $file) {
+ return $file;
+ }
+
foreach my $dir ( @$include ) {
my $path = File::Spec->catfile( $dir, $file );
return $path if -e $path;
Modified: branches/leo-ctx5/compilers/pge/demo.pir
==============================================================================
--- branches/leo-ctx5/compilers/pge/demo.pir (original)
+++ branches/leo-ctx5/compilers/pge/demo.pir Tue Aug 2 02:26:10 2005
@@ -21,7 +21,7 @@
istrace = 0
null rulesub
- gparse = p6rule_compile(":w ( (grammar) <ident> ; | (rule) <ident>
\{$<rulex>:=[<-[{]>*]\} )*")
+ gparse = p6rule_compile(":w ( (grammar) <ident> ; | (rule) <ident>
\{$<rulex>:=[<-[{]>*]\} ;? )*")
read_loop:
print "\ninput \"rule <pattern>\", \"glob <pattern>\", \"save <name>\",\n"
Modified: branches/leo-ctx5/config/gen/makefiles/tcl.in
==============================================================================
--- branches/leo-ctx5/config/gen/makefiles/tcl.in (original)
+++ branches/leo-ctx5/config/gen/makefiles/tcl.in Tue Aug 2 02:26:10 2005
@@ -14,8 +14,7 @@ PMCS = \
tclint \
tclfloat \
tcllist \
- tclarray \
- tclparser
+ tclarray
DEPS = $(PARROT) \
lib${slash}commands${slash}append.pir \
@@ -64,14 +63,16 @@ lib${slash}expression.pir \
lib${slash}get_var.pir \
lib${slash}interpret.pir \
lib${slash}list.pir \
+lib${slash}list_to_string.pir \
lib${slash}macros${slash}is_space.pir \
+lib${slash}parser.pir \
lib${slash}string_to_list.pir \
lib${slash}tcl.p6r \
lib${slash}variables.pir \
tcl.pir_template \
tcl.pl
-tcl.pbc: pmcs lib${slash}tcllib.pbc lib${slash}tclword.pbc tcl.pir
+tcl.pbc: pmcs lib${slash}tcllib.pbc lib${slash}tclcommand.pbc
lib${slash}tclconst.pbc lib${slash}tclvar.pbc lib${slash}tclword.pbc tcl.pir
$(PARROT) --output=tcl.pbc tcl.pir
pmcs:
@@ -89,6 +90,15 @@ lib${slash}tcllib.pir: $(DEPS)
lib${slash}tcllib.pbc: lib${slash}tcllib.pir
$(PARROT) --output=$(LIBPATH)${slash}tcllib.pbc
$(LIBPATH)${slash}tcllib.pir
+lib${slash}tclcommand.pbc: lib${slash}tclcommand.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclcommand.pbc
$(LIBPATH)${slash}tclcommand.pir
+
+lib${slash}tclconst.pbc: lib${slash}tclconst.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclconst.pbc
$(LIBPATH)${slash}tclconst.pir
+
+lib${slash}tclvar.pbc: lib${slash}tclvar.pir
+ $(PARROT) --output=$(LIBPATH)${slash}tclvar.pbc
$(LIBPATH)${slash}tclvar.pir
+
lib${slash}tclword.pbc: lib${slash}tclword.pir
$(PARROT) --output=$(LIBPATH)${slash}tclword.pbc
$(LIBPATH)${slash}tclword.pir
Modified: branches/leo-ctx5/languages/LANGUAGES.STATUS
==============================================================================
--- branches/leo-ctx5/languages/LANGUAGES.STATUS (original)
+++ branches/leo-ctx5/languages/LANGUAGES.STATUS Tue Aug 2 02:26:10 2005
@@ -87,6 +87,13 @@ S: generation was written, causing some
M: Yes
V: 0.0.11
+N: lazy-k
+A: Leopold Tötsch
+D: lazy-k is a pure functional programming language according to the
+D: SKI calculus.
+W: http://homepages.cwi.nl/~tromp/cl/lazy-k.html
+V: 0.2.2
+
N: m4
A: Bernhard Schmalhofer
D: Port of GNU m4 to PIR
@@ -119,7 +126,7 @@ D: variables, nested words and classes a
D: compile-time and run-time lexical word, class and variable scopes.
S: Under development;
S: Not in Parrot CVS
-W: http://www.daca.net:8080/Parakeet-0.1.tgz
+W: http://www.daca.net:8080/Parakeet-0.1.tgz
V: 0.0.11
N: parrot_compiler
@@ -201,7 +208,7 @@ N: unlamba
A: Leopold Tötsch
D: unlambda is a pure functional programming language with mostly eager
D: evaluation following the SKI calculus (+ a few extensions)
-S: Errors on HEAD branch, which will go away after complete merge of
+S: Errors on HEAD branch, which will go away after complete merge of
S: Leo's branch,
W: http://www.madore.org/~david/programs/unlambda/
V: 0.2.2
Modified: branches/leo-ctx5/languages/tcl/lib/commands/catch.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/catch.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/catch.pir Tue Aug 2
02:26:10 2005
@@ -13,10 +13,10 @@
.local pmc retval
.local string varname
.local string code
- .local pmc parser
+ .local pmc parse
.local pmc interpret
return_type = TCL_OK
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
.local int call_level
@@ -26,7 +26,7 @@
if argc == 0 goto badargs
if argc > 2 goto badargs
code = argv[0]
- $P1 = parser."parse"(code,0,0)
+ $P1 = parse(code)
register $P1
# ignoring $P0 here.
($I0,$P0) = interpret($P1)
Modified: branches/leo-ctx5/languages/tcl/lib/commands/eval.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/eval.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/eval.pir Tue Aug 2
02:26:10 2005
@@ -16,9 +16,9 @@
.local int looper
- .local pmc parser
+ .local pmc parse
.local pmc interpret
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expr = ""
@@ -35,7 +35,7 @@ loop:
goto loop
loop_done:
- $P1 = parser."parse"(expr,0,0)
+ $P1 = parse(expr)
register $P1
.return interpret($P1)
Modified: branches/leo-ctx5/languages/tcl/lib/commands/for.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/for.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/for.pir Tue Aug 2
02:26:10 2005
@@ -22,22 +22,22 @@
.local pmc retval
.local int return_type
- .local pmc parser, interpret
+ .local pmc parse, interpret
.local pmc expression_p, expression_i
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expression_p = find_global "_Tcl", "__expression_parse"
expression_i = find_global "_Tcl", "__expression_interpret"
# Parse the bits that are code.
$S0 = start_p
- start_parsed = parser."parse"($S0,0,0)
+ start_parsed = parse($S0)
register start_parsed
$S0 = next_p
- next_parsed = parser."parse"($S0,0,0)
+ next_parsed = parse($S0)
register next_parsed
$S0 = body_p
- body_parsed = parser."parse"($S0,0,0)
+ body_parsed = parse($S0)
register body_parsed
Modified: branches/leo-ctx5/languages/tcl/lib/commands/foreach.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/foreach.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/foreach.pir Tue Aug 2
02:26:10 2005
@@ -5,7 +5,7 @@
# Requires multiple of 3 args.
.local int return_type
- .local pmc parser,interpret,retval
+ .local pmc parse,interpret,retval
retval = new TclString
retval = ""
@@ -22,7 +22,7 @@
.local pmc __list
__list = find_global "_Tcl", "__list"
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
return_type = TCL_OK
@@ -76,7 +76,7 @@ got_list:
goto arg_loop
arg_done:
.local pmc parsed
- parsed = parser."parse"(body,0,0)
+ parsed = parse(body)
register parsed
.local pmc iterator
Modified: branches/leo-ctx5/languages/tcl/lib/commands/if.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/if.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/if.pir Tue Aug 2 02:26:10 2005
@@ -23,9 +23,9 @@
handling_else = 0
.local int counter
- .local pmc parser,interpret
+ .local pmc parse,interpret
.local pmc expression_p,expression_i
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expression_p = find_global "_Tcl", "__expression_parse"
expression_i = find_global "_Tcl", "__expression_interpret"
@@ -108,7 +108,7 @@ do_else:
code = else
done:
- $P1 = parser."parse"(code,0,0)
+ $P1 = parse(code)
register $P1
.return interpret($P1) #tailcall
Modified: branches/leo-ctx5/languages/tcl/lib/commands/proc.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/proc.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/proc.pir Tue Aug 2
02:26:10 2005
@@ -24,8 +24,8 @@ Create a PIR sub on the fly for this use
.local pmc retval
return_type = TCL_OK
- .local pmc parser
- parser = find_global "_Tcl", "parser"
+ .local pmc parse
+ parse = find_global "_Tcl", "parse"
.local pmc __list
__list = find_global "_Tcl", "__list"
@@ -42,7 +42,7 @@ got_args:
# Save the parsed body.
.local pmc parsed_body
$S0 = body_p
- parsed_body = parser."parse"($S0,0,0)
+ parsed_body = parse($S0)
register parsed_body
# XXX these need to go away - for now, we'll just escape
Modified: branches/leo-ctx5/languages/tcl/lib/commands/puts.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/puts.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/puts.pir Tue Aug 2
02:26:10 2005
@@ -55,7 +55,8 @@ two_arg_channel:
goto done
one_arg:
- $S1 = argv[0]
+ $P0 = argv[0]
+ $S1 = $P0
print $S1
print "\n"
goto done
Modified: branches/leo-ctx5/languages/tcl/lib/commands/source.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/source.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/source.pir Tue Aug 2
02:26:10 2005
@@ -12,9 +12,9 @@
.local string chunk, filename, contents
.local int code,type
- .local pmc retval, handle, parser
+ .local pmc retval, handle, parse
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
.local pmc interpret
interpret = find_global "_Tcl", "__interpret"
@@ -40,7 +40,7 @@ loop:
goto loop
gotfile:
- $P1 = parser."parse"(contents,0,0)
+ $P1 = parse(contents)
register $P1
(code,retval) = interpret($P1)
goto done
Modified: branches/leo-ctx5/languages/tcl/lib/commands/time.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/time.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/time.pir Tue Aug 2
02:26:10 2005
@@ -14,8 +14,8 @@
.local int return_type
return_type = TCL_OK
- .local pmc parser,interpret
- parser = find_global "_Tcl", "parser"
+ .local pmc parse,interpret
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
.local string script
@@ -37,7 +37,7 @@ twoargs:
run:
script = argv[0]
- $P1 = parser."parse"(script,0,0)
+ $P1 = parse(script)
register $P1
time $N1
Modified: branches/leo-ctx5/languages/tcl/lib/commands/while.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/commands/while.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/commands/while.pir Tue Aug 2
02:26:10 2005
@@ -7,30 +7,32 @@
.param pmc argv :slurpy
.local int argc
argc = argv
-
+
if argc != 2 goto bad_args
.param pmc cond_p
cond_p = argv[0]
- .param string body
- cond_p = argv[1]
+ .param string body_p
+ body_p = argv[1]
.local pmc retval, parsed_code
.local int return_type
- .local pmc parser
+ .local pmc parse
.local pmc interpret
.local pmc expression_p
.local pmc expression_i
- parser = find_global "_Tcl", "parser"
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
expression_p = find_global "_Tcl", "__expression_parse"
expression_i = find_global "_Tcl", "__expression_interpret"
-while_loop:
- parsed_code = parser."parse"(body,0,0)
+ $S0 = body_p
+ parsed_code = parse($S0)
register parsed_code
+
+while_loop:
(return_type,retval) = expression_p(cond_p)
if return_type == TCL_ERROR goto done_done
(return_type,retval) = expression_i(retval)
Modified: branches/leo-ctx5/languages/tcl/lib/expression.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/expression.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/expression.pir Tue Aug 2 02:26:10 2005
@@ -28,9 +28,6 @@ however, then we're returning the invoka
.local pmc precedences # Global list of operator precedence
precedences = find_global "_Tcl", "precedence"
- .local pmc parser
- parser = find_global "_Tcl", "parser"
-
.local pmc undef
undef = new Undef
@@ -73,15 +70,34 @@ get_parenthetical:
# string and call ourselves recursively.
# (XXX should unroll this recursion.)
- if char != 40 goto get_variable
- # where do we close?
- $I1 = parser."match_close"(expr,chunk_start)
- #.match_close(expr,chunk_start,$I1)
- #error_S = "missing close parenthesis"
- if $I1 <= 0 goto die_horribly
- $I1 = $I1 - 2
- inc chunk_start
- substr $S1, expr, chunk_start, $I1
+ if char != 40 goto get_variable # (
+ .local int depth
+ depth = 1
+ $I1 = chunk_start
+get_paren_loop:
+ inc $I1
+ if $I1 >= expr_length goto die_horribly
+ $I0 = ord expr, $I1
+ if $I0 == 41 goto get_paren_loop_right
+ if $I0 == 40 goto get_paren_loop_left
+ if $I0 == 92 goto get_paren_loop_backslash
+ goto get_paren_loop
+get_paren_loop_right:
+ dec depth
+ if depth == 0 goto get_paren_done
+ goto get_paren_loop
+get_paren_loop_left:
+ inc depth
+ goto get_paren_loop
+get_paren_loop_backslash:
+ inc $I1
+ goto get_paren_loop
+
+get_paren_done:
+ $I0 = $I1 - chunk_start
+ dec $I0
+ inc chunk_start
+ substr $S1, expr, chunk_start, $I0
$P9 = new String
$P9 = $S1
@@ -96,7 +112,7 @@ get_parenthetical:
chunk[1] = retval
push chunks, chunk
- chunk_start = chunk_start + $I1
+ chunk_start += $I0
inc chunk_start
goto chunk_loop
@@ -842,21 +858,42 @@ dd:
.local pmc func,operand
.local int start_paren_pos
-
- .local pmc parser
- parser = find_global "_Tcl", "parser"
+ .local int expr_length
+ expr_length = length expr
# if we are starting with the text of a defined function,
# and it's followed by a (),
index start_paren_pos, expr, "(", start
if start_paren_pos == -1 goto fail
- #.match_close(expr,start_paren_pos,$I1)
- $I1 = parser."match_close"(expr,start_paren_pos)
- if $I1 <= 0 goto fail
+
+ .local int depth
+ depth = 1
+ $I0 = start_paren_pos
+loop:
+ inc $I0
+ if $I0 >= expr_length goto fail
+ $I1 = ord expr, $I0
+ if $I1 == 40 goto left
+ if $I1 == 41 goto right
+ if $I1 == 92 goto backslash
+ goto loop
+left:
+ inc depth
+ goto loop
+right:
+ dec depth
+ if depth == 0 goto loop_done
+ goto loop
+backslash:
+ inc $I0
+ goto loop
+
+loop_done:
+ $I1 = $I0 - start_paren_pos
+ dec $I1
# so, we know that the function name must be before the first (
-
.local int len
len = start_paren_pos - start
@@ -876,7 +913,7 @@ dd:
inc start_paren_pos
.local int len_operand
- len_operand = $I1 - 2
+ len_operand = $I1
substr $S1, expr, start_paren_pos, len_operand
$P9 = new String
Modified: branches/leo-ctx5/languages/tcl/lib/interpret.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/interpret.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/interpret.pir Tue Aug 2 02:26:10 2005
@@ -14,82 +14,18 @@ Given a pre-parsed chunk of Tcl, interpr
return_type = TCL_OK
.local pmc retval
- # Which command are we processing?
- .local int command_num,num_commands
- command_num = -1
- num_commands = commands
- .local pmc command
- .local string proc
- .local pmc args,my_cmd,parsed_body,argument_list
-
-end_scope:
- inc command_num
- if command_num == num_commands goto done
- if return_type != TCL_OK goto done
- command = commands[command_num]
-
- # this should stringify the tclword object, which performs
- # all necessary substitutions.
- $P0 = command[0]
- (return_type,retval) = $P0.__get_pmc()
-
- if return_type != TCL_OK goto done
- proc = retval
-
- .local int num_args,arg_num
- num_args = command
- arg_num = 1
-
- # The subs we're calling expect flattened args,
- # as passed with the ":flag" arg adverb.
-
- .local string caller_sub_text
-
- push_eh no_command
- my_cmd = find_global "Tcl", proc
- clear_eh
- # we can't delete commands, so we store deleted commands
- # as null PMCs
- isnull my_cmd, no_command
+ .local int elems, i
+ elems = commands
+ i = 0
-got_command:
- .local pmc folded_args
- folded_args = new TclList
- .local pmc current_word
-
-loop:
- if arg_num == num_args goto loop_done
- current_word = command[arg_num]
- (return_type,retval) = current_word.__get_pmc()
+ .local pmc command
+next_command:
+ if i == elems goto done
if return_type != TCL_OK goto done
-
- push folded_args, retval
- inc arg_num
- goto loop
-
-loop_done:
- (return_type,retval) = my_cmd(folded_args :flat)
- goto end_scope
-
-no_command:
- $P1 = find_global "Tcl", "tcl_interactive"
- unless $P1 goto no_command_non_interactive
-
- # XXX Should probably make sure this wasn't redefined on us.
- my_cmd = find_global "Tcl", "unknown"
-
- # Add the command into the unknown handler, and fix our bookkeeping
- unshift command, proc
- inc num_args
-
- goto got_command
-
-no_command_non_interactive:
- return_type = TCL_ERROR
- $S0 = "invalid command name \""
- $S0 .= proc
- $S0 .= "\""
- retval = $S0
+ command = commands[i]
+ (return_type, retval) = command.interpret()
+ inc i
+ goto next_command
done:
.return(return_type,retval)
Modified: branches/leo-ctx5/languages/tcl/lib/list_to_string.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/list_to_string.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/list_to_string.pir Tue Aug 2
02:26:10 2005
@@ -42,6 +42,24 @@ right_brace:
check_list_done:
if count != 0 goto escape
+ # {}'d constructs
+check_spaces:
+ $I0 = find_whitespace $S0, 0
+ if $I0 != -1 goto quote
+
+check_left_bracket:
+ $I0 = index $S0, "["
+ if $I0 != -1 goto quote
+
+check_dollar_sign:
+ $I0 = index $S0, "$"
+ if $I0 != -1 goto quote
+
+check_semi_colon:
+ $I0 = index $S0, ";"
+ if $I0 != -1 goto quote
+
+ # \'d constructs
check_right_bracket:
$I0 = index $S0, "]"
if $I0 != -1 goto escape
@@ -50,7 +68,11 @@ check_backslash:
$I0 = index $S0, "\\"
if $I0 != -1 goto escape
- goto check_spaces
+check_quotes:
+ $I0 = index $S0, "\""
+ if $I0 != -1 goto escape
+
+ goto append_elem
escape:
$P0 = new String
@@ -61,26 +83,9 @@ escape:
$P0."replace"("{", "\\{")
$P0."replace"(" ", "\\ ")
$P0."replace"("]", "\\]")
+ $P0."replace"("\"", "\\\"")
- $S0 = $P0
- goto append_elem
-
-check_spaces:
- $I0 = find_whitespace $S0, 0
- if $I0 != -1 goto quote
-
-check_left_bracket:
- $I0 = index $S0, "["
- if $I0 != -1 goto quote
-
-check_dollar_sign:
- $I0 = index $S0, "$"
- if $I0 != -1 goto quote
-
-check_semi_colon:
- $I0 = index $S0, ";"
- if $I0 != -1 goto quote
-
+ $S0 = $P0
goto append_elem
empty:
Modified: branches/leo-ctx5/languages/tcl/lib/string_to_list.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/string_to_list.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/string_to_list.pir Tue Aug 2
02:26:10 2005
@@ -1,5 +1,3 @@
-# XXX move into a PMC vtable
-
.namespace [ "_Tcl" ]
.sub __stringToList
@@ -10,32 +8,118 @@
.local pmc retval
retval = new TclList
-
- .local pmc parsed_str
- .local pmc parser
- parser = find_global "_Tcl", "parser"
+ .local int pos, len
+ # we're going to increment before we use it, so set it to 0-1
+ pos = -1
+ len = length str
+
+eat_space:
+ inc pos
+ $I0 = is_whitespace str, pos
+ if $I0 == 1 goto eat_space
+
+loop:
+ if pos >= len goto done
- push_eh parse_error
- parsed_str = parser."parse"(str,0,1)
- clear_eh
- register parsed_str
+ # check if the first char is a {
+ $I0 = ord str, pos
+ if $I0 == 123 goto list
+ if $I0 == 34 goto quote
+
+not_list:
+ $I0 = find_whitespace str, pos
+ if $I0 == -1 goto loop_done
- $I0 = parsed_str
- if $I0 == 0 goto done
-
- retval = shift parsed_str
-
- # XXX If there is more than one entry in the parsed_str array, then
- # there's probably an error condition we need to raise.
+ # extract the element
+ $I1 = $I0 - pos
+ $S0 = substr str, pos, $I1
+
+ # add it to the list
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
+ # find the next pos
+ pos = $I0
+ goto eat_space
+
+loop_done:
+ # grab the rest of the string
+ $I1 = len - pos
+ $S0 = substr str, pos, $I1
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
goto done
+
+ # find the closing '"'
+quote:
+ inc pos
+ $I1 = pos
+quote_loop:
+ $I0 = ord str, $I1
+ if $I0 == 92 goto quote_backslash
+ if $I0 == 34 goto found_quote
+ inc $I1
+ goto quote_loop
+quote_backslash:
+ $I1 += 2
+ goto quote_loop
+found_quote:
+ $I0 = $I1 - pos
+ $S0 = substr str, pos, $I0
+
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
+
+ pos = $I1
+ inc pos
+ goto loop
+
+list:
+ .local int depth
+ depth = 1
+ $I1 = pos
+find_close_bracket:
+ inc $I1
+ if $I1 >= len goto unmatched_open_brace
+ $I0 = ord str, $I1
+ if $I0 == 123 goto left_bracket
+ if $I0 == 125 goto right_bracket
+ if $I0 == 92 goto backslash
+ goto find_close_bracket
+backslash:
+ inc $I1
+ goto find_close_bracket
+left_bracket:
+ inc depth
+ goto find_close_bracket
+right_bracket:
+ dec depth
+ if depth == 0 goto found_close_bracket
+ goto find_close_bracket
+
+found_close_bracket:
+ # length -- if we have "{ }", pos and $I0 should both be 1
+ $I0 = $I1 - pos
+ $I0 -= 1
+ inc pos
+ $S0 = substr str, pos, $I0
+ pos += $I0
+ pos += 2
-parse_error:
+ $P0 = new String
+ $P0 = $S0
+ push retval, $P0
+
+ goto loop
+
+unmatched_open_brace:
return_type = TCL_ERROR
- $S0 = P5["_message"]
retval = new String
- retval = $S0
+ retval = "unmatched open brace in list"
# goto done
done:
Modified: branches/leo-ctx5/languages/tcl/lib/tcl.p6r
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/tcl.p6r (original)
+++ branches/leo-ctx5/languages/tcl/lib/tcl.p6r Tue Aug 2 02:26:10 2005
@@ -1,55 +1,45 @@
-rule command { \[ (.*?) \] };
-rule quotes { " ([\\.|<-["]>]*) : " };
-rule braces { \{ : ([\\.|<braces>|<-[\{\}]>]*) : \} }
-rule variable { \$ [
- (<[A..Za..z_0..9]>+) |
- (<[A..Za..z_0..9]>* \( <[A..Za..z_0..9]>* \)) |
- \{ (<-[\}]>*) \}
- ]
-};
-
-rule float { [<[0..9]>+|0+]\.<[0..9]>* };
-rule decimal { <[1..9]><[0..9]>*] };
-rule octal { 0<[0..7]>*: };
-rule hex { 0<[xX]><[0..9A..Fa..f]>+ };
-rule number { [<float> | <decimal> | <octal> | <hex> ] };
+grammar _TclRules;
-rule nullary_functions { rand };
+rule command { \[ (.*?) \] }
+rule quotes { " ([\\.|<-["]>]*) : " }
+
+rule float { [<[0..9]>+|0+]\.<[0..9]>* }
+rule decimal { <[1..9]><[0..9]>*] }
+rule octal { 0<[0..7]>*: }
+rule hex { 0<[xX]><[0..9A..Fa..f]>+ }
+rule number { [<float> | <decimal> | <octal> | <hex> ] }
+
+rule unaryop { <[\-+~!]> }
+
+rule expr {:w <logor> | <logor> \? <logor> : <logor> }
+rule logor {:w <logand> [ (\|\|) <logand> ]* }
+rule logand {:w <bitor> [ (&&) <bitor> ]* }
+rule bitor {:w <bitxor> [ (\|) <bitxor> ]* }
+rule bitxor {:w <bitand> [ (\^) <bitand> ]* }
+rule bitand {:w <listin> [ (&) <listin> ]* }
+rule listin {:w <streq> [ (in|ni) <streq> ]* }
+rule streq {:w <equals> [ (eq|ne) <equals> ]* }
+rule equals {:w <compare> [ (\==|\!=) <compare> ]* }
+rule compare {:w <shifted> [ (\<|\>|\<=|\>=) <shifted> ]* }
+rule shifted {:w <sum> [ (\<\<|\>\>) <sum> ]* }
+rule sum {:w <term> [ (<[+\-]>) <term> ]* }
+rule term {:w <power> [ (<[*/%]>) <power> ]* }
+rule power {:w <unary> [ (\*\*) <unary> ]* }
+rule unary {:w <unaryop>* <operand> }
+
+rule operand { <number> | \( <expr> \) | <function> | <command> | <quotes> }
+
+rule nullary_functions { rand }
rule unary_functions {
abs | acos | asin | atan | ceil | cosh? | double | exp | floor | int |
log | log10 | round | sinh? | sqrt | srand | tanh? | wide
-};
+}
-rule binary_functions { atan2 | fmod | hypot | pow };
+rule binary_functions { atan2 | fmod | hypot | pow }
rule function {
<nullary_functions> \( \) |
- <unary_functions> \( <factor> \) |
- <binary_functions> \( <factor> , <factor> \)
-};
-
-rule unaryop { <[\-+~!]> };
-
-rule factor { <unaryop>* [ <operand> | <power> | \( <factor> \) ]};
-
-rule power {:w <term> [ (\*\*) <term> ]* };
-rule term {:w <sum> [ (<[*/%]>) <sum> ]* };
-rule sum {:w <shifted> [ (<[+\-]>) <shifted> ]* };
-rule shifted {:w <compare> [ (\<\<|\>\>) <compare> ]* };
-rule compare {:w <equals> [ (\<|\>|\<=|\>=) <equals> ]* };
-rule equals {:w <streq> [ (\==|\!=) <streq> ]* };
-rule streq {:w <listin> [ (eq|ne) <listin> ]* };
-rule listin {:w <bitand> [ (in|ni) <bitand> ]* };
-rule bitand {:w <bitxor> [ (&) <bitxor> ]* };
-rule bitxor {:w <bitor> [ (\^) <bitor> ]* };
-rule bitor {:w <logand> [ (\|) <logand> ]* };
-rule logand {:w <logor> [ (&&) <logor> ]* };
-rule logor {:w <ternary> [ (\|\|) <ternary> ]* };
-
-rule ternary {:w <operand> | <operand> \? <any> : <operand> };
-
-rule operand { <number> | <function> | <command> | <quotes> | <braces> |
<variable> };
-
-rule expr { ^^ <factor> $$ };
-
+ <unary_functions> \( <expr> \) |
+ <binary_functions> \( <expr> , <expr> \)
+}
Modified: branches/leo-ctx5/languages/tcl/lib/tclword.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/lib/tclword.pir (original)
+++ branches/leo-ctx5/languages/tcl/lib/tclword.pir Tue Aug 2 02:26:10 2005
@@ -1,47 +1,18 @@
=head1 TclWord
-This object holds the result of parsing a tcl command. Internally,
-It represents a word as discrete chunks, which are either finalized
-or require interpolation. Each chunk is marked as such. When the
-word is I<used> (at interpretation or at execution time), the required
-interpolation occurs (either variable or command)
-
-=head1 Attributes
-
-Each TclWord has the following attributes:
-
-=head2 chunks
-
-an array of pairs of (type, content), where type/content is
-
-=over 4
-
-=item CONST
-
-a string
-
-=item VARIABLE
-
-an array suitable for passing to C<_Tcl::_get_var>
-
-=item COMMAND
-
-the result of a the parse step for a [] command, i.e.
-a TclList of TclWords.
-
-=back
-
-=head2 constant
-
-An Integer PMC flag representing whether or not the value we hold is
-constant. I<Used as a hint at compile time.>
-
=cut
.namespace [ "TclWord" ]
.HLL "Tcl", "tcl_group"
+# return codes
+ .const int TCL_OK = 0
+ .const int TCL_ERROR = 1
+ .const int TCL_RETURN = 2
+ .const int TCL_BREAK = 3
+ .const int TCL_CONTINUE = 4
+
=head1 Methods
TclWord defines the following methods:
@@ -53,506 +24,45 @@ Define the attributes required for the c
=cut
.sub __class_init @LOAD
- newclass $P1, "TclWord"
- addattribute $P1, "chunks"
- addattribute $P1, "constant"
+ $P0 = getclass "TclList"
+ $P1 = subclass $P0, "TclWord"
.end
-=head2 __init
+=head2 interpret
-Initialize the attributes for an instance of the class
+Return a PMC that contains the value of our word, concatenating
+the string values of the elements.
=cut
-.sub __init method
- .local pmc emptyArray
- .local pmc constant
-
- emptyArray = new TclList
-
- setattribute self, "TclWord\x00chunks", emptyArray
- constant = new Integer
- constant = 1
- setattribute self, "TclWord\x00constant", constant
-.end
-
-=head2 clone
-
-Clone a TclWord object.
-
-=cut
-
-.sub __clone method
- .local pmc chunks
- .local pmc constant
-
- chunks = getattribute self, "TclWord\x00chunks"
- constant = getattribute self, "TclWord\x00constant"
-
- chunks = clone chunks
- constant = clone constant
+.sub interpret method
+ .local pmc retval
+ .local int return_type
+ return_type = TCL_OK
- .local pmc value
- $I0 = typeof self
- value = new $I0
- setattribute value, "TclWord\x00chunks", chunks
- setattribute value, "TclWord\x00constant", constant
+ .local int i, len
+ i = 0
+ len = self
- .return(value)
-.end
-
-=head2 concat_words
-
-Given an array of words, append the chunks of a given word to the existing
word
-
-=cut
-
-.sub concat_words method
- .param pmc words
-
- .local pmc word
- .local pmc chunk
-
- .local pmc these_chunks,this_constant
- these_chunks = getattribute self, "TclWord\x00chunks"
- this_constant = getattribute self, "TclWord\x00constant"
-
- .local pmc those_chunks,that_constant
-
- .local int num_words
- .local int word_num
-
- .local int num_chunks
- .local int chunk_num
-
- num_words = words
- word_num = 0
-outer_loop:
- if word_num == num_words goto outer_loop_done
-
- word = words[word_num]
- those_chunks = getattribute word, "TclWord\x00chunks"
- that_constant = getattribute word, "TclWord\x00constant"
-
- num_chunks = those_chunks
- chunk_num = 0
-
- if that_constant goto inner_loop
- this_constant = 0
-
-inner_loop:
- if chunk_num == num_chunks goto inner_loop_done
-
- chunk = those_chunks[chunk_num]
- push these_chunks, chunk
- inc chunk_num
-
- goto inner_loop
-
-inner_loop_done:
- inc word_num
-
-outer_loop_done:
+ .local string word
+ word = ""
+loop:
+ if i == len goto loop_done
-
-.end
-
-=head2 concat_char
-
-Add a constant character to a TclWord
-
-=cut
-
-.sub concat_char method
- .param int arg
-
- .local pmc chunk
- .local pmc chunks
- .local string str
+ $P0 = self[i]
+ (return_type, retval) = $P0.interpret()
+ if return_type != TCL_OK goto done
+ $S0 = retval
+ word .= $S0
- str = chr arg
-
- chunk = new FixedPMCArray
- chunk = 2
- chunk[0] = 0
- chunk[1] = str
-
- chunks = getattribute self, "TclWord\x00chunks"
- push chunks, chunk
-.end
-
-=head2 concat_const
-
-Add a constant string to a TclWord
-
-=cut
-
-.sub concat_const method
- .param string arg
-
- .local pmc chunk
- .local pmc chunks
-
- if arg == "" goto end
- chunk = new FixedPMCArray
- chunk = 2
- chunk[0] = 0
- chunk[1] = arg
-
- chunks = getattribute self, "TclWord\x00chunks"
- push chunks, chunk
-end:
-.end
-
-
-=head2 concat_variable
-
-Add the name of a variable to be interpolated to a TclWord. Takes the name
-of the var, and an optional index for array variables.
-
-=cut
-
-.sub concat_variable method
- .param string var
- .param string idx
-
- .local pmc chunk
- .local pmc chunks
- .local pmc constant
-
- chunk = new ResizablePMCArray
- chunk[0] = 1
- chunk[1] = var
-
- # I2 == # string params.
- if I2 == 1 goto no_index
- chunk[2] = idx
-
-no_index:
- chunks = getattribute self, "TclWord\x00chunks"
- constant = getattribute self, "TclWord\x00constant"
- constant = 0
- push chunks, chunk
-.end
-
-=head2 concat_command
-
-Add a command to be interpolated to a TclWord. Takes the
-text of the command, and stores the parsed version for
-later interpretation.
-
-=cut
-
-.sub concat_command method
- .param string cmd
-
- .local pmc chunk,chunks,parsed_cmd,constant
-
- .local pmc parser
- parser = find_global "_Tcl", "parser"
- parsed_cmd = parser."parse"(cmd,0,0)
- register parsed_cmd
-
- chunk = new FixedPMCArray
- chunk = 2
- chunk[0] = 2
- chunk[1] = parsed_cmd
-
- chunks = getattribute self, "TclWord\x00chunks"
- constant = getattribute self, "TclWord\x00constant"
- constant = 0
- push chunks, chunk
-.end
-
-=head2 __get_pmc
-
-Return a PMC that contains the value of our word. If we're just a command,
-evaluate the command and return the resulting PMC. If we're just a variable,
-return the PMC associated with that variable. In any other case, concat
-the results and return a Stringy PMC.
-
-=cut
-
-.sub __get_pmc method
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
-
- .local int count
- count = chunks
-
- if count == 1 goto justpmc
- ($I0,$S0) = self.__get_string()
- $P0 = new String
- $P0 = $S0
- .return($I0,$P0)
-
-justpmc:
- .local pmc chunk
- chunk = chunks[0]
- .local int chunk_type
- chunk_type = chunk[0]
- .local pmc chunk_value
- chunk_value = chunk[1]
-
- if chunk_type == 0 goto constant
- if chunk_type == 1 goto variable
-
-command:
- .local pmc interpret
- interpret = find_global "_Tcl", "__interpret"
- ($I0,$P0) = interpret(chunk_value)
- .return($I0,$P0)
-
-constant:
- # 0 == TCL_OK
- .return(0,chunk_value)
-
-variable:
- .local pmc read
- read = find_global "_Tcl", "__read"
- .local pmc get_var
- get_var = find_global "_Tcl", "__get_var"
- .local int return_type
- $S1 = chunk_value
- $S2 = chunk[2]
- if $S2 == "" goto get_variable
- .return get_var($S1,$S2)
-get_variable:
- .return read($S1)
-.end
-
-=head2 __get_string
-
-Stringify - In our case, we take the individual chunks of the words and
-evaluate them - so if we have a TclWord that came from a string like:
-
- "$a + $b = [expr $a + $b]"
-
-We have split it up internally to look like:
-
- VAR: a
- CONST: " + "
- VAR: b
- CONST: " = "
- COMMAND:
- WORD:
- CONST: "expr"
- WORD:
- VAR: a
- WORD:
- CONST: "+"
- WORD:
- VAR: b
-
-And, when we ask for the string representation, the two variable interpolations
-are performed, and the command containing "expr" is also evaluated. The
-resulting string, (assuming values of 1 and 2 for a and b, respectively) is
-
- "1 + 2 = 3"
-
-NB: This isn't quite the normal C<__get_string> method, and should probably be
-renamed - it is returning a tcl exit code in addition to the normal string
-result.
-
-=cut
-
-.sub __get_string method
-
- .local int return_type
-
- return_type = 0
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
-
- .local pmc interpret
- .local pmc get_var
-
- interpret = find_global "_Tcl", "__interpret"
- get_var = find_global "_Tcl", "__get_var"
-
- .local string retval
- retval = ""
-
- $I1 = chunks
- $P11 = new Integer
- $P11 = 0 # XXX If we don't use a PMC, this value is discarded because of
- # a method call below.
-loop:
- $I0 = $P11
- if $I0 == $I1 goto loop_done
- $P0 = chunks[$I0]
- $I2 = $P0[0]
-
- if $I2 == 0 goto constant
- if $I2 == 1 goto variable
- if $I2 == 2 goto command
-
-command:
- $P1 = $P0[1]
- $S1 = typeof $P1
- ($I0, $P9) = interpret( $P1 )
- $S0 = $P9
- if $I0 == 0 goto loop_next
- # else, an exception value was returned. abort.
- return_type = $I0
- goto loop_done
-
-variable:
- $S1 = $P0[1]
- $S2 = $P0[2]
- if $S2 == "" goto get_variable
- ($I2,$P9) = get_var($S1,$S2)
- goto got_variable
-
-get_variable:
- ($I2,$P9) = get_var($S1)
- $S0 = $P9
-
-got_variable:
- if $I2 == 0 goto loop_next
- return_type = $I2
- retval = $S0
- goto loop_done
-
-constant:
- $S0 = $P0[1]
- # goto loop_next
-
-loop_next:
- retval .= $S0
- $P11 = $P11 + 1
- goto loop
-
-loop_done:
- .return(return_type,retval)
-.end
-
-=head2 __dump
-
-Allow us to be rendered by Data::Dumper
-
-Not tested, uses pmcPerlArray dumper method because of the way Dumper is
written.
-Shouldn't have to.
-
-=cut
-
-.sub __dump method
- .param pmc dumper
- .param string name
-
- .local string subindent
- .local string indent
- (subindent, indent) = dumper."newIndent"()
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
-
- .local int num_chunks
- num_chunks = chunks
- .local int chunk_num
- chunk_num = 0
-
- print "(size:"
- print num_chunks
- print ") {\n"
-
-loop:
- if chunk_num >= num_chunks goto loop_done
- if chunk_num == 0 goto skip
- print ",\n"
-skip:
-
- $P0 = chunks[chunk_num]
- $I0 = $P0[0]
-
- print subindent
-
- if $I0 == 2 goto command
- if $I0 == 1 goto var
-
- $S0 = $P0[1]
- print "\""
- print $S0
- print "\""
- goto loop_next
-
-command:
- $P1 = $P0[1]
- # XXX This will need to change.
- dumper.pmcPerlArray($P1)
- goto loop_next
-
-var:
- $S0 = $P0[1]
- $S1 = $P0[2]
- if $S1 != "" goto array_var
- print "[ set "
- print $S0
- print " ]"
- goto loop_next
-
-array_var:
- print "[ set "
- print $S0
- print " ("
- print $S1
- print ") ]"
-
-loop_next:
- inc chunk_num
+ inc i
goto loop
loop_done:
- print "\n"
-
- print indent
- print "}"
-
- dumper."deleteIndent"()
-.end
-
-=head2 __get_integer
-
-Return the number of chunks in this tclword.
-
-=cut
-
-.sub __get_integer method
-
- .local pmc chunks
- chunks = getattribute self, "TclWord\x00chunks"
- .local int size
- size = chunks
-
- .return(size)
-.end
-
-=head2 XXX __freeze
-
-Not implemented yet, pending delegation of C<freeze> to objects.
-(Necessary anymore?)
-
-=head2 XXX __thaw
-
-Not implemented yet, pending delegation of C<thaw> to objects.
-(Necessary anymore?)
-
-=cut
-
-=head2 __is_const
-
-Returns an integer, C<1> if this word is constant, C<0> if it requires
-interpolation.
-
-=cut
+ retval = new TclString
+ retval = word
-.sub __is_const method
- .local pmc constant
- constant = getattribute self, "TclWord\x00constant"
- .local int result
- result = constant
- .return(result)
+done:
+ .return(return_type, retval)
.end
Modified: branches/leo-ctx5/languages/tcl/t/tcl_command_subst.t
==============================================================================
--- branches/leo-ctx5/languages/tcl/t/tcl_command_subst.t (original)
+++ branches/leo-ctx5/languages/tcl/t/tcl_command_subst.t Tue Aug 2
02:26:10 2005
@@ -3,7 +3,6 @@
use strict;
use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
use Parrot::Test tests => 10;
-use vars qw($TODO);
language_output_is("tcl",<<'TCL', <<'OUT',"all");
set a 5
@@ -67,13 +66,9 @@ TCL
2
OUT
-TODO: {
-$TODO = "bugs";
-
language_output_is("tcl",<<'TCL',<<'OUT',"] in \"\"s");
puts [set a "]"]
TCL
]
OUT
-}
Modified: branches/leo-ctx5/languages/tcl/tcl.pir
==============================================================================
--- branches/leo-ctx5/languages/tcl/tcl.pir (original)
+++ branches/leo-ctx5/languages/tcl/tcl.pir Tue Aug 2 02:26:10 2005
@@ -36,8 +36,8 @@
STDIN = getstdin
STDOUT = getstdout
- .local pmc parser,interpret
- parser = find_global "_Tcl", "parser"
+ .local pmc parse,interpret
+ parse = find_global "_Tcl", "parse"
interpret = find_global "_Tcl", "__interpret"
input_loop:
@@ -45,7 +45,7 @@ input_loop:
STDOUT."flush"()
input_line = readline STDIN
unless STDIN goto done
- $P1 = parser."parse"(input_line,0,0)
+ $P1 = parse(input_line)
register $P1
(retcode,retval) = interpret($P1)
# print out the result of the evaluation.
Modified: branches/leo-ctx5/languages/tcl/tcl.pir_template
==============================================================================
--- branches/leo-ctx5/languages/tcl/tcl.pir_template (original)
+++ branches/leo-ctx5/languages/tcl/tcl.pir_template Tue Aug 2 02:26:10 2005
@@ -83,6 +83,9 @@ providing a compreg-compatible method.
.sub __prepare_lib @LOAD,@ANON
# Load any dependant libraries.
+ load_bytecode "languages/tcl/lib/tclcommand.pbc"
+ load_bytecode "languages/tcl/lib/tclconst.pbc"
+ load_bytecode "languages/tcl/lib/tclvar.pbc"
load_bytecode "languages/tcl/lib/tclword.pbc"
load_bytecode "library/Data/Escape.pbc"
load_bytecode "library/PGE.pbc"
@@ -157,12 +160,6 @@ providing a compreg-compatible method.
store_global "_Tcl", "functions", math_funcs
store_global "_Tcl", "precedence", precedence
- # Grab a (for now) global instance of TclParser
- .local pmc parser
- parser = new TclParser
-
- store_global "_Tcl", "parser", parser
-
# Eventually, we'll need to register MMD for the various Tcl PMCs
# (Presuming we don't do this from the .pmc definitions.)
@@ -242,8 +239,10 @@ providing a compreg-compatible method.
pir_code .= " @ANON\n.local string code\ncode = \""
tcl_code = escaper(tcl_code,"\"")
pir_code .= tcl_code
- pir_code .= "\"\n.local pmc parser\n.local pmc tcl_interpret\nparser = new
TclParser"
- pir_code .= "\ntcl_interpret = find_global \"_Tcl\", \"__interpret\"\n$P1 =
parser.\"parse\"(code,0,0)\n.return tcl_interpret($P1)\n.end\n"
+ pir_code .= "\"\n.local pmc tcl_interpret\n.local pmc parse\n"
+ pir_code .= "tcl_interpret = find_global \"_Tcl\", \"__interpret\"\n"
+ pir_code .= "parse = find_global \"_Tcl\", \"parse\"\n"
+ pir_code .= "$P1 = parse(code)\n.return tcl_interpret($P1)\n.end\n"
$P1 = compile pir_compiler, pir_code
.return ($P1)
Modified: branches/leo-ctx5/languages/tcl/tcl.pl
==============================================================================
--- branches/leo-ctx5/languages/tcl/tcl.pl (original)
+++ branches/leo-ctx5/languages/tcl/tcl.pl Tue Aug 2 02:26:10 2005
@@ -33,7 +33,7 @@ my @commands = grep {s/\.pir$//} @cmd_fi
my $lib_dir = "lib";
opendir(LIBDIR,$lib_dir) or die;
-my @libs = map {"$lib_dir/$_"} grep {m/\.pir$/} grep {!
m/^tcl(lib|word).pir$/} readdir(LIBDIR);
+my @libs = map {"$lib_dir/$_"} grep {m/\.pir$/} grep {!
m/^tcl(lib|command|const|var|word).pir$/} readdir(LIBDIR);
closedir(LIBDIR);
my $includes;
Modified: branches/leo-ctx5/runtime/parrot/library/dumper.imc
==============================================================================
--- branches/leo-ctx5/runtime/parrot/library/dumper.imc (original)
+++ branches/leo-ctx5/runtime/parrot/library/dumper.imc Tue Aug 2 02:26:10 2005
@@ -93,7 +93,8 @@ ex:
=item _register_dumper( id, sub )
-Registers a dumper for new PMC type.
+Registers a dumper for new PMC type. B<UNIMPLEMENTED>
+But see B<method __dunp> below.
=over 4
@@ -123,6 +124,11 @@ This function returns nothing.
$P2."registerDumper"(id, s)
.end
+=item __dump(pmc dumper, str label) method
+
+If a method C<__dump> exists in the namespace of the class, it will be
+called with the current dumper object and the label of the PMC.
+
=item dumper =_global_dumper() B<(internal)>
Internal helper function.
Modified: branches/leo-ctx5/t/library/dumper.t
==============================================================================
--- branches/leo-ctx5/t/library/dumper.t (original)
+++ branches/leo-ctx5/t/library/dumper.t Tue Aug 2 02:26:10 2005
@@ -18,7 +18,7 @@ Tests data dumping.
use strict;
-use Parrot::Test tests => 26;
+use Parrot::Test tests => 27;
# no. 1
pir_output_is(<<'CODE', <<'OUT', "dumping array of sorted numbers");
@@ -932,5 +932,45 @@ CODE
]
OUTPUT
+# no. 27
+pir_output_is(<<'CODE', <<'OUTPUT', "custom dumper");
+.sub main @MAIN
+ .local pmc o, s,ds, cl
+ cl = subclass 'ResizablePMCArray', 'bar'
+ .local int id
+ id = typeof cl
+ o = new id
+ _dumper(s)
+.end
+
+.namespace ["bar"]
+.sub __init method
+ .local pmc ar
+ ar = getattribute self, '__value'
+ push ar, 1
+ push ar, 2
+.end
+
+.sub __dump method
+ .param pmc dumper
+ .param string label
+ print " __value => { \n"
+ .local pmc ar
+ ar = getattribute self, '__value'
+ dumper.'dump'('attr', ar)
+ print "\n}"
+.end
+.namespace ['']
+.include 'library/dumper.imc'
+
+CODE
+"VAR1" => PMC 'bar' __value => {
+ResizablePMCArray (size:2) [
+ 1,
+ 2
+]
+}
+OUTPUT
+
# pir_output_is(<<'CODE', <<'OUTPUT', "dumping IntegerArray PMC");
# pir_output_is(<<'CODE', <<'OUTPUT', "dumping FloatValArray PMC");
