Add some primitive regex debugging capabilities.

perl6 · Oct 21, 2009 · 9104507 · 9104507
1 parent 31f8ae7
commit 9104507
Show file tree

Hide file tree

Showing 4 changed files with 55 additions and 3 deletions.
diff --git a/src/PAST/Compiler-Regex.pir b/src/PAST/Compiler-Regex.pir
@@ -39,11 +39,12 @@ Return the POST representation of the regex AST rooted by C<node>.
     reghash = new ['Hash']
     .lex '$*REG', reghash
 
-    .local pmc regexname
+    .local pmc regexname, regexname_esc
     $P0 = get_global '@?BLOCK'
     $P1 = $P0[0]
     $S0 = $P1.'name'()
     regexname = box $S0
+    regexname_esc = self.'escape'($S0)
     .lex '$*REGEXNAME', regexname
 
     .local string prefix, rname, rtype
@@ -101,6 +102,7 @@ Return the POST representation of the regex AST rooted by C<node>.
     concat $S0, tgt
     concat $S0, ', $I10)'
     ops.'push_pirop'('callmethod', '"!cursor_start"', 'self', 'result'=>$S0)
+    self.'!cursorop'(ops, '!cursor_debug', 0, '"START "', regexname_esc) 
     unless caparray goto caparray_skip
     self.'!cursorop'(ops, '!cursor_caparray', 0, caparray :flat)
   caparray_skip:
@@ -133,6 +135,7 @@ Return the POST representation of the regex AST rooted by C<node>.
     ops.'push_pirop'('jump', '$I10')
     ops.'push'(donelabel)
     self.'!cursorop'(ops, '!cursor_fail', 0)
+    self.'!cursorop'(ops, '!cursor_debug', 0, '"FAIL  "', regexname_esc)
     ops.'push_pirop'('return', cur)
     .return (ops)
 .end
@@ -724,6 +727,7 @@ second child of this node.
 
     ops.'push_pirop'('inline', 'inline'=>'  # rx pass')
     self.'!cursorop'(ops, '!cursor_pass', 0, pos, regexname)
+    self.'!cursorop'(ops, '!cursor_debug', 0, '"PASS  "', regexname, '" at pos="', pos)
     ops.'push_pirop'('return', cur)
     .return (ops)
 .end

diff --git a/src/Regex/Cursor-builtins.pir b/src/Regex/Cursor-builtins.pir
@@ -190,6 +190,17 @@ Regex::Cursor-builtins - builtin regexes for Cursor objects
     die message
 .end
 
+.sub 'DEBUG' :method
+    .param pmc arg             :optional
+    .param int has_arg         :opt_flag
+
+    if has_arg goto have_arg
+    arg = get_global '$!TRUE'
+  have_arg:
+
+    setattribute self, '$!debug', arg
+    .return (1)
+.end
 
 =head1 AUTHORS
 

diff --git a/src/Regex/Cursor.pir b/src/Regex/Cursor.pir
@@ -22,7 +22,7 @@ grammars.
     load_bytecode 'P6object.pbc'
     .local pmc p6meta
     p6meta = new 'P6metaclass'
-    $P0 = p6meta.'new_class'('Regex::Cursor', 'attr'=>'$!target $!from $!pos $!match $!action $!names @!bstack @!cstack @!caparray')
+    $P0 = p6meta.'new_class'('Regex::Cursor', 'attr'=>'$!target $!from $!pos $!match $!action $!names $!debug @!bstack @!cstack @!caparray')
     $P0 = box 0
     set_global '$!generation', $P0
     $P0 = new ['Boolean']
@@ -252,7 +252,7 @@ provided, then the new cursor has the same type as lang.
     parrotclass = getattribute $P0, 'parrotclass'
     cur = new parrotclass
 
-    .local pmc from, pos, target, action
+    .local pmc from, pos, target, action, debug
     from = getattribute self, '$!pos'
     setattribute cur, '$!from', from
     setattribute cur, '$!pos', from
@@ -261,6 +261,8 @@ provided, then the new cursor has the same type as lang.
     setattribute cur, '$!target', target
     action = getattribute self, '$!action'
     setattribute cur, '$!action', action
+    debug = getattribute self, '$!debug'
+    setattribute cur, '$!debug', debug
 
     .return (cur, from, target, from)
 .end
@@ -344,6 +346,35 @@ Set the cursor's position to C<pos>.
 .end
 
 
+=item !cursor_debug(args :slurpy)
+
+Log a debug message.
+
+=cut
+
+.sub '!cursor_debug' :method
+    .param pmc args            :slurpy
+    $P0 = getattribute self, '$!debug'
+    if null $P0 goto done
+    unless $P0 goto done
+    .local pmc from, pos, orig
+    .local int line
+    from = getattribute self, '$!from'
+    orig = getattribute self, '$!target'
+    line = orig.'lineof'(from)
+    inc line
+    printerr from
+    printerr '/'
+    printerr line
+    printerr ': '
+    $S0 = join '', args
+    printerr $S0
+    printerr "\n"
+  done:
+    .return (self)
+.end
+
+
 =item !mark_push(rep, pos, mark)
 
 Push a new backtracking point onto the cursor with the given

diff --git a/src/cheats/regex-cursor-protoregex.pir b/src/cheats/regex-cursor-protoregex.pir
@@ -21,6 +21,8 @@ in reverse order of longest regex name.
 .sub '!protoregex' :method
     .param string name
 
+    self.'!cursor_debug'('START ', name)
+
     .local pmc generation
     generation = get_global '$!generation'
 
@@ -56,9 +58,13 @@ in reverse order of longest regex name.
     if cur goto token_done
     goto token_loop
   token_done:
+    $P0 = cur.'pos'()
+    if $P0 < 0 goto token_fail
+    self.'!cursor_debug'('PASS  ', name, ' at pos=', $P0)
     .return (cur)
 
   token_fail:
+    self.'!cursor_debug'('FAIL  ', name)
     .return (0)
 .end