view release on metacpan or  search on metacpan

src/Perlito5/Grammar/Block.pm  view on Meta::CPAN

package Perlito5::Grammar::Block;

use Perlito5::Grammar::Expression;
use Perlito5::Grammar::Scope;
use Perlito5::AST::BeginScratchpad;
use Perlito5::AST::Captures;
use Perlito5::FoldConstant;
use strict;

our %Named_block = (
    BEGIN     => 1,
    UNITCHECK => 1,
    CHECK     => 1,
    INIT      => 1,
    END       => 1,
    AUTOLOAD  => 1,
    DESTROY   => 1,
);

sub block {
    my $str = $_[0];
    my $pos = $_[1];
    my $m = Perlito5::Grammar::Space::opt_ws($str, $pos);
    $pos = $m->{to};
    if ( $str->[$pos] ne '{' ) {
        return
    }
    $pos++;

    # when parsing a command like "for my $x ..." register the loop variable
    # before entering the block, so that it can be seen immediately
    Perlito5::Grammar::Scope::check_variable_declarations();
    Perlito5::Grammar::Scope::create_new_compile_time_scope();

    $m = Perlito5::Grammar::exp_stmts($str, $pos);
    if (!$m) {
        Perlito5::Compiler::error "syntax error";
    }
    $pos = $m->{to};
    my $capture = Perlito5::Match::flat($m);
    $m = Perlito5::Grammar::Space::opt_ws($str, $pos);
    $pos = $m->{to};
    if ( $str->[$pos] ne '}' ) {
        Perlito5::Compiler::error "syntax error";
    }
    $m->{to} = $pos + 1;
    $m->{capture} = Perlito5::AST::Block->new( stmts => $capture, sig => undef );
    # end of lexical scope
    Perlito5::Grammar::Scope::end_compile_time_scope();
    return $m;
}

sub closure_block {
    my $str = $_[0];
    my $pos = $_[1];
    my $m = Perlito5::Grammar::Space::opt_ws($str, $pos);
    $pos = $m->{to};
    if ( $str->[$pos] ne '{' ) {
        return
    }
    $pos++;

    # when parsing a command like "for my $x ..." register the loop variable
    # before entering the block, so that it can be seen immediately
    Perlito5::Grammar::Scope::check_variable_declarations();
    Perlito5::Grammar::Scope::create_new_compile_time_scope();
    local $Perlito5::CLOSURE_SCOPE = $#Perlito5::BASE_SCOPE;  # this is the only diff from plain <block>

    $m = Perlito5::Grammar::exp_stmts($str, $pos);
    if (!$m) {
        Perlito5::Compiler::error "syntax error";
    }

src/Perlito5/Grammar/Block.pm  view on Meta::CPAN

   
    # anonymous blocks can have a 'continue' block
    $m = Perlito5::Grammar::opt_continue_block( $str, $p );
    $p = $m->{to};
    my $continue = Perlito5::Match::flat($m);

    my $v = $block;

    # TODO - this is not recognized as a statement: { 123 => 4;}
    # TODO - this is not recognized as a syntax error: { 123 => 4 }{2}
    $v = Perlito5::Grammar::Expression::block_or_hash($v)
        if !$continue->{is_continue}
        && !$Perlito5::BLOCK_HAS_SEMICOLON;
    $m->{capture} = $v;
    if ( $continue->{is_continue} ) {
        $m->{capture}{continue} = $continue;
    }
    return $m;
}

sub ast_nop {
    Perlito5::AST::Apply->new(
        code => 'nop',
        namespace => 'Perlito5',
        arguments => []
    );
}

sub special_named_block {
    my $str = $_[0];
    my $pos = $_[1];

    my $p = $pos;
    my $block_name;
    my $m_name = Perlito5::Grammar::ident( $str, $p );
    return if !$m_name;
    $p = $m_name->{to};
    $block_name = Perlito5::Match::flat($m_name);

    my $ws = Perlito5::Grammar::Space::opt_ws( $str, $p );
    $p = $ws->{to};

    my $block_start = $p;
    my $m = Perlito5::Grammar::Block::closure_block( $str, $p );
    return if !$m;
    $p = $m->{to};
    my $block = Perlito5::Match::flat($m);
 
    if ($block_name eq 'INIT') {
        push @Perlito5::INIT_BLOCK, eval_end_block( $block, 'INIT' );
        $m->{capture} = ast_nop();
    }
    elsif ($block_name eq 'END') {
        unshift @Perlito5::END_BLOCK, eval_end_block( $block, 'END' );
        $m->{capture} = ast_nop();
    }
    elsif ($block_name eq 'CHECK') {
        unshift @Perlito5::CHECK_BLOCK, eval_end_block( $block, 'CHECK' );
        $m->{capture} = ast_nop();
    }
    elsif ($block_name eq 'UNITCHECK') {
        unshift @Perlito5::UNITCHECK_BLOCK, eval_end_block( $block, 'UNITCHECK' );
        $m->{capture} = ast_nop();
    }
    elsif ($block_name eq 'BEGIN') {
        # say "BEGIN $block_start ", $m->{to}, "[", substr($str, $block_start, $m->{to} - $block_start), "]";
        # local $Perlito5::PKG_NAME = $Perlito5::PKG_NAME;  # BUG - this doesn't work
        local $Perlito5::PHASE = 'BEGIN';
        eval_begin_block( $block );
        $m->{capture} = ast_nop();
    }
    elsif ($block_name eq 'AUTOLOAD' || $block_name eq 'DESTROY') {
        my $sub = Perlito5::AST::Sub->new(
            'attributes' => [],
            'block'      => $block,
            'name'       => $block_name,
            'namespace'  => $Perlito5::PKG_NAME,
            'sig'        => undef,
            'pos'        => Perlito5::Compiler::compiler_pos(),
        );
        # add named sub to SCOPE
        my $full_name = $sub->{namespace} . "::" . $sub->{name};
        $Perlito5::PROTO->{$full_name} = undef;
        $Perlito5::GLOBAL->{$full_name} = $sub;
        # evaluate the sub definition in a BEGIN block
        $block = Perlito5::AST::Block->new( stmts => [$sub] );
        Perlito5::Grammar::Block::eval_begin_block($block, 'BEGIN');  
        # runtime effect of subroutine declaration is "undef"
        $m->{capture} = ast_nop();
    }
    else {
        $m->{capture} = $block;
        $m->{capture}{name} = $block_name;
    }
    return $m;
}

token named_sub_def {
    <Perlito5::Grammar::optional_namespace_before_ident> <Perlito5::Grammar::ident>
    <Perlito5::Grammar::Block::prototype_> <.Perlito5::Grammar::Space::opt_ws>
    <Perlito5::Grammar::Attribute::opt_attribute> <.Perlito5::Grammar::Space::opt_ws>
    [
        <Perlito5::Grammar::Block::closure_block>
        {
            $MATCH->{_tmp} = Perlito5::Match::flat($MATCH->{"Perlito5::Grammar::Block::closure_block"});
        }
    |
        <.Perlito5::Grammar::Statement::statement_parse>
        {
            Perlito5::Compiler::error 'Illegal declaration of subroutine \'', Perlito5::Match::flat($MATCH->{"Perlito5::Grammar::ident"}), '\''
        }
    |
        {
            # subroutine predeclaration - there is no block
            $MATCH->{_tmp} = undef;
        }
    ]
    {
        my $name = Perlito5::Match::flat($MATCH->{"Perlito5::Grammar::ident"});
        my $sig  = Perlito5::Match::flat($MATCH->{"Perlito5::Grammar::Block::prototype_"});
        $sig = undef if $sig eq '*undef*';