Author: azuroth
Date: Sat Oct 29 01:41:02 2005
New Revision: 9622
Added:
trunk/languages/tcl/lib/commands/lsort.pir
trunk/languages/tcl/t/cmd_lsort.t (contents, props changed)
Modified:
trunk/languages/tcl/t/cmd_for.t
Log:
Implemented some of tcl's lsort
Added: trunk/languages/tcl/lib/commands/lsort.pir
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/lib/commands/lsort.pir Sat Oct 29 01:41:02 2005
@@ -0,0 +1,195 @@
+#
+# [lsort]
+#
+
+.namespace [ "Tcl" ]
+
+.sub "&lsort"
+ .param pmc argv :slurpy
+
+ .local int return_type, argc
+ .local pmc retval
+ .local pmc compare
+ .local pmc sort
+
+ argc = argv
+ if argc == 0 goto wrong_args
+
+ compare = find_global "_Tcl\0builtins\0lsort", "ascii"
+ sort = find_global "_Tcl\0builtins\0lsort", "sort"
+
+ # possible options
+ .local int decr, unique
+chew_flag:
+ $P0 = shift argv
+ unless argv goto got_list
+
+ if $P0 == "-decreasing" goto c_decr
+ if $P0 == "-increasing" goto c_incr
+ if $P0 == "-unique" goto c_uniq
+ if $P0 == "-integer" goto c_int
+ # XXX dictionary, real, command etc necessary
+ branch bad_opt
+
+c_decr:
+ decr = 1
+ branch chew_flag
+c_incr:
+ decr = 0
+ branch chew_flag
+c_uniq:
+ unique = 1
+ branch chew_flag
+c_int:
+ compare = find_global "_Tcl\0builtins\0lsort", "integer"
+ branch chew_flag
+
+
+got_list:
+
+ unless decr goto skip_decr
+ $P0 = find_global "_Tcl\0builtins\0lsort", "reverse"
+ compare = $P0(compare)
+skip_decr:
+
+ .local pmc __list
+ __list = find_global "_Tcl", "__list"
+ $P0 = __list($P0)
+
+ sort(compare, $P0)
+
+ unless unique goto skip_unique
+ .local int c, size
+ size = $P0
+
+ if size == 0 goto strip_end
+ $P1 = $P0[0]
+strip_loop:
+ inc c
+ if c == size goto strip_end
+ $P2 = $P1
+ $P1 = $P0[c]
+
+ if $P1 != $P2 goto strip_loop
+ delete $P0[c]
+ dec c
+ dec size
+ branch strip_loop
+strip_end:
+
+skip_unique:
+ .return ($P0)
+
+bad_opt:
+ $S0 = "bad option \""
+ $S1 = $P0
+ $S0 .= $S1
+ $S0 .= "\": must be -ascii, -command, -decreasing, -dictionary, -increasing,
-index, -integer, -real, or -unique"
+ .throw ($S0)
+wrong_args:
+ .throw ("wrong # args: should be \"lsort ?options? list\"")
+.end
+
+.namespace [ "_Tcl\0builtins\0lsort" ]
+
+.sub "sort"
+ .param pmc compare
+ .param pmc list
+
+ .local int size
+ size = list
+ size -= 1
+
+ quicksort(compare, list, 0, size)
+.end
+
+.sub "quicksort"
+ .param pmc compare
+ .param pmc list
+ .param int lo
+ .param int hi
+
+ if lo >= hi goto done
+
+ .local pmc pivot
+ pivot = list[hi]
+
+ .local int l,h
+ l = lo
+ h = hi
+
+move_loop:
+ inc_loop:
+ unless l < h goto inc_end
+ $P0 = list[l]
+ $I0 = compare($P0, pivot)
+ unless $I0 <= 0 goto inc_end
+ l += 1
+ branch inc_loop
+ inc_end:
+ dec_loop:
+ unless h > l goto dec_end
+ $P0 = list[h]
+ $I0 = compare($P0, pivot)
+ unless $I0 >= 0 goto dec_end
+ h -= 1
+ branch dec_loop
+ dec_end:
+
+ unless l < h goto move_end
+ $P0 = list[l]
+ $P1 = list[h]
+ list[l] = $P1
+ list[h] = $P0
+
+ branch move_loop
+move_end:
+
+ $P0 = list[l]
+ $P1 = list[hi]
+ list[l] = $P1
+ list[hi] = $P0
+
+ $I0 = l - 1
+ $I1 = l + 1
+ quicksort(compare, list, lo, $I0)
+ quicksort(compare, list, $I1, hi)
+
+done:
+ .return ()
+.end
+
+.sub "ascii"
+ .param pmc s1
+ .param pmc s2
+ $I0 = cmp_str s1, s2
+ .return ($I0)
+.end
+
+.sub "integer"
+ .param pmc s1
+ .param pmc s2
+# XXX check that they're actually integers
+ $I0 = cmp_num s1, s2
+ .return ($I0)
+.end
+
+.sub "reverse"
+ .param pmc compare
+ .local string code
+
+ print "-decreasing not implemented!"
+
+ code = <<"END_PIR"
+
+.sub "reversed" :anon
+ .param string s1
+ .param string s2
+ .return (0)
+.endsub
+
+END_PIR
+
+ $P0 = compreg "PIR"
+ .return $P0(code)
+.end
Modified: trunk/languages/tcl/t/cmd_for.t
==============================================================================
--- trunk/languages/tcl/t/cmd_for.t (original)
+++ trunk/languages/tcl/t/cmd_for.t Sat Oct 29 01:41:02 2005
@@ -16,3 +16,4 @@ TCL
3
4
OUT
+
Added: trunk/languages/tcl/t/cmd_lsort.t
==============================================================================
--- (empty file)
+++ trunk/languages/tcl/t/cmd_lsort.t Sat Oct 29 01:41:02 2005
@@ -0,0 +1,142 @@
+#!/usr/bin/perl
+
+use strict;
+use lib qw(tcl/t t . ../lib ../../lib ../../../lib);
+use Parrot::Test tests => 20;
+use Test::More;
+use vars qw($TODO);
+
+language_output_is("tcl",<<'TCL',<<OUT,"empty list");
+ puts [lsort {}]
+TCL
+
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"no args");
+ lsort
+TCL
+wrong # args: should be "lsort ?options? list"
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"bad option");
+ lsort blah {}
+TCL
+bad option "blah": must be -ascii, -command, -decreasing, -dictionary,
-increasing, -index, -integer, -real, or -unique
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"one elem");
+ puts [lsort {SortMe}]
+TCL
+SortMe
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"implicit ASCII");
+ set a {a10 B2 b1 a1 a2}
+ puts [lsort $a]
+TCL
+B2 a1 a10 a2 b1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"ASCII all same");
+ puts [lsort {z z z}]
+TCL
+z z z
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"few same");
+ puts [lsort {a z z t a monkey}]
+TCL
+a a monkey t z z
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"list of lists");
+ puts [lsort {{a b c} {} {a c d} {z z t}}]
+TCL
+{} {a b c} {a c d} {z z t}
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"list of lists mixed");
+ puts [lsort {{3 2} {3 4} {} no way}]
+TCL
+{} {3 2} {3 4} no way
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"list of lists mixed var subst");
+ set a {{3 2} {3 4} {} no way}
+ puts [lsort $a]
+TCL
+{} {3 2} {3 4} no way
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"explicit increasing");
+ set a {a10 B2 b1 a1 a2}
+ puts [lsort -increasing $a]
+TCL
+B2 a1 a10 a2 b1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"unique");
+ set a {a10 B2 a2 B2 b1 a1 a2 z z t}
+ puts [lsort -unique $a]
+TCL
+B2 a1 a10 a2 b1 t z
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"unique empty");
+ set a {}
+ puts [lsort -unique $a]
+TCL
+
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"unique one elem");
+ set a {A}
+ puts [lsort -unique $a]
+TCL
+A
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"integer");
+ set a {10 2 30 5 0 -5 2}
+ puts [lsort -integer $a]
+TCL
+-5 0 2 2 5 10 30
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"integer unique");
+ set a {10 2 30 5 0 -5 2 -5}
+ puts [lsort -unique -integer $a]
+TCL
+-5 0 2 5 10 30
+OUT
+
+TODO: {
+ local $TODO = "no excuses!";
+
+language_output_is("tcl",<<'TCL',<<OUT,"integer die");
+ set a {10 10.2}
+ puts [lsort -integer $a]
+TCL
+expected integer but got "10.2"
+OUT
+
+language_output_is("tcl",<<'TCL',<<'OUT',"decreasing");
+ puts [lsort -decreasing {1 3 2 5 9 4 8 7 6}]
+TCL
+9 8 7 6 5 4 3 2 1
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"decreasing integer unique");
+ set a {10 2 30 5 0 -5 2}
+ puts [lsort -decreasing -integer -unique $a]
+TCL
+30 10 5 2 0 -5
+OUT
+
+language_output_is("tcl",<<'TCL',<<OUT,"dictionary");
+ set a {a10 B2 b1 a1 a2}
+ puts [lsort -dictionary $a]
+TCL
+a1 a2 a10 b1 B2
+OUT
+}
