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::Glade; |
13
|
|
|
|
|
|
|
|
14
|
104
|
|
|
104
|
|
2144
|
use 5.010001; |
|
104
|
|
|
|
|
345
|
|
15
|
104
|
|
|
104
|
|
530
|
use strict; |
|
104
|
|
|
|
|
200
|
|
|
104
|
|
|
|
|
2273
|
|
16
|
104
|
|
|
104
|
|
701
|
use warnings; |
|
104
|
|
|
|
|
212
|
|
|
104
|
|
|
|
|
3308
|
|
17
|
104
|
|
|
104
|
|
524
|
no warnings qw(recursion); |
|
104
|
|
|
|
|
202
|
|
|
104
|
|
|
|
|
4033
|
|
18
|
|
|
|
|
|
|
|
19
|
104
|
|
|
104
|
|
621
|
use vars qw($VERSION $STRING_VERSION); |
|
104
|
|
|
|
|
206
|
|
|
104
|
|
|
|
|
8375
|
|
20
|
|
|
|
|
|
|
$VERSION = '4.001_054'; |
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_Glade; |
32
|
|
|
|
|
|
|
|
33
|
104
|
|
|
104
|
|
644
|
use Scalar::Util qw(blessed tainted); |
|
104
|
|
|
|
|
205
|
|
|
104
|
|
|
|
|
6046
|
|
34
|
104
|
|
|
104
|
|
608
|
use English qw( -no_match_vars ); |
|
104
|
|
|
|
|
256
|
|
|
104
|
|
|
|
|
614
|
|
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
our $PACKAGE = 'Marpa::R3::Glade'; |
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 glade_common_set { |
48
|
1
|
|
|
1
|
|
2
|
my ( $glade, $flat_args ) = @_; |
49
|
1
|
50
|
|
|
|
4
|
if ( my $value = $flat_args->{'trace_file_handle'} ) { |
50
|
0
|
|
|
|
|
0
|
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE] = $value; |
51
|
|
|
|
|
|
|
} |
52
|
1
|
|
|
|
|
6
|
my $trace_file_handle = |
53
|
|
|
|
|
|
|
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE]; |
54
|
1
|
|
|
|
|
2
|
delete $flat_args->{'trace_file_handle'}; |
55
|
1
|
|
|
|
|
2
|
return $flat_args; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
sub Marpa::R3::Internal_Glade::peak { |
59
|
1
|
|
|
1
|
|
3
|
my ( $asf, @args ) = @_; |
60
|
1
|
|
|
|
|
5
|
my $glade = bless [], "Marpa::R3::Glade"; |
61
|
|
|
|
|
|
|
|
62
|
1
|
|
|
|
|
2
|
my $end_of_parse; |
63
|
|
|
|
|
|
|
|
64
|
1
|
|
|
|
|
3
|
my ( $flat_args, $error_message ) = Marpa::R3::flatten_hash_args( \@args ); |
65
|
1
|
50
|
|
|
|
3
|
Marpa::R3::exception( sprintf $error_message, '$glade->peak' ) |
66
|
|
|
|
|
|
|
if not $flat_args; |
67
|
1
|
|
|
|
|
4
|
$flat_args = glade_common_set( $glade, $flat_args ); |
68
|
|
|
|
|
|
|
|
69
|
1
|
|
|
|
|
3
|
my $asf_class = 'Marpa::R3::ASF'; |
70
|
1
|
50
|
33
|
|
|
12
|
if ( not blessed $asf or not $asf->isa($asf_class) ) { |
71
|
0
|
|
|
|
|
0
|
my $ref_type = ref $asf; |
72
|
0
|
0
|
|
|
|
0
|
my $desc = $ref_type ? "a ref to $ref_type" : 'not a ref'; |
73
|
0
|
|
|
|
|
0
|
Marpa::R3::exception( |
74
|
|
|
|
|
|
|
qq{'recognizer' named argument to new() is $desc\n}, |
75
|
|
|
|
|
|
|
" It should be a ref to $asf_class\n" |
76
|
|
|
|
|
|
|
); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
1
|
|
33
|
|
|
7
|
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE] //= |
80
|
|
|
|
|
|
|
$asf->[Marpa::R3::Internal_ASF::TRACE_FILE_HANDLE]; |
81
|
|
|
|
|
|
|
|
82
|
1
|
|
|
|
|
1
|
my $trace_file_handle = |
83
|
|
|
|
|
|
|
$glade->[Marpa::R3::Internal_Glade::TRACE_FILE_HANDLE]; |
84
|
|
|
|
|
|
|
|
85
|
1
|
|
|
|
|
2
|
my $lua = $asf->[Marpa::R3::Internal_ASF::L]; |
86
|
1
|
|
|
|
|
3
|
$glade->[Marpa::R3::Internal_Glade::L] = $lua; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my ( $regix ) = $asf->coro_by_tag( |
89
|
|
|
|
|
|
|
( '@' . __FILE__ . ':' . __LINE__ ), |
90
|
|
|
|
|
|
|
{ |
91
|
|
|
|
|
|
|
signature => 's', |
92
|
|
|
|
|
|
|
args => [$flat_args], |
93
|
|
|
|
|
|
|
handlers => { |
94
|
|
|
|
|
|
|
trace => sub { |
95
|
0
|
|
|
0
|
|
0
|
my ($msg) = @_; |
96
|
0
|
|
|
|
|
0
|
say {$trace_file_handle} $msg; |
|
0
|
|
|
|
|
0
|
|
97
|
0
|
|
|
|
|
0
|
return 'ok'; |
98
|
|
|
|
|
|
|
}, |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
}, |
101
|
1
|
|
|
|
|
11
|
<<'END_OF_LUA'); |
102
|
|
|
|
|
|
|
local asf, flat_args = ... |
103
|
|
|
|
|
|
|
_M.wrap(function () |
104
|
|
|
|
|
|
|
local peak = asf:peak(flat_args) |
105
|
|
|
|
|
|
|
if not peak then return 'ok', -1 end |
106
|
|
|
|
|
|
|
return 'ok', peak.regix |
107
|
|
|
|
|
|
|
end) |
108
|
|
|
|
|
|
|
END_OF_LUA |
109
|
|
|
|
|
|
|
|
110
|
1
|
50
|
|
|
|
7
|
return if $regix < 0; |
111
|
1
|
|
|
|
|
2
|
$glade->[Marpa::R3::Internal_Glade::REGIX] = $regix; |
112
|
1
|
|
|
|
|
4
|
return $glade; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub Marpa::R3::Glade::DESTROY { |
117
|
|
|
|
|
|
|
# say STDERR "In Marpa::R3::Glade::DESTROY before test"; |
118
|
1
|
|
|
1
|
|
883
|
my $glade = shift; |
119
|
1
|
|
|
|
|
2
|
my $lua = $glade->[Marpa::R3::Internal_Glade::L]; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# If we are destroying the Perl interpreter, then all the Marpa |
122
|
|
|
|
|
|
|
# objects will be destroyed, including Marpa's Lua interpreter. |
123
|
|
|
|
|
|
|
# We do not need to worry about cleaning up the |
124
|
|
|
|
|
|
|
# recognizer is an orderly manner, because the Lua interpreter |
125
|
|
|
|
|
|
|
# containing the recognizer will be destroyed. |
126
|
|
|
|
|
|
|
# In fact, the Lua interpreter may already have been destroyed, |
127
|
|
|
|
|
|
|
# so this test is necessary to avoid a warning message. |
128
|
1
|
50
|
|
|
|
4
|
return if not $lua; |
129
|
|
|
|
|
|
|
# say STDERR "In Marpa::R3::Glade::DESTROY after test"; |
130
|
|
|
|
|
|
|
|
131
|
1
|
|
|
|
|
2
|
my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX]; |
132
|
1
|
|
|
|
|
3
|
$glade->call_by_tag( |
133
|
|
|
|
|
|
|
('@' . __FILE__ . ':' . __LINE__), |
134
|
|
|
|
|
|
|
<<'END_OF_LUA', ''); |
135
|
|
|
|
|
|
|
local glade = ... |
136
|
|
|
|
|
|
|
local regix = glade.regix |
137
|
|
|
|
|
|
|
_M.unregister(_M.registry, regix) |
138
|
|
|
|
|
|
|
END_OF_LUA |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# not to be documented |
142
|
|
|
|
|
|
|
sub Marpa::R3::Glade::call_by_tag { |
143
|
2
|
|
|
2
|
0
|
5
|
my ( $glade, $tag, $codestr, $signature, @args ) = @_; |
144
|
2
|
|
|
|
|
3
|
my $lua = $glade->[Marpa::R3::Internal_Glade::L]; |
145
|
2
|
|
|
|
|
3
|
my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX]; |
146
|
|
|
|
|
|
|
|
147
|
2
|
|
|
|
|
5
|
my @results; |
148
|
|
|
|
|
|
|
my $eval_error; |
149
|
2
|
|
|
|
|
0
|
my $eval_ok; |
150
|
|
|
|
|
|
|
{ |
151
|
2
|
|
|
|
|
3
|
local $@; |
|
2
|
|
|
|
|
2
|
|
152
|
2
|
|
|
|
|
4
|
$eval_ok = eval { |
153
|
2
|
|
|
|
|
44
|
@results = |
154
|
|
|
|
|
|
|
$lua->call_by_tag( $regix, $tag, $codestr, $signature, @args ); |
155
|
2
|
|
|
|
|
4
|
return 1; |
156
|
|
|
|
|
|
|
}; |
157
|
2
|
|
|
|
|
6
|
$eval_error = $@; |
158
|
|
|
|
|
|
|
} |
159
|
2
|
50
|
|
|
|
6
|
if ( not $eval_ok ) { |
160
|
0
|
|
|
|
|
0
|
Marpa::R3::exception($eval_error); |
161
|
|
|
|
|
|
|
} |
162
|
2
|
|
|
|
|
8
|
return @results; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# not to be documented |
166
|
|
|
|
|
|
|
sub Marpa::R3::Glade::coro_by_tag { |
167
|
0
|
|
|
0
|
0
|
0
|
my ( $glade, $tag, $args, $codestr ) = @_; |
168
|
0
|
|
|
|
|
0
|
my $lua = $glade->[Marpa::R3::Internal_ASF::L]; |
169
|
0
|
|
|
|
|
0
|
my $regix = $glade->[Marpa::R3::Internal_ASF::REGIX]; |
170
|
0
|
|
0
|
|
|
0
|
my $handler = $args->{handlers} // {}; |
171
|
0
|
|
|
|
|
0
|
my $resume_tag = $tag . '[R]'; |
172
|
0
|
|
0
|
|
|
0
|
my $signature = $args->{signature} // ''; |
173
|
0
|
|
0
|
|
|
0
|
my $p_args = $args->{args} // []; |
174
|
|
|
|
|
|
|
|
175
|
0
|
|
|
|
|
0
|
my @results; |
176
|
|
|
|
|
|
|
my $eval_error; |
177
|
0
|
|
|
|
|
0
|
my $eval_ok; |
178
|
|
|
|
|
|
|
{ |
179
|
0
|
|
|
|
|
0
|
local $@; |
|
0
|
|
|
|
|
0
|
|
180
|
0
|
|
|
|
|
0
|
$eval_ok = eval { |
181
|
0
|
|
|
|
|
0
|
$lua->call_by_tag( $regix, $tag, $codestr, $signature, @{$p_args} ); |
|
0
|
|
|
|
|
0
|
|
182
|
0
|
|
|
|
|
0
|
my @resume_args = (''); |
183
|
0
|
|
|
|
|
0
|
my $signature = 's'; |
184
|
0
|
|
|
|
|
0
|
CORO_CALL: while (1) { |
185
|
0
|
|
|
|
|
0
|
my ( $cmd, $yield_data ) = |
186
|
|
|
|
|
|
|
$lua->call_by_tag( $regix, $resume_tag, |
187
|
|
|
|
|
|
|
'local glade, resume_arg = ...; return _M.resume(resume_arg)', |
188
|
|
|
|
|
|
|
$signature, @resume_args ) ; |
189
|
0
|
0
|
|
|
|
0
|
if (not $cmd) { |
190
|
0
|
|
|
|
|
0
|
@results = @{$yield_data}; |
|
0
|
|
|
|
|
0
|
|
191
|
0
|
|
|
|
|
0
|
return 1; |
192
|
|
|
|
|
|
|
} |
193
|
0
|
|
|
|
|
0
|
my $handler = $handler->{$cmd}; |
194
|
0
|
0
|
|
|
|
0
|
Marpa::R3::exception(qq{No coro handler for "$cmd"}) |
195
|
|
|
|
|
|
|
if not $handler; |
196
|
0
|
|
0
|
|
|
0
|
$yield_data //= []; |
197
|
0
|
|
|
|
|
0
|
my ($handler_cmd, $new_resume_args) = $handler->(@{$yield_data}); |
|
0
|
|
|
|
|
0
|
|
198
|
0
|
0
|
|
|
|
0
|
Marpa::R3::exception(qq{Undefined return command from handler for "$cmd"}) |
199
|
|
|
|
|
|
|
if not defined $handler_cmd; |
200
|
0
|
0
|
|
|
|
0
|
if ($handler_cmd eq 'ok') { |
201
|
0
|
|
|
|
|
0
|
$signature = 's'; |
202
|
0
|
|
|
|
|
0
|
@resume_args = ($new_resume_args); |
203
|
0
|
0
|
|
|
|
0
|
if (scalar @resume_args < 1) { |
204
|
0
|
|
|
|
|
0
|
@resume_args = (''); |
205
|
|
|
|
|
|
|
} |
206
|
0
|
|
|
|
|
0
|
next CORO_CALL; |
207
|
|
|
|
|
|
|
} |
208
|
0
|
0
|
|
|
|
0
|
if ($handler_cmd eq 'sig') { |
209
|
0
|
|
|
|
|
0
|
@resume_args = @{$new_resume_args}; |
|
0
|
|
|
|
|
0
|
|
210
|
0
|
|
|
|
|
0
|
$signature = shift @resume_args; |
211
|
0
|
|
|
|
|
0
|
next CORO_CALL; |
212
|
|
|
|
|
|
|
} |
213
|
0
|
|
|
|
|
0
|
Marpa::R3::exception(qq{Bad return command ("$handler_cmd") from handler for "$cmd"}) |
214
|
|
|
|
|
|
|
} |
215
|
0
|
|
|
|
|
0
|
return 1; |
216
|
|
|
|
|
|
|
}; |
217
|
0
|
|
|
|
|
0
|
$eval_error = $@; |
218
|
|
|
|
|
|
|
} |
219
|
0
|
0
|
|
|
|
0
|
if ( not $eval_ok ) { |
220
|
|
|
|
|
|
|
# if it's an object, just die |
221
|
0
|
0
|
|
|
|
0
|
die $eval_error if ref $eval_error; |
222
|
0
|
|
|
|
|
0
|
Marpa::R3::exception($eval_error); |
223
|
|
|
|
|
|
|
} |
224
|
0
|
|
|
|
|
0
|
return @results; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
sub Marpa::R3::Glade::g1_span { |
228
|
1
|
|
|
1
|
0
|
5
|
my ($glade) = @_; |
229
|
|
|
|
|
|
|
|
230
|
1
|
|
|
|
|
5
|
my ($g1_start, $g1_length) = $glade->call_by_tag( |
231
|
|
|
|
|
|
|
('@' . __FILE__ . ':' . __LINE__), |
232
|
|
|
|
|
|
|
<<'END__OF_LUA', '>*' ); |
233
|
|
|
|
|
|
|
local glade = ... |
234
|
|
|
|
|
|
|
return glade:g1_span() |
235
|
|
|
|
|
|
|
END__OF_LUA |
236
|
1
|
|
|
|
|
3
|
return $g1_start, $g1_length; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub Marpa::R3::Glade::dump { |
240
|
0
|
|
|
0
|
0
|
|
my ($glade) = @_; |
241
|
0
|
|
|
|
|
|
return ""; |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
# not to be documented |
245
|
|
|
|
|
|
|
sub Marpa::R3::Glade::regix { |
246
|
0
|
|
|
0
|
0
|
|
my ( $glade ) = @_; |
247
|
0
|
|
|
|
|
|
my $regix = $glade->[Marpa::R3::Internal_Glade::REGIX]; |
248
|
0
|
|
|
|
|
|
return $regix; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
1; |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
# vim: expandtab shiftwidth=4: |