Fix LTM automaton generation for user-defined operators

sorear · Aug 3, 2011 · 7888fe2 · 7888fe2
1 parent 17807f3
commit 7888fe2
Showing 1 changed file with 23 additions and 21 deletions.
diff --git a/src/NieczaFrontendSTD.pm6 b/src/NieczaFrontendSTD.pm6
@@ -65,10 +65,25 @@ method default_O($cat, $sym) {
     }
 }
 
-role sym_categorical[$name,$cat,$sym] { #OK not used
+# MOP will be used to install $*rx into appropriate method field
+role sym_categorical[$name,$cat,$sym] {
+    $*name = $name;
+    $*rxm = anon token sym_categorical () {
+        $sym $<sym>={$sym} $<name>={$name}
+        $<O>={ self.cat_O($cat, $sym) }
+    }
 }
 
-role bracket_categorical[$name,$cat,$sym1,$sym2] { #OK not used
+role bracket_categorical[$name,$cat,$sym1,$sym2] {
+    $*name = $name;
+    $*rxm = anon token bracket_categorical () {
+        :my $*GOAL = $sym2;
+        $sym1 {}:s
+        $<name>={$name}
+        [ :lang($¢.unbalanced($sym2)) <semilist> ]
+        [ $sym2 || <.FAILGOAL($sym2, $name, self.pos)> ]
+        $<O>={ self.cat_O($cat, "$sym1 $sym2") } $<sym>={ [$sym1,$sym2] }
+    }
 }
 
 method add_categorical($name) {
@@ -81,32 +96,19 @@ method add_categorical($name) {
     return self unless ($name ~~ /^(\w+)\: \< (.*) \> /);
     my $cat = ~$0;
     my $sym = ~$1;
-    my $role;
+    my ($role, $*rxm, $*name);
 
     if $sym ~~ /\s+/ {
         my $sym1 = $sym.substr(0, $/.from);
         my $sym2 = $sym.substr($/.to, $sym.chars - $/.to);
-        $role = OUR::bracket_categorical[
-            "{$cat}:sym<$sym1 $sym2>", $cat, $sym1, $sym2];
-        my token bracket_categorical () {
-            :my $*GOAL = $sym2;
-            $sym1 {}:s
-            $<name>={$name}
-            [ :lang($¢.unbalanced($sym2)) <semilist> ]
-            [ $sym2 || <.FAILGOAL($sym2, $name, self.pos)> ]
-            $<O>={ self.cat_O($cat, "$sym1 $sym2") } $<sym>={ [$sym1,$sym2] }
-        }
-        Q:CgOp { (rnull (_addmethod (obj_llhow (@ {$role})) 8
-            (obj_getstr {"{$cat}:sym<$sym1 $sym2>"}) (@ {&bracket_categorical}))) };
+        $role = OUR::bracket_categorical["{$cat}:sym<$sym1 $sym2>",
+            $cat, $sym1, $sym2];
     } else {
         $role = OUR::sym_categorical["{$cat}:sym<$sym>", $cat, $sym];
-        my token sym_categorical () {
-            $sym $<sym>={$sym} $<name>={$name}
-            $<O>={ self.cat_O($cat, $sym) }
-        }
-        Q:CgOp { (rnull (_addmethod (obj_llhow (@ {$role})) 8
-            (obj_getstr {"{$cat}:sym<$sym>"}) (@ {&sym_categorical}))) };
     }
+
+    Q:CgOp { (rnull (_addmethod (obj_llhow (@ {$role})) 8
+        (obj_getstr {$*name}) (@ {$*rxm}))) };
     Q:CgOp { (rnull (_invalidate (obj_llhow (@ {$role})))) };
     %*LANG<MAIN> = self.WHAT but $role;
     self.cursor_fresh(%*LANG<MAIN>);