Add NQP overrides to TclList; getIndex(), similar to TclString's

partcl · Dec 19, 2009 · d6688f6 · d6688f6
1 parent f465131
commit d6688f6
Show file tree

Hide file tree

Showing 4 changed files with 42 additions and 26 deletions.
diff --git a/build/Makefile.in b/build/Makefile.in
@@ -30,8 +30,9 @@ GEN_SOURCES = \
   src/Partcl/commands/package.pir \
   src/Partcl/commands/string.pir \
   src/Partcl/commands/trace.pir \
-  src/TclString.pir \
   src/TclLexPad.pir \
+  src/TclList.pir \
+  src/TclString.pir \
   src/init.pir \
   src/options.pir
 

diff --git a/src/Partcl.pir b/src/Partcl.pir
@@ -29,6 +29,7 @@
 .include 'src/Partcl/commands/string.pir'
 .include 'src/Partcl/commands/trace.pir'
 .include 'src/TclLexPad.pir'
+.include 'src/TclList.pir'
 .include 'src/TclString.pir'
 .include 'src/ARE/Grammar.pir'
 .include 'src/ARE/Actions.pir'

diff --git a/src/TclList.pm b/src/TclList.pm
@@ -0,0 +1,38 @@
+# This class is currently created via PIR in src/class/tcllist.pir
+
+INIT {
+    my $interp := pir::getinterp__p();
+    my $tcl  := pir::get_class__ps('TclList'),
+
+    my $core := pir::get_class__ps('ResizablePMCArray'),
+    $interp.hll_map($core, $tcl);
+
+    $core := pir::get_class__ps('Array'),
+    $interp.hll_map($core, $tcl);
+
+    $core := pir::get_class__ps('ResizableStringArray'),
+    $interp.hll_map($core, $tcl);
+}
+
+module TclList {
+    method getIndex($index) {
+        my $parse := Partcl::Grammar.parse(
+            $index, :rule('index'),
+            :actions(Partcl::Actions)
+        );
+
+        if ?$parse && $parse.chars() == pir::length__is($index) { 
+            my @pos := $parse.ast(); 
+            my $len := +self;
+            my $loc := @pos[1];
+            if @pos[0] == 2 { # position relative from end.
+                $loc := $len - 1 + $loc;
+            }
+            return $loc;
+        } else {
+            error("bad index \"$index\": must be integer?[+-]integer? or end?[+-]integer?");
+        }
+    }
+} 
+
+# vim: filetype=perl6:
diff --git a/src/class/tcllist.pir b/src/class/tcllist.pir
@@ -6,7 +6,7 @@ A Tcl-style list
 
 .include 'cclass.pasm'
 
-.HLL 'parrot'
+.HLL 'tcl'
 .namespace [ 'TclList' ]
 
 .sub class_init :anon :init
@@ -15,30 +15,6 @@ A Tcl-style list
   tcl = subclass core, 'TclList'
 .end
 
-.HLL 'tcl'
-.namespace []
-
-.sub 'mapping' :anon :init
-  .local pmc tcl
-  tcl  = get_class 'TclList'
-  .local pmc interp
-  interp = getinterp
-
-  .local pmc core
-  core = get_class 'ResizablePMCArray'
-  interp.'hll_map'(core,tcl)
-
-  core = get_class 'Array'
-  interp.'hll_map'(core,tcl)
-
-  core = get_class 'ResizableStringArray'
-  interp.'hll_map'(core,tcl)
-
-.end
-
-.HLL 'parrot'
-.namespace [ 'TclList' ]
-
 =head2 get_string
 
 Returns the list as a string