# Marpa::R3 is Copyright (C) 2018, Jeffrey Kegler.
#
# This module is free software; you can redistribute it and/or modify it
# under the same terms as Perl 5.10.1. For more details, see the full text
# of the licenses in the directory LICENSES.
#
# This program is distributed in the hope that it will be
# useful, but it is provided "as is" and without any express
# or implied warranties. For details, see the full text of
# of the licenses in the directory LICENSES.
package Marpa::R3::Glade;
use 5.010001;
use strict;
use warnings;
no warnings qw(recursion);
use vars qw($VERSION $STRING_VERSION);
$VERSION = '4.001_052';
$STRING_VERSION = $VERSION;
## no critic(BuiltinFunctions::ProhibitStringyEval)
$VERSION = eval $VERSION;
## use critic
# The code in this file, for now, breaks "the rules". It makes use
# of internal methods not documented as part of Libmarpa.
# It is intended to create documented Libmarpa methods to underlie
# this interface, and rewrite it to use them
package Marpa::R3::Internal_Glade;
use Scalar::Util qw(blessed tainted);
use English qw( -no_match_vars );
our $PACKAGE = 'Marpa::R3::Glade';
# Set those common args which are at the Perl level.
# This is more complicated that it needs to be for the current implementation.
# It allows for LHS terminals (implemented in Libmarpa but not allowed by the SLIF).
# It also assumes that every or-node which can be constructed from preceding or-nodes
# and the input will be present. This is currently the case, but in the future
# rules and/or symbols may have extra-syntactic conditions attached making this
# assumption false.
# Set those common args which are at the Perl level.
sub glade_common_set {
my ( $glade, $flat_args ) = @_;
if ( my $value = $flat_args->{'trace_file_handle'} ) {
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE] = $value;
}
my $trace_file_handle =
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE];
delete $flat_args->{'trace_file_handle'};
return $flat_args;
}
sub Marpa::R3::Internal_Glade::peak {
my ( $asf, @args ) = @_;
my $glade = bless [], "Marpa::R3::Glade";
my $end_of_parse;
my ( $flat_args, $error_message ) = Marpa::R3::flatten_hash_args( \@args );
Marpa::R3::exception( sprintf $error_message, '$glade->peak' )
if not $flat_args;
$flat_args = glade_common_set( $glade, $flat_args );
my $asf_class = 'Marpa::R3::ASF';
if ( not blessed $asf or not $asf->isa($asf_class) ) {
my $ref_type = ref $asf;
my $desc = $ref_type ? "a ref to $ref_type" : 'not a ref';
Marpa::R3::exception(
qq{'recognizer' named argument to new() is $desc\n},
" It should be a ref to $asf_class\n"
);
}
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE] //=
$asf->[Marpa::R3::Internal_ASF::TRACE_FILE_HANDLE];
my $trace_file_handle =
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE];
my $lua = $asf->[Marpa::R3::Internal_ASF::L];
$glade->[Marpa::R3::Internal_Glade::L] = $lua;
my ( $regix ) = $asf->coro_by_tag(
( '@' . __FILE__ . ':' . __LINE__ ),
{
signature => 's',
args => [$flat_args],
handlers => {
trace => sub {
my ($msg) = @_;
say {$trace_file_handle} $msg;
return 'ok';
},
}
},
<<'END_OF_LUA');
local asf, flat_args = ...
_M.wrap(function ()
local peak = asf:peak(flat_args)
if not peak then return 'ok', -1 end
return 'ok', peak.regix
end)
END_OF_LUA
return if $regix < 0;
$glade->[Marpa::R3::Internal_Glade::REGIX] = $regix;
return $glade;
}
sub Marpa::R3::Glade::DESTROY {
# say STDERR "In Marpa::R3::Glade::DESTROY before test";
my $glade = shift;
my $lua = $glade->[Marpa::R3::Internal_Glade::L];
# If we are destroying the Perl interpreter, then all the Marpa
# objects will be destroyed, including Marpa's Lua interpreter.
# We do not need to worry about cleaning up the
# recognizer is an orderly manner, because the Lua interpreter
# containing the recognizer will be destroyed.
# In fact, the Lua interpreter may already have been destroyed,
# so this test is necessary to avoid a warning message.
return if not $lua;
# say STDERR "In Marpa::R3::Glade::DESTROY after test";
my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX];
$glade->call_by_tag(
('@' . __FILE__ . ':' . __LINE__),
<<'END_OF_LUA', '');
local glade = ...
local regix = glade.regix
_M.unregister(_M.registry, regix)
END_OF_LUA
}
# not to be documented
sub Marpa::R3::Glade::call_by_tag {
my ( $glade, $tag, $codestr, $signature, @args ) = @_;
my $lua = $glade->[Marpa::R3::Internal_Glade::L];
my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX];
my @results;
my $eval_error;
my $eval_ok;
{
local $@;
$eval_ok = eval {
@results =
$lua->call_by_tag( $regix, $tag, $codestr, $signature, @args );
return 1;
};
$eval_error = $@;
}
if ( not $eval_ok ) {
Marpa::R3::exception($eval_error);
}
return @results;
}
# not to be documented
sub Marpa::R3::Glade::coro_by_tag {
my ( $glade, $tag, $args, $codestr ) = @_;
my $lua = $glade->[Marpa::R3::Internal_ASF::L];
my $regix = $glade->[Marpa::R3::Internal_ASF::REGIX];
my $handler = $args->{handlers} // {};
my $resume_tag = $tag . '[R]';
my $signature = $args->{signature} // '';
my $p_args = $args->{args} // [];
my @results;
my $eval_error;
my $eval_ok;
{
local $@;
$eval_ok = eval {
$lua->call_by_tag( $regix, $tag, $codestr, $signature, @{$p_args} );
my @resume_args = ('');
my $signature = 's';
CORO_CALL: while (1) {
my ( $cmd, $yield_data ) =
$lua->call_by_tag( $regix, $resume_tag,
'local glade, resume_arg = ...; return _M.resume(resume_arg)',
$signature, @resume_args ) ;
if (not $cmd) {
@results = @{$yield_data};
return 1;
}
my $handler = $handler->{$cmd};
Marpa::R3::exception(qq{No coro handler for "$cmd"})
if not $handler;
$yield_data //= [];
my ($handler_cmd, $new_resume_args) = $handler->(@{$yield_data});
Marpa::R3::exception(qq{Undefined return command from handler for "$cmd"})
if not defined $handler_cmd;
if ($handler_cmd eq 'ok') {
$signature = 's';
@resume_args = ($new_resume_args);
if (scalar @resume_args < 1) {
@resume_args = ('');
}
next CORO_CALL;
}
if ($handler_cmd eq 'sig') {
@resume_args = @{$new_resume_args};
$signature = shift @resume_args;
next CORO_CALL;
}
Marpa::R3::exception(qq{Bad return command ("$handler_cmd") from handler for "$cmd"})
}
return 1;
};
$eval_error = $@;
}
if ( not $eval_ok ) {
# if it's an object, just die
die $eval_error if ref $eval_error;
Marpa::R3::exception($eval_error);
}
return @results;
}
sub Marpa::R3::Glade::g1_span {
my ($glade) = @_;
my ($g1_start, $g1_length) = $glade->call_by_tag(
('@' . __FILE__ . ':' . __LINE__),
<<'END__OF_LUA', '>*' );
local glade = ...
return glade:g1_span()
END__OF_LUA
return $g1_start, $g1_length;
}
sub Marpa::R3::Glade::dump {
my ($glade) = @_;
return "";
}
# not to be documented
sub Marpa::R3::Glade::regix {
my ( $glade ) = @_;
my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX];
return $regix;
}
1;
# vim: expandtab shiftwidth=4: