[svn:parrot] r29810 - in trunk/languages/tcl: runtime/builtin t

[coke@xxxxxxxxxxxx]

Author: coke
Date: Sun Jul 27 17:11:43 2008
New Revision: 29810

Modified:
   trunk/languages/tcl/runtime/builtin/lsort.pir
   trunk/languages/tcl/t/cmd_lsort.t

Log:
[tcl] http://code.google.com/p/partcl/issues/detail?id=29  --  first pass at 
[lsort -command], with a test.



Modified: trunk/languages/tcl/runtime/builtin/lsort.pir
==============================================================================
--- trunk/languages/tcl/runtime/builtin/lsort.pir       (original)
+++ trunk/languages/tcl/runtime/builtin/lsort.pir       Sun Jul 27 17:11:43 2008
@@ -33,7 +33,7 @@
   if $P0 == '-integer' goto c_int
   if $P0 == '-real' goto c_real
   if $P0 == '-dictionary' goto c_dict
-  # RT#40749: command etc necessary
+  if $P0 == '-command' goto c_command
   branch bad_opt
 
 c_dict:
@@ -54,7 +54,12 @@
 c_int:
   compare = get_root_global ['_tcl';'helpers';'lsort'], 'integer'
   branch chew_flag
-
+c_command:
+  .local string compareName
+  compareName = shift argv
+  $S0 = '&' . compareName
+  compare = find_global $S0
+  branch chew_flag
 
 got_list:
 

Modified: trunk/languages/tcl/t/cmd_lsort.t
==============================================================================
--- trunk/languages/tcl/t/cmd_lsort.t   (original)
+++ trunk/languages/tcl/t/cmd_lsort.t   Sun Jul 27 17:11:43 2008
@@ -10,7 +10,7 @@
 __DATA__
 
 source lib/test_more.tcl
-plan 21
+plan 22
 
 is [lsort {}] {} {empty list}
 
@@ -79,3 +79,19 @@
 eval_is {
   lsort -real {4.28 5.65 6.20 7.66 7.6 2.4 8.5 0.4 7.6 6.3}
 } {0.4 2.4 4.28 5.65 6.20 6.3 7.6 7.6 7.66 8.5} {-real}
+
+proc sortByLen {a b} {
+  set sizeA [string length $a]
+  set sizeB [string length $b]
+  if {$sizeA < $sizeB} {
+    return -1
+  } elseif {$sizeB < $sizeA} {
+    return 1
+  } else {
+    return 0
+  }
+}
+
+eval_is {
+  lsort -command sortByLen [list 12345 {} 1234 1 12345678 123456 1234567]
+} {{} 1 1234 12345 123456 1234567 12345678} {-command option}