Skip to content

Commit

Permalink
Convert TclList's 'get_string' vtable from PIR to NQP
Browse files Browse the repository at this point in the history
  • Loading branch information
@coke
coke committed Apr 3, 2010
1 parent 163b622 commit 3749f5a
Show file tree
Hide file tree
Showing 2 changed files with 104 additions and 150 deletions.
105 changes: 104 additions & 1 deletion src/TclList.pm
View file
Expand Up @@ -9,6 +9,8 @@ INIT {

$core := pir::get_class__ps('ResizableStringArray'),
$interp.hll_map($core, $tcl);

$tcl.add_vtable_override('get_string', TclList::get_string)
}

module TclList {
Expand Down Expand Up @@ -52,6 +54,107 @@ module TclList {
}
return self;
}
}

method get_string() {
my @retval := ();

my $first := 1;
my $self := self;

for self -> $element {
my $elem_length := pir::length__is($element);
my $new_s := '';

if $elem_length == 0 {
$new_s := '{}';
} else {
my $count := 0;
my $pos := 0;
my $brace_check_pos := 0;
my $has_braces := 0;

my $escaped := 0;

while $pos < $elem_length && !$escaped {
my $char := pir::ord__isi($element, $pos);
if $char == 0x7b { # open brace
$count++;
$has_braces := 1;
} elsif $char == 0x7d { # close brace
$count--;
if $count < 0 {
$new_s := self.'escape_element'($element);
$escaped := 1;
} else {
$brace_check_pos := +$pos;
}
}
$pos++;
}

unless $escaped {
if $count {
$new_s := self.'escape_element'($element);
} else {

if $has_braces && $brace_check_pos != $elem_length -1 {
if $brace_check_pos != $elem_length -2 {
$new_s := '{' ~ $element ~ '}';
} elsif pir::ord__isi($element,$elem_length-1) != 0x5c {
# 0x5c == backslash
$new_s := '{' ~ $element ~ '}';
} else {
$new_s := self.'escape_element'($element);
}
} elsif $elem_length -1 == pir::index__issi($element,"\\", $elem_length-1) {
$new_s := self.'escape_element'($element);
} elsif pir::index__iss($element, '"') != -1 {
$new_s := '{' ~ $element ~ '}';
} elsif pir::index__iss($element, '[') != -1 {
$new_s := '{' ~ $element ~ '}';
} elsif $first && pir::index__iss($element, '#') != -1 {
$new_s := '{' ~ $element ~ '}';
} elsif pir::index__iss($element, '$') != -1 {
$new_s := '{' ~ $element ~ '}';
} elsif pir::index__iss($element, ';') != -1 {
$new_s := '{' ~ $element ~ '}';
} elsif pir::index__iss($element, ']') != -1 {
$new_s := self.'escape_element'($element);
} elsif pir::find_cclass__iisii(32, $element, 0, $elem_length) != $elem_length {
# .macro_const CCLASS_WHITESPACE 32
$new_s := '{' ~ $element ~ '}';
} else {
$new_s := $element
}
}
}
}

@retval.push($new_s);
$first := 0;
}

return pir::join__ssp(' ', @retval);
}

method escape_element($string) {
my $repl := ~$string;
$repl.replace("\\", "\\\\");
$repl.replace("\t", "\\t");
$repl.replace("\f", "\\f");
$repl.replace("\n", "\\n");
$repl.replace("\r", "\\r");
$repl.replace("\v", "\\v");
$repl.replace("\;", "\\;" );
$repl.replace('$', "\\\$" );
$repl.replace('{', "\\\x7b" );
$repl.replace('}', "\\\x7d" );
$repl.replace(' ', "\\ " );
$repl.replace('[', "\\[" );
$repl.replace(']', "\\]" );
$repl.replace('"', "\\\"");
return $repl;
}
}

