Start work on associative arrays:

* Get [set a(b) 2] to set an array value * Get [array exists a] to return whether the variable a exists and is an array
partcl · Jun 21, 2010 · 28793c8 · 28793c8
1 parent c38a414
commit 28793c8
Show file tree

Hide file tree

Showing 4 changed files with 40 additions and 13 deletions.
diff --git a/src/Partcl/commands/array.pm b/src/Partcl/commands/array.pm
@@ -48,7 +48,7 @@ INIT {
 our sub dispatch_command(*@args) {
     my $num_args := +@args -2 ; # need option & arrayName
 
-    if $num_args <= 0  {
+    if $num_args < 0  {
         error('wrong # args: should be "array option arrayName ?arg ...?"');
     }
 
@@ -67,7 +67,7 @@ our sub dispatch_command(*@args) {
     my $array     := ();  # FIXME - get the actual array obj here.
 
     my &subcommand := %Array_funcs{$cmd};
-    &subcommand($array, |@args);
+    &subcommand($arrayName, |@args);
 }
 
 
@@ -79,8 +79,15 @@ my sub donesearch() {
     'XXX';
 }
 
-my sub exists() {
-    'XXX';
+my sub exists($arrayName, *@args) {
+    my $variable := Q:PIR {
+        .local pmc varname, lexpad
+        varname = find_lex '$arrayName'
+        lexpad = find_dynamic_lex '%LEXPAD'
+        %r = lexpad[varname]
+    };
+    
+    return pir::defined($variable) && pir::isa($variable, 'TclArray');
 }
 
 my sub get() {

diff --git a/src/Partcl/commands/main.pm b/src/Partcl/commands/main.pm
@@ -431,11 +431,30 @@ our sub set(*@args) {
         error('wrong # args: should be "set varName ?newValue?"');
     }
     my $varname := @args[0];
+    my $value   := @args[1];
 
     # Does it look like foo(bar) ?
     if pir::ord__isi($varname, -1) == 41 && pir::index__iss($varname, '(' ) != -1 {
-        # XXX array 
-        return 'XXX';   
+        # find the variable name and key name
+        my $left_paren  := pir::index__iss($varname, '(');
+        my $right_paren := pir::index__iss($varname, ')');
+        my $keyname   := pir::substr__ssii($varname, $left_paren+1, $right_paren-$left_paren-1);
+        my $arrayname := pir::substr__ssii($varname, 0, $left_paren);
+
+        my $var := Q:PIR {
+            .local pmc varname, lexpad
+            varname = find_lex '$arrayname'
+            lexpad = find_dynamic_lex '%LEXPAD'
+            %r = vivify lexpad, varname, ['TclArray']
+        };
+        
+        if !pir::isa($var, 'TclArray') {
+            error("can't set \"$varname\": variable isn't array");
+        }
+        if pir::defined($value) {
+            $var{$keyname} := $value;
+        }
+        return '';
     } else {
         # scalar
 
@@ -445,8 +464,9 @@ our sub set(*@args) {
             lexpad = find_dynamic_lex '%LEXPAD'
             %r = vivify lexpad, varname, ['Undef']
         };
-        my $value := @args[1];
-        if pir::defined($value) {
+        if pir::isa($var, 'TclArray') {
+            error("can't set \"$varname\": variable is array");
+        } elsif pir::defined($value) {
             pir::copy__0PP($var, $value)
         } elsif ! pir::defined($var) {
             error("can't read \"$varname\": no such variable");

diff --git a/t/cmd_array.t b/t/cmd_array.t
@@ -13,19 +13,19 @@ eval_is {array exists}\
 
 eval_is {array bork foo}\
   {bad option "bork": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}\
-  {array, bad subcommand, bad array} {TODO NQPRX}
+  {array, bad subcommand, bad array}
 
 eval_is {
  set b(c) 2
  array exists b
-} 1 {array exists yes} {TODO NQPRX}
+} 1 {array exists yes}
 
 eval_is {
  set a 2
  array exists a
-} 0 {array exists no} {TODO NQPRX}
+} 0 {array exists no}
 
-eval_is {array exists q} 0 {array exists missing} {TODO NQPRX}
+eval_is {array exists q} 0 {array exists missing}
 
 eval_is {array exists a b}\
   {wrong # args: should be "array exists arrayName"}\

diff --git a/t/cmd_set.t b/t/cmd_set.t
@@ -23,7 +23,7 @@ eval_is {
  set b 1
  set b(c) 2
 } {can't set "b(c)": variable isn't array} \
-  {not an array} {TODO NQPRX}
+  {not an array}
 
 eval_is {
   array set a {}