view release on metacpan or  search on metacpan

share/P6STD/STD.pm6  view on Meta::CPAN

 
    token mod_internal:sym<:Perl5>    { [':Perl5' | ':P5'] <.require_P5> [ :lang( $¢.cursor_fresh( %*LANG<P5Regex> ).unbalanced($*GOAL) ) <nibbler> ] }

    token mod_internal:p6adv {
        <?before ':' ['dba'|'lang'] » > [ :lang(%*LANG<MAIN>) <quotepair> ] $<sym> = {':' ~ $<quotepair><k>}
    }

    token mod_internal:oops { {} (':'\w+) <.sorry: "Unrecognized regex modifier " ~ $0.Str > }

    token quantifier:sym<*>  { <sym> <quantmod> }
    token quantifier:sym<+>  { <sym> <quantmod> }
    token quantifier:sym<?>  { <sym> <quantmod> }
    token quantifier:sym<:>  { <sym> {} <?before \s> }
    token quantifier:sym<**> { '**' :: <normspace>? <quantmod> <normspace>?
        [
        | \d+ \s+ '..' <.panic: "Spaces not allowed in bare range">
        | (\d+) [ '..' [ (\d+) { $¢.panic("Empty range") if $0.Str > $1[0].Str } | '*' | <.panic: "Malformed range"> ] ]?
        | <embeddedblock>
        | {} <quantified_atom> { $¢.worryobs("atom ** " ~ $<quantified_atom>.Str ~ " as separator", "atom +% " ~ $<quantified_atom>.Str, " nowadays"); }
        ]
    }

    token quantifier:sym<~> {
        <sym> :: <normspace>? <quantified_atom> <normspace>? <quantified_atom>
    }

    token quantifier:sym<~~> {
        [
        | '!' <sym>
        | <sym>
        ]
        <normspace> <quantified_atom> }

    token quantmod { ':'? [ '?' | '!' | '+' ]? }

    token quantifier:sym<{N,M}> {
        {} '{' (\d+) (','?) (\d*) '}'
        {
            my $all = substr(self.orig, self.pos, $¢.pos - self.pos);
            my $repl = chars($1.Str) ??
                ($0.Str ~ '..' ~ ($2.Str || '*')) !! $0.Str;
            $¢.sorryobs($all ~ " as general quantifier", 'X**' ~ $repl);
        }
    }
}

method require_P5 {
    require STD_P5;
    self;
}

method require_P6 {
    require STD_P6;
    self;
}

#################
# Symbol tables #
#################

method newlex ($needsig = 0) {
    my $oid = $*CURLEX.id;
    $ALL.{$oid} === $*CURLEX or die "internal error: current lex id is invalid";
    my $line = self.lineof(self.pos);
    my $id;
    if $*NEWLEX {
        $*NEWLEX.<OUTER::> = $*CURLEX.idref;
        $*CURLEX = $*NEWLEX;
        $*NEWLEX = 0;
        $id = $*CURLEX.id;
    }
    else {
        $id = 'MY:file<' ~ $*FILE<name> ~ '>:line(' ~ $line ~ '):pos(' ~ self.pos ~ ')';
        $*CURLEX = Stash.new(
            'OUTER::' => [$oid],
            '!file' => $*FILE, '!line' => $line,
            '!id' => [$id],
        );
    }
    $*CURLEX.<!NEEDSIG> = 1 if $needsig;
    $*CURLEX.<!IN_DECL> = $*IN_DECL if $*IN_DECL;
    $ALL.{$id} = $*CURLEX;
    self.<LEX> = $*CURLEX;
    $*DECLARAND<curlex> = $*CURLEX if $*DECLARAND;
    self;
}

method finishlex {
    my $line = self.lineof(self.pos);
    $*CURLEX<$_> //= NAME.new( name => '$_', file => $*FILE, line => $line, dynamic => 1, scope => 'my' );
    $*CURLEX<$/> //= NAME.new( name => '$/', file => $*FILE, line => $line, dynamic => 1, scope => 'my' );
    $*CURLEX<$!> //= NAME.new( name => '$!', file => $*FILE, line => $line, dynamic => 1, scope => 'my' );
    $*SIGNUM = 0;
    self;
}

method getsig {
    my $pv = $*CURLEX.{'%?PLACEHOLDERS'};
    my $sig;
    if $*CURLEX.<!NEEDSIG>:delete {
        if $pv {
            my $h_ = ($pv.<%_>:delete);
            my $a_ = ($pv.<@_>:delete);
            $sig = join ', ', sort { substr($^a,1) leg substr($^b,1) }, keys %$pv;
            $sig ~= ', *@_' if $a_;
            $sig ~= ', *%_' if $h_;
        }
        else {
            $sig = '$_ is ref = OUTER::<$_>';
        }
        $*CURLEX.<$?SIGNATURE> = $sig;
    }
    else {
        $sig = $*CURLEX.<$?SIGNATURE>;
    }
    self.<sig> = self.makestr(TEXT => $sig);
    self.<lex> = $*CURLEX.idref;
    if ($*DECLARAND<mult>//'') ne 'proto' {
        for keys %$*CURLEX {
            my $desc = $*CURLEX{$_};
            next unless $_ ~~ m/(\$|\@|\%|\&)\w/;
            next if $_ eq '$_' or $_ eq '@_' or $_ eq '%_';
            next if $desc<used>;
            next if $desc<rebind>;
            next if $desc<dynamic>;
            my $scope = $desc<scope> // 'my';
            next if $scope eq 'our';
            next if $scope eq 'state';
            next if $desc<stub>;
            my $pos = $desc<declaredat> // self.pos;
            self.cursor($pos).worry("$_ is declared but not used");
        }
    }
    self;
}

method getdecl {
    self.<decl> = $*DECLARAND;
    self;
}