Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Perlito5 - indirect-object - all tests pass
  • Loading branch information
@fglock
fglock committed Jul 24, 2013
1 parent a6bb050 commit f4ffaad
Show file tree
Hide file tree
Showing 5 changed files with 83 additions and 57 deletions.
41 changes: 25 additions & 16 deletions html/perlito5.js
View file
Expand Up @@ -5253,24 +5253,31 @@ var p5100 = p5pkg['main'];
var v_invocant;
var v_effective_name;
(v_effective_name = ((p5str(p5or(v_namespace, function () { return p5pkg["Perlito5"]["v_PKG_NAME"] })) + '::' + p5str(v_name))));
if ( ((p5pkg["Perlito5"]["v_PROTO"])._hash_.hasOwnProperty(v_effective_name) || ((!( p5bool(v_namespace)) || (p5str(v_namespace) == 'CORE')) && (p5pkg["Perlito5"]["v_CORE_PROTO"])._hash_.hasOwnProperty(('CORE::' + p5str(v_name))))) ) {
(function () {
(v_invocant = (p5call(p5pkg["Perlito5::Grammar"], "full_ident", [v_str, v_p], 0)));
var v_package;
(v_package = (p5pkg["Perlito5::Match"].flat([v_invocant], 0)));
if ( p5bool(v_package) ) {
(v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hset('capture', (p5call(p5pkg["Perlito5::AST::Var"], "new", ['sigil', '::', 'name', '', 'namespace', v_package], 0)));
if ( (p5pkg["Perlito5::Grammar::Bareword"].substr([v_str, (v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hget('to'), 2], 0) == '::') ) {
(v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hset('to', ((p5num((v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hget('to')) + 2)));
}
else {
(v_invocant = (null));
};
};
})();
if ( (p5pkg["Perlito5::Grammar::Print"]["Hash_Print"]).hasOwnProperty(v_name) ) {
(v_invocant = (null));
}
else {
(v_invocant = (p5call(p5pkg["Perlito5::Grammar::Bareword"], "the_object", [v_str, v_p], 0)));
if ( ((p5pkg["Perlito5"]["v_PROTO"])._hash_.hasOwnProperty(v_effective_name) || ((!( p5bool(v_namespace)) || (p5str(v_namespace) == 'CORE')) && (p5pkg["Perlito5"]["v_CORE_PROTO"])._hash_.hasOwnProperty(('CORE::' + p5str(v_name))))) ) {
(function () {
(v_invocant = (p5call(p5pkg["Perlito5::Grammar"], "full_ident", [v_str, v_p], 0)));
var v_package;
(v_package = (p5pkg["Perlito5::Match"].flat([v_invocant], 0)));
if ( p5bool(v_package) ) {
(v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hset('capture', (p5call(p5pkg["Perlito5::AST::Var"], "new", ['sigil', '::', 'name', '', 'namespace', v_package], 0)));
if ( (p5pkg["Perlito5::Grammar::Bareword"].substr([v_str, (v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hget('to'), 2], 0) == '::') ) {
(v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hset('to', ((p5num((v_invocant || (v_invocant = new p5HashRef({})))._hash_.p5hget('to')) + 2)));
}
else {
if ( !( p5bool((p5pkg["Perlito5"]["v_PACKAGES"] || (p5pkg["Perlito5"]["v_PACKAGES"] = new p5HashRef({})))._hash_.p5hget(p5str(v_package)))) ) {
(v_invocant = (null));
};
};
};
})();
}
else {
(v_invocant = (p5call(p5pkg["Perlito5::Grammar::Bareword"], "the_object", [v_str, v_p], 0)));
};
};
if ( p5bool(v_invocant) ) {
(function () {
Expand Down Expand Up @@ -11528,6 +11535,8 @@ return r;
var p5155 = p5make_package("Perlito5::Grammar::Print");
// use strict
;
// our p5pkg["Perlito5::Grammar::Print"]["Hash_Print"]
(p5pkg["Perlito5::Grammar::Print"]["Hash_Print"] = {'print' : 1, 'printf' : 1, 'say' : 1, 'exec' : 1, 'system' : 1});
p5pkg["Perlito5::Precedence"].add_term(['print', function (List__, p5want) {
return (p5call(p5pkg["Perlito5::Grammar::Print"], "term_print", p5list_to_a(List__.p5aget(0), List__.p5aget(1)), p5want));
}], null);
Expand Down
34 changes: 21 additions & 13 deletions perlito5.pl
View file
Expand Up @@ -774,21 +774,28 @@ sub Perlito5::Grammar::Bareword::term_bareword {
};
(my $invocant);
((my $effective_name) = ((($namespace || $Perlito5::PKG_NAME)) . '::' . $name));
if ((exists($Perlito5::PROTO->{$effective_name}) || ((((!($namespace) || ($namespace eq 'CORE'))) && exists($Perlito5::CORE_PROTO->{('CORE::' . $name)}))))) {
($invocant = Perlito5::Grammar->full_ident($str, $p));
((my $package) = Perlito5::Match::flat($invocant));
if ($package) {
($invocant->{'capture'} = Perlito5::AST::Var->new('sigil', '::', 'name', '', 'namespace', $package));
if ((substr($str, $invocant->{'to'}, 2) eq '::')) {
($invocant->{'to'} = ($invocant->{'to'} + 2))
}
else {
($invocant = undef())
}
}
if (exists($Perlito5::Grammar::Print::Print{$name})) {
($invocant = undef())
}
else {
($invocant = Perlito5::Grammar::Bareword->the_object($str, $p))
if ((exists($Perlito5::PROTO->{$effective_name}) || ((((!($namespace) || ($namespace eq 'CORE'))) && exists($Perlito5::CORE_PROTO->{('CORE::' . $name)}))))) {
($invocant = Perlito5::Grammar->full_ident($str, $p));
((my $package) = Perlito5::Match::flat($invocant));
if ($package) {
($invocant->{'capture'} = Perlito5::AST::Var->new('sigil', '::', 'name', '', 'namespace', $package));
if ((substr($str, $invocant->{'to'}, 2) eq '::')) {
($invocant->{'to'} = ($invocant->{'to'} + 2))
}
else {
if (!($Perlito5::PACKAGES->{$package})) {
($invocant = undef())
}
}
}
}
else {
($invocant = Perlito5::Grammar::Bareword->the_object($str, $p))
}
};
if ($invocant) {
($p = $invocant->{'to'});
Expand Down Expand Up @@ -6445,6 +6452,7 @@ package Perlito5::Grammar::Print;

# use strict
;
((our %Print) = ('print', 1, 'printf', 1, 'say', 1, 'exec', 1, 'system', 1));
Perlito5::Precedence::add_term('print', sub {
Perlito5::Grammar::Print->term_print($_[0], $_[1])
});
Expand Down
22 changes: 13 additions & 9 deletions src5/lib/Perlito5/Grammar/Bareword.pm
View file
Expand Up @@ -77,17 +77,18 @@ token the_object {
# check for indirect-object
my $invocant;
my $effective_name = ( $namespace || $Perlito5::PKG_NAME ) . '::' . $name;
if ( exists( $Perlito5::PROTO->{$effective_name} ) # subroutine was predeclared
|| ( (!$namespace || $namespace eq 'CORE')
&& exists $Perlito5::CORE_PROTO->{"CORE::$name"} # subroutine comes from CORE
)
)
if ( exists( $Perlito5::Grammar::Print::Print{$name} ) ) {
$invocant = undef;
}
elsif ( exists( $Perlito5::PROTO->{$effective_name} ) # subroutine was predeclared
|| ( (!$namespace || $namespace eq 'CORE')
&& exists $Perlito5::CORE_PROTO->{"CORE::$name"} # subroutine comes from CORE
)
)
{
# first term is a subroutine name;
# this can be an indirect-object if the next term is a bareword ending with '::'

# TODO

$invocant = Perlito5::Grammar->full_ident( $str, $p );
my $package = Perlito5::Match::flat($invocant);
if ( $package ) {
Expand All @@ -102,10 +103,13 @@ token the_object {
}
else {
# is this a known package name?
# if ( ! $Perlito5::PACKAGES->{ $package } ) {
if ( ! $Perlito5::PACKAGES->{ $package } ) {
# not a known package name
$invocant = undef;
# }
}
else {
# valid package name - this is indirect-object
}
}
}

Expand Down
8 changes: 8 additions & 0 deletions src5/lib/Perlito5/Grammar/Print.pm
View file
Expand Up @@ -3,6 +3,14 @@ package Perlito5::Grammar::Print;

use strict;

our %Print = (
print => 1,
printf => 1,
say => 1,
exec => 1,
system => 1,
);

Perlito5::Precedence::add_term( 'print' => sub { Perlito5::Grammar::Print->term_print($_[0], $_[1]) } );
Perlito5::Precedence::add_term( 'printf' => sub { Perlito5::Grammar::Print->term_print($_[0], $_[1]) } );
Perlito5::Precedence::add_term( 'say' => sub { Perlito5::Grammar::Print->term_print($_[0], $_[1]) } );
Expand Down
35 changes: 16 additions & 19 deletions t5/01-perlito/27-syntax-indirect-object.t
View file
@@ -1,6 +1,6 @@
use feature 'say';

say "1..21";
say "1..20";

my $v = 0;
my $r = 1;
Expand Down Expand Up @@ -38,56 +38,53 @@ my $e;

$r = 3;

# TODO - 'A P' without eval;
$e = eval 'A P; 1';
A P;
print "not " if $r != 4;
say "ok 5 - method call - $r # TODO";
print "not " if !$x;
say "ok 6 - method call # $x";
print "not " if !$e;
say "ok 7 - syntax ok - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " # TODO";

$r = 3;
$e = eval 'A Q; 1'; # Bareword "Q" not allowed
print "not " if $r != 3;
say "ok 8 - syntax error - $r ";
say "ok 7 - syntax error - $r ";
print "not " if $e;
say "ok 9 - syntax error - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . "";
say "ok 8 - syntax error - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . "";

$r = 3;
$e = eval 'A Q::; 1'; # Can't locate object method "A"
print "not " if $r != 3;
say "ok 10 - runtime error - $r";
say "ok 9 - runtime error - $r";
print "not " if $e;
say "ok 11 - runtime error - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";
say "ok 10 - runtime error - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";

$r = 3;
$e = eval 'A M; 1';
print "not " if $r != 12;
say "ok 12 - method in other package - $r # TODO - strict";
say "ok 11 - method in other package - $r ";
print "not " if !$e;
say "ok 13 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " # TODO";
say "ok 12 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";

$r = 3;
$e = eval 'A M::; 1';
print "not " if $r != 12;
say "ok 14 - method in other package - $r ";
say "ok 13 - method in other package - $r ";
print "not " if !$e;
say "ok 15 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";
say "ok 14 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";

$v = 3;
$e = eval 'C M; 1';
print "not " if $v != 13;
say "ok 16 - method in other package - $v";
say "ok 15 - method in other package - $v";
print "not " if !$e;
say "ok 17 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";
say "ok 16 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";

$v = 3;
$e = eval 'C M::; 1';
print "not " if $v != 13;
say "ok 18 - method in other package - $v ";
say "ok 17 - method in other package - $v ";
print "not " if !$e;
say "ok 19 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";
say "ok 18 - method in other package - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " ";

}

Expand All @@ -99,8 +96,8 @@ my $e;
$r = 3;
$e = eval 'A Q; 1'; # this would be an error: Bareword "Q" not allowed
print "not " if $r != 3;
say "ok 20 - bareword not a syntax error under no strict # $r";
say "ok 19 - bareword not a syntax error under no strict # $r";
print "not " if $e;
say "ok 21 - bareword; runtime error - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " #";
say "ok 20 - bareword; runtime error - $e " . ( $@ ? substr( $@, 0, 30 ) : '' ) . " #";
}

0 comments on commit f4ffaad

Please sign in to comment.