File Coverage

blib/lib/Marpa/R3/ASF.pm
Criterion Covered Total %
statement 92 134 68.6
branch 9 32 28.1
condition 6 16 37.5
subroutine 13 18 72.2
pod 0 8 0.0
total 120 208 57.6


line stmt bran cond sub pod time code
1             # Marpa::R3 is Copyright (C) 2018, Jeffrey Kegler.
2             #
3             # This module is free software; you can redistribute it and/or modify it
4             # under the same terms as Perl 5.10.1. For more details, see the full text
5             # of the licenses in the directory LICENSES.
6             #
7             # This program is distributed in the hope that it will be
8             # useful, but it is provided "as is" and without any express
9             # or implied warranties. For details, see the full text of
10             # of the licenses in the directory LICENSES.
11              
12             package Marpa::R3::ASF;
13              
14 101     101   1983 use 5.010001;
  101         414  
15 101     101   666 use strict;
  101         251  
  101         2697  
16 101     101   619 use warnings;
  101         247  
  101         3407  
17 101     101   645 no warnings qw(recursion);
  101         246  
  101         4148  
18              
19 101     101   679 use vars qw($VERSION $STRING_VERSION);
  101         275  
  101         8864  
20             $VERSION = '4.001_052';
21             $STRING_VERSION = $VERSION;
22             ## no critic(BuiltinFunctions::ProhibitStringyEval)
23             $VERSION = eval $VERSION;
24             ## use critic
25              
26             # The code in this file, for now, breaks "the rules". It makes use
27             # of internal methods not documented as part of Libmarpa.
28             # It is intended to create documented Libmarpa methods to underlie
29             # this interface, and rewrite it to use them
30              
31             package Marpa::R3::Internal_ASF;
32              
33 101     101   751 use Scalar::Util qw(blessed tainted);
  101         270  
  101         6430  
34 101     101   744 use English qw( -no_match_vars );
  101         273  
  101         679  