# vim: filetype=perl6:
149 changes: 0 additions & 149 deletions src/class/tcllist.pir
View file
Expand Up @@ -4,8 +4,6 @@ A Tcl-style list

=cut

.include 'cclass.pasm'

.HLL 'tcl'
.namespace [ 'TclList' ]

Expand All @@ -14,150 +12,3 @@ A Tcl-style list
core = get_class 'ResizablePMCArray'
tcl = subclass core, 'TclList'
.end

=head2 get_string

Returns the list as a string

=cut

.sub get_string :vtable
.local pmc retval
retval = new 'ResizablePMCArray'

.local int elems
elems = self

.local pmc iterator
iterator = iter self

.local string elem_s
.local int elem_len
.local string new_s

.local int first_elem
first_elem = 1
loop:
unless iterator goto done
elem_s = shift iterator
elem_len = length elem_s

if elem_len != 0 goto has_length
new_s = '{}'
goto append_elem

has_length:
.local int count, pos, brace_check_pos, has_braces
count = 0
pos = 0
brace_check_pos = 0
has_braces = 0

.local int char
elem_loop:
if pos >= elem_len goto elem_loop_done
char = ord elem_s, pos
if char == 0x7b goto open_count
if char == 0x7d goto close_count
goto elem_loop_next
open_count:
inc count
has_braces = 1
goto elem_loop_next
close_count:
dec count
if count < 0 goto escape
brace_check_pos = pos
elem_loop_next:
inc pos
goto elem_loop
elem_loop_done:

if count goto escape
unless has_braces goto done_brace_check
if count goto done_brace_check
$I0 = elem_len - 1
if brace_check_pos == $I0 goto done_brace_check

# escape {ab}\, but brace-wrap anything else.
$I0 = elem_len - 2
if brace_check_pos != $I0 goto quote
$I0 = elem_len - 1
char = ord elem_s, $I0
if char != 0x5c goto quote

goto escape

done_brace_check:
# trailing slash
$I0 = elem_len - 1
$I1 = index elem_s, "\\", $I0
if $I0 == $I1 goto escape

$I0 = index elem_s, "\""
if $I0 != -1 goto quote

$I0 = index elem_s, '['
if $I0 != -1 goto quote

# only check hashes on first elem.
unless first_elem goto done_hash
$I0 = index elem_s, '#'
if $I0 != -1 goto quote

done_hash:
$I0 = index elem_s, '$'
if $I0 != -1 goto quote

$I0 = index elem_s, ';'
if $I0 != -1 goto quote

# \'d constructs
$I0 = index elem_s, ']'
if $I0 != -1 goto escape

$I0 = index elem_s, "\\"
if $I0 != -1 goto escape

# {}'d constructs
$I0 = find_cclass .CCLASS_WHITESPACE, elem_s, 0, elem_len
if elem_len != $I0 goto quote

new_s = elem_s
goto append_elem

escape:
.local pmc string_t
string_t = new 'String'
string_t = elem_s
string_t.'replace'("\\", "\\\\")
string_t.'replace'("\t", "\\t")
string_t.'replace'("\f", "\\f")
string_t.'replace'("\n", "\\n")
string_t.'replace'("\r", "\\r")
string_t.'replace'("\v", "\\v")
string_t.'replace'("\;", "\\;" )
string_t.'replace'("$", "\\$" )
string_t.'replace'("}", "\\}" )
string_t.'replace'("{", "\\{" )
string_t.'replace'(" ", "\\ " )
string_t.'replace'("[", "\\[" )
string_t.'replace'("]", "\\]" )
string_t.'replace'("\"", "\\\"")
new_s = string_t
goto append_elem

quote:
new_s = '{' . elem_s
new_s = new_s . '}'

append_elem:
push retval, new_s
first_elem = 0
goto loop

done:
.local string retval_s
retval_s = join " ", retval
.return(retval_s)
.end

0 comments on commit 3749f5a

Please sign in to comment.