[perl6]:

* Initial version of smart match (infix:~~) and regex support.
  Still very incomplete in some respects, but hey, it's a start.  :-)


git-svn-id: http://svn.perl.org/parrot/trunk/languages/perl6@12631 d31e2699-5ff4-0310-a27c-f18f2fbe73fe

src/POST.pir

@@ -37,6 +37,7 @@ The base class of POST is Perl6::PAST::Node -- see C<lib/PAST.pir>
 
     $P0 = subclass base, 'Perl6::POST::Sub'
     addattribute $P0, '$.outer'
+    addattribute $P0, '$.subtype'
 
     $P0 = subclass base, 'Perl6::POST::Op'
     $P0 = subclass base, 'Perl6::POST::Ops'
@@ -192,6 +193,12 @@ and that is returned.
     .return self.'attr'('$.outer', outer, has_outer)
 .end
 
+.sub 'subtype' :method
+    .param pmc subtype         :optional
+    .param int has_subtype     :opt_flag
+    .return self.'attr'('$.subtype', subtype, has_subtype)
+.end
+
 .sub 'root_pir' :method
     ##   create a new (empty) variable hash for the outer sub
     $P0 = new .Hash
@@ -211,6 +218,12 @@ and that is returned.
 
 
 .sub 'pir' :method
+    .local string subtype
+    subtype = self.'subtype'()
+    if subtype != 'regex' goto standard_sub
+    .return self.'pir_regex'()
+
+  standard_sub:
     ##   create a new (empty) variable hash for this sub
     .local pmc varhash
     varhash = find_global 'Perl6::POST', '%!varhash'
@@ -232,6 +245,11 @@ and that is returned.
     ## build the code for this sub
     subcode = new 'PGE::CodeString'
     subcode.'emit'("\n.sub '%0' %1", name, outerattr)
+    ## add the $/ lexical
+    $P0 = new 'Perl6::POST::Var'
+    $P0.'init'('name'=>'$/', 'scope'=>'lexical')
+    $P1 = $P0.'pir'()
+    subcode .= $P1
     iter = self.'child_iter'()
   iter_loop:
     unless iter goto iter_end
@@ -257,8 +275,27 @@ and that is returned.
     .return (code)
 .end
 
+.sub 'pir_regex' :method
+    .local pmc p6regex, regexast, regexpir
+    .local string name, value
+    name = self.'name'()
+    value = self.'value'()
+    p6regex = compreg 'PGE::P6Regex'
+    regexast = self[0]
+    regexpir = p6regex(regexast, 'name'=>name, 'grammar'=>'', 'target'=>'PIR')
+
+    $P0 = find_global 'Perl6::POST', '$!subpir'
+    regexpir .= $P0
+    store_global 'Perl6::POST', '$!subpir', regexpir
+
+    .local pmc code
+    code = new 'PGE::CodeString'
+    code.'emit'("    %0 = find_name '%1'", value, name)
+    .return (code)
+.end
+
 .sub '__dumplist' :method
-    .return ('$.name $.outer $.value @.children')
+    .return ('$.name $.subtype $.outer $.value @.children')
 .end
 
 .namespace [ 'Perl6::POST::Val' ]

src/builtins.pir

@@ -592,6 +592,18 @@
 ## TODO: infix:|= infix:&= infix:^=
 
 
+.sub 'infix:~~'
+    .param pmc topic
+    .param pmc regex
+    .local pmc match
+    match = regex(topic)
+    $P0 = getinterp
+    $P1 = $P0['lexpad';1]
+    $P1['$/'] = match
+    .return (match)
+.end
+
+
 .sub 'die'
     .param pmc list            :slurpy
     .local pmc iter

src/grammar_rules.pg

@@ -161,7 +161,7 @@ token reserved_word { [ if | unless | while | until | for | loop ] \b }
 ## XXX: These are just placeholder regexes for demonstration,
 ## they certainly need to be expanded to be more complete.
 
-token variable { <sigil> <name> }
+token variable { \$/ | \$_ | <sigil> <name> }
 token sigil { <[$@%^&]> }
 
 token integer {

src/parse.pir

@@ -193,9 +193,5 @@ working -- it will likely change.
   with_stop: 
     $P0 = find_global 'PGE::Grammar', 'regex'
     $P1 = $P0(mob, 'stop'=>stop)
-    '_dumper'($P1)
-    $I0 = $P1.to()
-    print $I0
-    print "\n"
     .return ($P1)
 .end

src/past2post.tg

@@ -7,17 +7,19 @@ Perl6::PAST::Block: root(.) = {
 
 
 Perl6::PAST::Block: post(.) = {
-    .local string name
+    .local string name, blocktype
     name = node.'name'()
+    blocktype = node.'blocktype'()
     if name > '' goto with_name
-    name = node.'unique'('_block')
+    name = concat '_', blocktype
+    name = node.'unique'(name)
   with_name:
     .local pmc outerpost, outerpast
     outerpost = find_global 'Perl6::POST', '$?BLOCK'
     outerpast = find_global 'Perl6::PAST', '$?BLOCK'
     .local pmc post
     post = new 'Perl6::POST::Sub'
-    post.'init'('node'=>node, 'name'=>name, 'outer'=>outerpost)
+    post.'init'('node'=>node, 'name'=>name, 'outer'=>outerpost, 'subtype'=>blocktype)
     store_global 'Perl6::POST', '$?BLOCK', post
     store_global 'Perl6::PAST', '$?BLOCK', node
     .local pmc iter
@@ -32,6 +34,7 @@ Perl6::PAST::Block: post(.) = {
   iter_end:
     .local pmc value
     value = cpost.'value'()
+    value = clone value
     post.'value'(value)
     store_global 'Perl6::POST', '$?BLOCK', outerpost
     store_global 'Perl6::PAST', '$?BLOCK', outerpast
@@ -52,6 +55,8 @@ Perl6::Grammar: post(.) = {
     ##   code that is stored as a child of a Block.  The regex
     ##   AST is already reduced to what we want to pass to
     ##   the PGE compiler, so we just return it directly.
+    ##   But clear any 'value' of the Match object, first.
+    node.'value'('')
     .return (node)
 }