35              
36             our $PACKAGE = 'Marpa::R3::ASF';
37              
38             # Set those common args which are at the Perl level.
39             # This is more complicated that it needs to be for the current implementation.
40             # It allows for LHS terminals (implemented in Libmarpa but not allowed by the SLIF).
41             # It also assumes that every or-node which can be constructed from preceding or-nodes
42             # and the input will be present. This is currently the case, but in the future
43             # rules and/or symbols may have extra-syntactic conditions attached making this
44             # assumption false.
45              
46             # Set those common args which are at the Perl level.
47             sub asf_common_set {
48 1     1   2 my ( $asf, $flat_args ) = @_;
49 1 50       3 if ( my $value = $flat_args->{'trace_file_handle'} ) {
50 0         0 $asf->[Marpa::R3::Internal_ASF::TRACE_FILE_HANDLE] = $value;
51             }
52 1         5 my $trace_file_handle =
53             $asf->[Marpa::R3::Internal_ASF::TRACE_FILE_HANDLE];
54 1         3 delete $flat_args->{'trace_file_handle'};
55 1         2 return $flat_args;
56             }
57              
58             # Returns undef if no parse
59             sub Marpa::R3::ASF::new {
60 1     1 0 1614 my ( $class, @args ) = @_;
61 1         3 my $asf = bless [], $class;
62              
63 1         2 my $end_of_parse;
64              
65 1         6 my ( $flat_args, $error_message ) = Marpa::R3::flatten_hash_args( \@args );
66 1 50       4 Marpa::R3::exception( sprintf $error_message, '$asf->new' )
67             if not $flat_args;
68 1         4 $flat_args = asf_common_set( $asf, $flat_args );
69              
70 1         2 my $slr = $flat_args->{recognizer};
71 1 50       3 Marpa::R3::exception(
72             qq{Marpa::R3::ASF::new() called without a "recognizer" argument} )
73             if not defined $slr;
74 1         3 $asf->[Marpa::R3::Internal_ASF::SLR] = $slr;
75 1         1 delete $flat_args->{recognizer};
76              
77 1         2 my $slr_class = 'Marpa::R3::Recognizer';
78 1 50 33     11 if ( not blessed $slr or not $slr->isa($slr_class) ) {
79 0         0 my $ref_type = ref $slr;
80 0 0       0 my $desc = $ref_type ? "a ref to $ref_type" : 'not a ref';
81 0         0 Marpa::R3::exception(
82             qq{'recognizer' named argument to new() is $desc\n},
83             " It should be a ref to $slr_class\n"
84             );
85             }
86              
87 1   33     6 $asf->[Marpa::R3::Internal_ASF::TRACE_FILE_HANDLE] //=
88             $slr->[Marpa::R3::Internal_R::TRACE_FILE_HANDLE];
89              
90 1         2 my $trace_file_handle =
91             $asf->[Marpa::R3::Internal_ASF::TRACE_FILE_HANDLE];
92              
93 1         2 my $lua = $slr->[Marpa::R3::Internal_R::L];
94 1         2 $asf->[Marpa::R3::Internal_ASF::L] = $lua;
95              
96             my ( $regix ) = $slr->coro_by_tag(
97             ( '@' . __FILE__ . ':' . __LINE__ ),
98             {
99             signature => 's',
100             args => [$flat_args],
101             handlers => {
102             trace => sub {
103 0     0   0 my ($msg) = @_;
104 0         0 say {$trace_file_handle} $msg;
  0         0  
105 0         0 return 'ok';
106             },
107             }
108             },
109 1         11 <<'END_OF_LUA');
110             local slr, flat_args = ...
111             _M.wrap(function ()
112             local asf = slr:asf_new(flat_args)
113             if not asf then return 'ok', -1 end
114             return 'ok', asf.regix
115             end)
116             END_OF_LUA
117              
118 1 50       9 return if $regix < 0;
119 1         2 $asf->[Marpa::R3::Internal_ASF::REGIX] = $regix;
120              
121 1   50     7 $asf->[Marpa::R3::Internal_ASF::FACTORING_MAX] //= 42;
122              
123 1         4 return $asf;
124              
125             } ## end sub Marpa::R3::ASF::new
126              
127             sub Marpa::R3::ASF::DESTROY {
128             # say STDERR "In Marpa::R3::ASF::DESTROY before test";
129 1     1   3 my $asf = shift;
130 1         2 my $lua = $asf->[Marpa::R3::Internal_ASF::L];
131              
132             # If we are destroying the Perl interpreter, then all the Marpa
133             # objects will be destroyed, including Marpa's Lua interpreter.
134             # We do not need to worry about cleaning up the
135             # recognizer is an orderly manner, because the Lua interpreter
136             # containing the recognizer will be destroyed.
137             # In fact, the Lua interpreter may already have been destroyed,
138             # so this test is necessary to avoid a warning message.
139 1 50       3 return if not $lua;
140             # say STDERR "In Marpa::R3::ASF::DESTROY after test";
141              
142 1         2 my $regix = $asf->[Marpa::R3::Internal_ASF::REGIX];
143 1         3 $asf->call_by_tag(
144             ('@' . __FILE__ . ':' . __LINE__),
145             <<'END_OF_LUA', '');
146             local asf = ...
147             local regix = asf.regix
148             _M.unregister(_M.registry, regix)
149             END_OF_LUA
150             }
151              
152             # not to be documented
153             sub Marpa::R3::ASF::call_by_tag {
154 1     1 0 4 my ( $asf, $tag, $codestr, $signature, @args ) = @_;
155 1         2 my $lua = $asf->[Marpa::R3::Internal_ASF::L];
156 1         1 my $regix = $asf->[Marpa::R3::Internal_ASF::REGIX];
157              
158 1         3 my @results;
159             my $eval_error;
160 1         0 my $eval_ok;
161             {
162 1         1 local $@;
  1         2  
163 1         2 $eval_ok = eval {
164 1         14 @results =
165             $lua->call_by_tag( $regix, $tag, $codestr, $signature, @args );
166 1         2 return 1;
167             };
168 1         3 $eval_error = $@;
169             }
170 1 50       3 if ( not $eval_ok ) {
171 0         0 Marpa::R3::exception($eval_error);
172             }
173 1         6 return @results;
174             }
175              
176             # not to be documented
177             sub Marpa::R3::ASF::coro_by_tag {
178 1     1 0 3 my ( $asf, $tag, $args, $codestr ) = @_;
179 1         2 my $lua = $asf->[Marpa::R3::Internal_ASF::L];
180 1         2 my $regix = $asf->[Marpa::R3::Internal_ASF::REGIX];
181 1   50     4 my $handler = $args->{handlers} // {};
182 1         3 my $resume_tag = $tag . '[R]';
183 1   50     3 my $signature = $args->{signature} // '';
184 1   50     4 my $p_args = $args->{args} // [];
185              
186 1         3 my @results;
187             my $eval_error;
188 1         0 my $eval_ok;
189             {
190 1         2 local $@;
  1         2  
191 1         2 $eval_ok = eval {
192 1         2 $lua->call_by_tag( $regix, $tag, $codestr, $signature, @{$p_args} );
  1         30  
193 1         3 my @resume_args = ('');
194 1         1 my $signature = 's';
195 1         2 CORO_CALL: while (1) {
196 1         32 my ( $cmd, $yield_data ) =
197             $lua->call_by_tag( $regix, $resume_tag,
198             'local asf, resume_arg = ...; return _M.resume(resume_arg)',
199             $signature, @resume_args ) ;
200 1 50       4 if (not $cmd) {
201 1         2 @results = @{$yield_data};
  1         2  
202 1         3 return 1;
203             }
204 0         0 my $handler = $handler->{$cmd};
205 0 0       0 Marpa::R3::exception(qq{No coro handler for "$cmd"})
206             if not $handler;
207 0   0     0 $yield_data //= [];
208 0         0 my ($handler_cmd, $new_resume_args) = $handler->(@{$yield_data});
  0         0  
209 0 0       0 Marpa::R3::exception(qq{Undefined return command from handler for "$cmd"})
210             if not defined $handler_cmd;
211 0 0       0 if ($handler_cmd eq 'ok') {
212 0         0 $signature = 's';
213 0         0 @resume_args = ($new_resume_args);
214 0 0       0 if (scalar @resume_args < 1) {
215 0         0 @resume_args = ('');
216             }
217 0         0 next CORO_CALL;
218             }
219 0 0       0 if ($handler_cmd eq 'sig') {
220 0         0 @resume_args = @{$new_resume_args};
  0         0  
221 0         0 $signature = shift @resume_args;
222 0         0 next CORO_CALL;
223             }
224 0         0 Marpa::R3::exception(qq{Bad return command ("$handler_cmd") from handler for "$cmd"})
225             }
226 0         0 return 1;
227             };
228 1         3 $eval_error = $@;
229             }
230 1 50       3 if ( not $eval_ok ) {
231             # if it's an object, just die
232 0 0       0 die $eval_error if ref $eval_error;
233 0         0 Marpa::R3::exception($eval_error);
234             }
235 1         4 return @results;
236             }
237              
238             sub Marpa::R3::ASF::ambiguity_level {
239 0     0 0 0 my ($asf) = @_;
240              
241 0         0 my ($metric) = $asf->call_by_tag(
242             ('@' . __FILE__ . ':' . __LINE__),
243             <<'END__OF_LUA', '>*' );
244             local asf = ...
245             return asf:ambiguity_level()
246             END__OF_LUA
247 0         0 return $metric;
248             }
249              
250             sub Marpa::R3::ASF::peak {
251 1     1 0 6 my ($asf) = @_;
252              
253 1         5 my ($peak) = Marpa::R3::Internal_Glade::peak($asf);
254 1         2 return $peak;
255             }
256              
257             sub Marpa::R3::ASF::dump {
258 0     0 0   my ($asf) = @_;
259 0           my ($dump) = $asf->call_by_tag(
260             ('@' . __FILE__ . ':' . __LINE__),
261             <<'END__OF_LUA', '>*' );
262             local asf = ...
263             return asf:dump()
264             END__OF_LUA
265 0           return $dump;
266             }
267              
268             sub Marpa::R3::ASF::g1_pos {
269 0     0 0   my ( $asf ) = @_;
270 0           my ($g1_pos) = $asf->call_by_tag(
271             ('@' . __FILE__ . ':' . __LINE__),
272             <<'END__OF_LUA', '>*' );
273             local asf = ...
274             return asf:g1_pos()
275             END__OF_LUA
276 0           return $g1_pos;
277             }
278              
279             # not to be documented
280             sub Marpa::R3::ASF::regix {
281 0     0 0   my ( $asf ) = @_;
282 0           my $regix = $asf->[Marpa::R3::Internal_ASF::REGIX];
283 0           return $regix;
284             }
285              
286             1;
287              
288             # vim: expandtab shiftwidth=4: