break out [string] in anticipation of implementing the rest of the en…

…semble command.
partcl · Nov 30, 2009 · 79d9ee8 · 79d9ee8
1 parent 816ba49
commit 79d9ee8
Show file tree

Hide file tree

Showing 4 changed files with 45 additions and 41 deletions.
diff --git a/build/Makefile.in b/build/Makefile.in
@@ -42,6 +42,7 @@ PMTCL_G_PIR   = src/gen/pmtcl-grammar.pir
 PMTCL_A_PIR   = src/gen/pmtcl-actions.pir
 PMTCL_C_PIR   = src/gen/pmtcl-compiler.pir
 PMTCL_B_PIR   = src/gen/pmtcl-commands-main.pir
+PMTCL_B_S_PIR = src/gen/pmtcl-commands-string.pir
 TCLLEXPAD_PIR = src/gen/tcllexpad.pir
 ARE_G_PIR     = src/gen/are-grammar.pir
 ARE_A_PIR     = src/gen/are-actions.pir
@@ -53,6 +54,7 @@ PMTCL_SOURCES = \
     $(PMTCL_A_PIR) \
     $(PMTCL_C_PIR) \
     $(PMTCL_B_PIR) \
+    $(PMTCL_B_S_PIR) \
     $(TCLLEXPAD_PIR) \
     $(ARE_G_PIR) \
     $(ARE_A_PIR) \
@@ -81,6 +83,8 @@ $(PMTCL_C_PIR): src/PmTcl/Compiler.pm
 	$(PARROT_NQP) --target=pir -o $(PMTCL_C_PIR) src/PmTcl/Compiler.pm
 $(PMTCL_B_PIR): src/PmTcl/commands/main.pm
 	$(PARROT_NQP) --target=pir -o $(PMTCL_B_PIR) src/PmTcl/commands/main.pm
+$(PMTCL_B_S_PIR): src/PmTcl/commands/string.pm
+	$(PARROT_NQP) --target=pir -o $(PMTCL_B_S_PIR) src/PmTcl/commands/string.pm
 $(TCLLEXPAD_PIR): src/TclLexPad.pm
 	$(PARROT_NQP) --target=pir -o $(TCLLEXPAD_PIR) src/TclLexPad.pm
 $(ARE_G_PIR): src/ARE/Grammar.pm

diff --git a/src/PmTcl.pir b/src/PmTcl.pir
@@ -19,6 +19,7 @@
 .include 'src/gen/pmtcl-actions.pir'
 .include 'src/gen/pmtcl-compiler.pir'
 .include 'src/gen/pmtcl-commands-main.pir'
+.include 'src/gen/pmtcl-commands-string.pir'
 .include 'src/gen/tcllexpad.pir'
 .include 'src/gen/are-grammar.pir'
 .include 'src/gen/are-actions.pir'

diff --git a/src/PmTcl/commands/main.pm b/src/PmTcl/commands/main.pm
@@ -364,23 +364,6 @@ our sub split(*@args) {
     return @result;
 }
 
-our sub string($cmd, *@args) {
-    if $cmd eq 'toupper' {
-        return pir::upcase(@args[0]); 
-    } elsif $cmd eq 'compare' {
-        @args.shift; # assuming -nocase here.
-        my $s1 := pir::upcase(@args[0]);
-        my $s2 := pir::upcase(@args[1]);
-        if ($s1 eq $s2) {
-            return 0;
-        } elsif ($s1 lt $s2) {
-            return -1;
-        } else {
-            return 1;
-        } 
-    }
-}
-
 our sub switch ($string, *@args) {
     unless @args {
         pir::printerr("wrong # args: should be ``switch ?switches? string pattern body ... ?default body?''");
@@ -481,27 +464,3 @@ our sub while (*@args) {
 our sub EXPAND($args) {
     PmTcl::Grammar.parse($args, :rule<list>, :actions(PmTcl::Actions) ).ast;
 }
-
-module _tcl {
-    our sub string_trim($string) {
-        Q:PIR {
-            .include 'cclass.pasm'
-            .local string str
-            $P0 = find_lex '$string'
-            str = $P0
-            .local int lpos, rpos
-            rpos = length str
-            lpos = find_not_cclass .CCLASS_WHITESPACE, str, 0, rpos
-          rtrim_loop:
-            unless rpos > lpos goto rtrim_done
-            dec rpos
-            $I0 = is_cclass .CCLASS_WHITESPACE, str, rpos
-            if $I0 goto rtrim_loop
-          rtrim_done:
-            inc rpos
-            $I0 = rpos - lpos
-            $S0 = substr str, lpos, $I0
-            %r = box $S0
-        };
-    }
-}
diff --git a/src/PmTcl/commands/string.pm b/src/PmTcl/commands/string.pm
@@ -0,0 +1,40 @@
+our sub string($cmd, *@args) {
+    if $cmd eq 'toupper' {
+        return pir::upcase(@args[0]); 
+    } elsif $cmd eq 'compare' {
+        @args.shift; # assuming -nocase here.
+        my $s1 := pir::upcase(@args[0]);
+        my $s2 := pir::upcase(@args[1]);
+        if ($s1 eq $s2) {
+            return 0;
+        } elsif ($s1 lt $s2) {
+            return -1;
+        } else {
+            return 1;
+        } 
+    }
+}
+
+module _tcl {
+    our sub string_trim($string) {
+        Q:PIR {
+            .include 'cclass.pasm'
+            .local string str
+            $P0 = find_lex '$string'
+            str = $P0
+            .local int lpos, rpos
+            rpos = length str
+            lpos = find_not_cclass .CCLASS_WHITESPACE, str, 0, rpos
+          rtrim_loop:
+            unless rpos > lpos goto rtrim_done
+            dec rpos
+            $I0 = is_cclass .CCLASS_WHITESPACE, str, rpos
+            if $I0 goto rtrim_loop
+          rtrim_done:
+            inc rpos
+            $I0 = rpos - lpos
+            $S0 = substr str, lpos, $I0
+            %r = box $S0
+        };
+    }
+}