line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package AI::Prolog::Parser; |
2
|
|
|
|
|
|
|
$REVISION = '$Id: Parser.pm,v 1.9 2005/08/06 23:28:40 ovid Exp $'; |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
$VERSION = '0.10'; |
5
|
13
|
|
|
13
|
|
12224
|
use strict; |
|
13
|
|
|
|
|
27
|
|
|
13
|
|
|
|
|
469
|
|
6
|
13
|
|
|
13
|
|
69
|
use warnings; |
|
13
|
|
|
|
|
24
|
|
|
13
|
|
|
|
|
448
|
|
7
|
13
|
|
|
13
|
|
70
|
use Carp qw( confess croak ); |
|
13
|
|
|
|
|
30
|
|
|
13
|
|
|
|
|
893
|
|
8
|
13
|
|
|
13
|
|
17977
|
use Regexp::Common; |
|
13
|
|
|
|
|
77175
|
|
|
13
|
|
|
|
|
73
|
|
9
|
13
|
|
|
13
|
|
925349
|
use Hash::Util 'lock_keys'; |
|
13
|
|
|
|
|
2334
|
|
|
13
|
|
|
|
|
148
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
# debugging stuff |
12
|
13
|
|
|
13
|
|
9514
|
use Clone; |
|
13
|
|
|
|
|
38212
|
|
|
13
|
|
|
|
|
678
|
|
13
|
13
|
|
|
13
|
|
483299
|
use Text::Balanced qw/extract_quotelike extract_delimited/; |
|
13
|
|
|
|
|
589270
|
|
|
13
|
|
|
|
|
1558
|
|
14
|
|
|
|
|
|
|
|
15
|
13
|
|
|
13
|
|
154
|
use aliased 'AI::Prolog::Engine'; |
|
13
|
|
|
|
|
28
|
|
|
13
|
|
|
|
|
274
|
|
16
|
13
|
|
|
13
|
|
1377
|
use aliased 'AI::Prolog::KnowledgeBase'; |
|
13
|
|
|
|
|
23
|
|
|
13
|
|
|
|
|
66
|
|
17
|
13
|
|
|
13
|
|
1671
|
use aliased 'AI::Prolog::Parser::PreProcessor'; |
|
13
|
|
|
|
|
26
|
|
|
13
|
|
|
|
|
52
|
|
18
|
13
|
|
|
13
|
|
1252
|
use aliased 'AI::Prolog::Term'; |
|
13
|
|
|
|
|
32
|
|
|
13
|
|
|
|
|
92
|
|
19
|
13
|
|
|
13
|
|
1817
|
use aliased 'AI::Prolog::Term::Number'; |
|
13
|
|
|
|
|
137
|
|
|
13
|
|
|
|
|
60
|
|
20
|
13
|
|
|
13
|
|
1591
|
use aliased 'AI::Prolog::TermList'; |
|
13
|
|
|
|
|
59
|
|
|
13
|
|
|
|
|
58
|
|
21
|
13
|
|
|
13
|
|
1542
|
use aliased 'AI::Prolog::TermList::Clause'; |
|
13
|
|
|
|
|
32
|
|
|
13
|
|
|
|
|
52
|
|
22
|
13
|
|
|
13
|
|
1538
|
use aliased 'AI::Prolog::TermList::Primitive'; |
|
13
|
|
|
|
|
32
|
|
|
13
|
|
|
|
|
58
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
my $ATOM = qr/[[:alpha:]][[:alnum:]_]*/; |
25
|
|
|
|
|
|
|
|
26
|
13
|
|
|
13
|
|
2511
|
use constant NULL => 'null'; |
|
13
|
|
|
|
|
33
|
|
|
13
|
|
|
|
|
38222
|
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub new { |
29
|
76
|
|
|
76
|
0
|
2961
|
my ( $class, $string ) = @_; |
30
|
76
|
|
|
|
|
439
|
my $self = bless { |
31
|
|
|
|
|
|
|
_str => PreProcessor->process($string), |
32
|
|
|
|
|
|
|
_posn => 0, |
33
|
|
|
|
|
|
|
_start => 0, |
34
|
|
|
|
|
|
|
_varnum => 0, |
35
|
|
|
|
|
|
|
_internal => 0, |
36
|
|
|
|
|
|
|
_vardict => {}, |
37
|
|
|
|
|
|
|
} => $class; |
38
|
76
|
|
|
|
|
346
|
lock_keys %$self; |
39
|
76
|
|
|
|
|
856
|
return $self; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub _vardict_to_string { |
43
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
44
|
0
|
|
|
|
|
0
|
return "{" |
45
|
|
|
|
|
|
|
. ( |
46
|
0
|
|
|
|
|
0
|
join ', ' => map { join '=' => $_->[0], $_->[1] } |
47
|
0
|
|
|
|
|
0
|
sort { $a->[2] <=> $b->[2] } |
48
|
0
|
|
|
|
|
0
|
map { [ $_, $self->_sortable_term( $self->{_vardict}{$_} ) ] } |
49
|
0
|
|
|
|
|
0
|
keys %{ $self->{_vardict} } |
50
|
|
|
|
|
|
|
) . "}"; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub _sortable_term { |
54
|
0
|
|
|
0
|
|
0
|
my ( $self, $term ) = @_; |
55
|
0
|
|
|
|
|
0
|
my $string = $term->to_string; |
56
|
0
|
|
|
|
|
0
|
my $number = substr $string => 1; |
57
|
0
|
|
|
|
|
0
|
return $string, $number; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub to_string { |
61
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
62
|
0
|
|
|
|
|
0
|
my $output = Clone::clone($self); |
63
|
0
|
|
|
|
|
0
|
$output->{_vardict} = $self->_vardict_to_string; |
64
|
0
|
|
|
|
|
0
|
return "{" |
65
|
|
|
|
|
|
|
. substr( $self->{_str}, 0, $self->{_posn} ) . " ^ " |
66
|
|
|
|
|
|
|
. substr( $self->{_str}, $self->{_posn} ) . " | " |
67
|
|
|
|
|
|
|
. $self->_vardict_to_string . " }"; |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
0
|
|
|
0
|
|
0
|
sub _posn { shift->{_posn} } |
71
|
0
|
|
|
0
|
|
0
|
sub _str { shift->{_str} } |
72
|
0
|
|
|
0
|
|
0
|
sub _start { shift->{_start} } |
73
|
0
|
|
|
0
|
|
0
|
sub _varnum { shift->{_varnum} } |
74
|
0
|
|
|
0
|
|
0
|
sub _vardict { shift->{_vardict} } |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub _internal { |
77
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
78
|
0
|
0
|
|
|
|
0
|
if (@_) { |
79
|
0
|
|
|
|
|
0
|
$self->{_internal} = shift; |
80
|
0
|
|
|
|
|
0
|
return $self; |
81
|
|
|
|
|
|
|
} |
82
|
0
|
|
|
|
|
0
|
return $self->{_internal}; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# get the current character |
86
|
|
|
|
|
|
|
sub current { |
87
|
49367
|
|
|
49367
|
0
|
53434
|
my $self = shift; |
88
|
49367
|
100
|
|
|
|
80408
|
return '#' if $self->empty; |
89
|
49267
|
|
|
|
|
208997
|
return substr $self->{_str} => $self->{_posn}, 1; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# peek at the next character |
93
|
|
|
|
|
|
|
sub peek { |
94
|
5
|
|
|
5
|
0
|
8
|
my $self = shift; |
95
|
5
|
50
|
|
|
|
11
|
return '#' if $self->empty; |
96
|
5
|
|
50
|
|
|
36
|
return substr( $self->{_str} => ( $self->{_posn} + 1 ), 1 ) || '#'; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# is the parsestring empty? |
100
|
|
|
|
|
|
|
sub empty { |
101
|
49788
|
|
|
49788
|
0
|
49474
|
my $self = shift; |
102
|
49788
|
|
|
|
|
157954
|
return $self->{_posn} >= length $self->{_str}; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
my $LINENUM = 1; |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub linenum { |
108
|
22
|
|
|
22
|
0
|
39
|
my $self = shift; |
109
|
22
|
50
|
|
|
|
152
|
if (@_) { |
110
|
22
|
|
|
|
|
37
|
$LINENUM = shift; |
111
|
22
|
|
|
|
|
46
|
return $self; |
112
|
|
|
|
|
|
|
} |
113
|
0
|
|
|
|
|
0
|
$LINENUM; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub advance_linenum { |
117
|
479
|
|
|
479
|
0
|
578
|
my $self = shift; |
118
|
479
|
|
|
|
|
1198
|
$LINENUM++; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# Move a character forward |
122
|
|
|
|
|
|
|
sub advance { |
123
|
13178
|
|
|
13178
|
0
|
14747
|
my $self = shift; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# print $self->current; # XXX |
126
|
13178
|
50
|
|
|
|
31714
|
$self->{_posn}++ unless $self->{_posn} >= length $self->{_str}; |
127
|
13178
|
100
|
|
|
|
21788
|
$self->advance_linenum if $self->current =~ /[\r\n]/; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# all three get methods must be called before advance |
131
|
|
|
|
|
|
|
# recognize a name (sequence of alphanumerics) |
132
|
|
|
|
|
|
|
# XXX the java methods do not directly translate, so |
133
|
|
|
|
|
|
|
# we need to revisit this if it breaks |
134
|
|
|
|
|
|
|
# XXX Update: There was a subtle bug. I think |
135
|
|
|
|
|
|
|
# I've nailed it, though. The string index was off by one |
136
|
|
|
|
|
|
|
sub getname { |
137
|
1366
|
|
|
1366
|
0
|
2373
|
my $self = shift; |
138
|
|
|
|
|
|
|
|
139
|
1366
|
|
|
|
|
1925
|
$self->{_start} = $self->{_posn}; |
140
|
1366
|
|
|
|
|
1571
|
my $getname; |
141
|
1366
|
100
|
|
|
|
2487
|
if ( $self->current =~ /['"]/ ) { |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# Normally, Prolog distinguishes between single and double quoted strings |
144
|
3
|
|
|
|
|
6
|
my $string = substr $self->{_str} => $self->{_start}; |
145
|
3
|
|
|
|
|
16
|
$getname = extract_delimited($string); |
146
|
3
|
|
|
|
|
273
|
$self->{_posn} += length $getname; |
147
|
3
|
|
|
|
|
10
|
return substr $getname => 1, length($getname) - 2; # strip the quotes |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
else { |
150
|
1363
|
|
|
|
|
4569
|
my $string = substr $self->{_str} => $self->{_start}; |
151
|
1363
|
|
|
|
|
8910
|
($getname) = $string =~ /^($ATOM)/; |
152
|
1363
|
|
|
|
|
3061
|
$self->{_posn} += length $getname; |
153
|
1363
|
|
|
|
|
4155
|
return $getname; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# recognize a number |
158
|
|
|
|
|
|
|
# XXX same issues as getname |
159
|
|
|
|
|
|
|
sub getnum { |
160
|
309
|
|
|
309
|
0
|
371
|
my $self = shift; |
161
|
|
|
|
|
|
|
|
162
|
309
|
|
|
|
|
469
|
$self->{_start} = $self->{_posn}; |
163
|
309
|
|
|
|
|
996
|
my $string = substr $self->{_str} => $self->{_start}; |
164
|
309
|
|
|
|
|
1932
|
my ($getnum) = $string =~ /^($RE{num}{real})/; |
165
|
309
|
100
|
|
|
|
79908
|
if ( '.' eq substr $getnum => -1, 1 ) { |
166
|
234
|
|
|
|
|
793
|
$getnum = substr $getnum => 0, length($getnum) - 1; |
167
|
|
|
|
|
|
|
} |
168
|
309
|
|
|
|
|
529
|
$self->{_posn} += length $getnum; |
169
|
309
|
|
|
|
|
1057
|
return $getnum; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
# get the term corresponding to a name. |
173
|
|
|
|
|
|
|
# if the name is new, create a new variable |
174
|
|
|
|
|
|
|
sub getvar { |
175
|
674
|
|
|
674
|
0
|
1030
|
my $self = shift; |
176
|
674
|
|
|
|
|
1091
|
my $string = $self->getname; |
177
|
674
|
|
|
|
|
1386
|
my $term = $self->{_vardict}{$string}; |
178
|
674
|
100
|
|
|
|
1339
|
unless ($term) { |
179
|
492
|
|
|
|
|
1711
|
$term = Term->new( $self->{_varnum}++ ); # XXX wrong _varnum? |
180
|
492
|
|
|
|
|
1380
|
$self->{_vardict}{$string} = $term; |
181
|
|
|
|
|
|
|
} |
182
|
674
|
|
|
|
|
1616
|
return ( $term, $string ); |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
my $ANON = 'a'; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
sub get_anon { |
188
|
5
|
|
|
5
|
0
|
8
|
my $self = shift; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# HACK!!! |
191
|
5
|
|
|
|
|
11
|
my $string = '___' . $ANON++; |
192
|
5
|
|
|
|
|
11
|
$self->advance; |
193
|
5
|
|
|
|
|
11
|
my $term = $self->{_vardict}{$string}; |
194
|
5
|
50
|
|
|
|
13
|
unless ($term) { |
195
|
5
|
|
|
|
|
28
|
$term = Term->new( $self->{_varnum}++ ); # XXX wrong _varnum? |
196
|
5
|
|
|
|
|
18
|
$self->{_vardict}{$string} = $term; |
197
|
|
|
|
|
|
|
} |
198
|
5
|
|
|
|
|
14
|
return ( $term, $string ); |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
# handle errors in one place |
202
|
|
|
|
|
|
|
sub parseerror { |
203
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $character ) = @_; |
204
|
0
|
|
|
|
|
0
|
my $linenum = $self->linenum; |
205
|
0
|
|
|
|
|
0
|
croak "Unexpected character: ($character) at line number $linenum"; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# skips whitespace and prolog comments |
209
|
|
|
|
|
|
|
sub skipspace { |
210
|
4967
|
|
|
4967
|
0
|
5854
|
my $self = shift; |
211
|
4967
|
|
|
|
|
8844
|
$self->advance while $self->current =~ /[[:space:]]/; |
212
|
4967
|
|
|
|
|
9904
|
_skipcomment($self); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# XXX Other subtle differences |
216
|
|
|
|
|
|
|
sub _skipcomment { |
217
|
4967
|
|
|
4967
|
|
6954
|
my $self = shift; |
218
|
4967
|
100
|
|
|
|
7979
|
if ( $self->current eq '%' ) { |
219
|
90
|
|
66
|
|
|
234
|
while ( $self->current ne "\n" && $self->current ne "#" ) { |
220
|
3060
|
|
|
|
|
6076
|
$self->advance; |
221
|
|
|
|
|
|
|
} |
222
|
90
|
|
|
|
|
343
|
$self->skipspace; |
223
|
|
|
|
|
|
|
} |
224
|
4967
|
50
|
|
|
|
9565
|
if ( $self->current eq "/" ) { |
225
|
0
|
|
|
|
|
0
|
$self->advance; |
226
|
0
|
0
|
|
|
|
0
|
if ( $self->current ne "*" ) { |
227
|
0
|
|
|
|
|
0
|
$self->parseerror("Expecting '*' after '/'"); |
228
|
|
|
|
|
|
|
} |
229
|
0
|
|
|
|
|
0
|
$self->advance; |
230
|
0
|
|
0
|
|
|
0
|
while ( $self->current ne "*" && $self->current ne "#" ) { |
231
|
0
|
|
|
|
|
0
|
$self->advance; |
232
|
|
|
|
|
|
|
} |
233
|
0
|
|
|
|
|
0
|
$self->advance; |
234
|
0
|
0
|
|
|
|
0
|
if ( $self->current ne "/" ) { |
235
|
0
|
|
|
|
|
0
|
$self->parseerror("Expecting terminating '/' on comment"); |
236
|
|
|
|
|
|
|
} |
237
|
0
|
|
|
|
|
0
|
$self->advance; |
238
|
0
|
|
|
|
|
0
|
$self->skipspace; |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# reset the variable dictionary |
243
|
|
|
|
|
|
|
sub nextclause { |
244
|
394
|
|
|
394
|
0
|
518
|
my $self = shift; |
245
|
394
|
|
|
|
|
760
|
$self->{_vardict} = {}; |
246
|
394
|
|
|
|
|
2262
|
$self->{_varnum} = 0; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
# takes a hash and extends it with the clauses in the string |
250
|
|
|
|
|
|
|
# $program is a string representing a prolog program |
251
|
|
|
|
|
|
|
# $db is an initial program that will be augmented with the |
252
|
|
|
|
|
|
|
# clauses parsed. |
253
|
|
|
|
|
|
|
# class method, not an instance method |
254
|
|
|
|
|
|
|
sub consult { |
255
|
22
|
|
|
22
|
0
|
99
|
my ( $class, $program, $db ) = @_; |
256
|
22
|
|
66
|
|
|
190
|
$db ||= KnowledgeBase->new; |
257
|
22
|
|
|
|
|
94
|
my $self = $class->new($program); |
258
|
22
|
|
|
|
|
289
|
$self->linenum(1); |
259
|
22
|
|
|
|
|
77
|
$self->skipspace; |
260
|
|
|
|
|
|
|
|
261
|
22
|
|
|
|
|
67
|
until ( $self->empty ) { |
262
|
394
|
|
|
|
|
950
|
my $termlist = $self->_termlist; |
263
|
|
|
|
|
|
|
|
264
|
394
|
|
|
|
|
1078
|
my $head = $termlist->term; |
265
|
394
|
|
|
|
|
993
|
my $body = $termlist->next; |
266
|
|
|
|
|
|
|
|
267
|
394
|
|
100
|
|
|
2670
|
my $is_primitive = $body && $body->isa(Primitive); |
268
|
394
|
100
|
|
|
|
848
|
unless ($is_primitive) { |
269
|
160
|
|
|
|
|
420
|
my $predicate = $head->predicate; |
270
|
160
|
|
|
|
|
446
|
$is_primitive = exists $db->{primitives}{$predicate}; |
271
|
|
|
|
|
|
|
} |
272
|
394
|
100
|
|
|
|
725
|
my $add = $is_primitive ? 'add_primitive' : 'add_clause'; |
273
|
394
|
|
|
|
|
1493
|
my $clause = Clause->new( $head, $body ); |
274
|
394
|
|
|
|
|
1386
|
my $adding_builtins = Engine->_adding_builtins; |
275
|
394
|
100
|
|
|
|
1389
|
$clause->is_builtin(1) if $adding_builtins; |
276
|
394
|
|
|
|
|
1411
|
$db->$add( $clause, $adding_builtins ); |
277
|
394
|
|
|
|
|
777
|
$self->skipspace; |
278
|
394
|
|
|
|
|
894
|
$self->nextclause; # new set of vars |
279
|
|
|
|
|
|
|
} |
280
|
22
|
|
|
|
|
193
|
return $db; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
sub resolve { |
284
|
0
|
|
|
0
|
0
|
0
|
my ( $class, $db ) = @_; |
285
|
0
|
|
|
|
|
0
|
foreach my $termlist ( values %{ $db->ht } ) { |
|
0
|
|
|
|
|
0
|
|
286
|
0
|
|
|
|
|
0
|
$termlist->resolve($db); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub _termlist { |
291
|
401
|
|
|
401
|
|
538
|
my ($self) = @_; |
292
|
401
|
|
|
|
|
1418
|
my $termlist = TermList->new; |
293
|
401
|
|
|
|
|
1080
|
my @ts = $self->_term; |
294
|
401
|
|
|
|
|
806
|
$self->skipspace; |
295
|
|
|
|
|
|
|
|
296
|
401
|
100
|
|
|
|
807
|
if ( $self->current eq ':' ) { |
297
|
343
|
|
|
|
|
674
|
$self->advance; |
298
|
|
|
|
|
|
|
|
299
|
343
|
100
|
|
|
|
714
|
if ( $self->current eq '=' ) { |
|
|
50
|
|
|
|
|
|
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
# we're parsing a primitive |
302
|
234
|
|
|
|
|
503
|
$self->advance; |
303
|
234
|
|
|
|
|
482
|
$self->skipspace; |
304
|
234
|
|
|
|
|
520
|
my $id = $self->getnum; |
305
|
234
|
|
|
|
|
690
|
$self->skipspace; |
306
|
234
|
|
|
|
|
477
|
$termlist->{term} = $ts[0]; |
307
|
234
|
|
|
|
|
935
|
$termlist->{next} = Primitive->new($id); |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
elsif ( $self->current ne '-' ) { |
310
|
0
|
|
|
|
|
0
|
$self->parseerror("Expected '-' after ':'"); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
else { |
313
|
109
|
|
|
|
|
221
|
$self->advance; |
314
|
109
|
|
|
|
|
391
|
$self->skipspace; |
315
|
|
|
|
|
|
|
|
316
|
109
|
|
|
|
|
239
|
push @ts => $self->_term; |
317
|
109
|
|
|
|
|
252
|
$self->skipspace; |
318
|
|
|
|
|
|
|
|
319
|
109
|
|
|
|
|
262
|
while ( $self->current eq ',' ) { |
320
|
41
|
|
|
|
|
107
|
$self->advance; |
321
|
41
|
|
|
|
|
115
|
$self->skipspace; |
322
|
41
|
|
|
|
|
98
|
push @ts => $self->_term; |
323
|
41
|
|
|
|
|
118
|
$self->skipspace; |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
109
|
|
|
|
|
176
|
my @tsl; |
327
|
109
|
|
|
|
|
312
|
for my $j ( reverse 1 .. $#ts ) { |
328
|
150
|
|
|
|
|
664
|
$tsl[$j] = $termlist->new( $ts[$j], $tsl[ $j + 1 ] ); |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
109
|
|
|
|
|
219
|
$termlist->{term} = $ts[0]; |
332
|
109
|
|
|
|
|
231
|
$termlist->{next} = $tsl[1]; |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
else { |
336
|
58
|
|
|
|
|
116
|
$termlist->{term} = $ts[0]; |
337
|
58
|
|
|
|
|
103
|
$termlist->{next} = undef; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
401
|
50
|
|
|
|
961
|
if ( $self->current ne '.' ) { |
341
|
0
|
|
|
|
|
0
|
$self->parseerror("Expected '.' Got '@{[$self->current]}'"); |
|
0
|
|
|
|
|
0
|
|
342
|
|
|
|
|
|
|
} |
343
|
401
|
|
|
|
|
822
|
$self->advance; |
344
|
401
|
|
|
|
|
871
|
return $termlist; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
# This constructor is the simplest way to construct a term. The term is given |
348
|
|
|
|
|
|
|
# in standard notation. |
349
|
|
|
|
|
|
|
# Example: my $term = Term->new(Parser->new("p(1,a(X,b))")); |
350
|
|
|
|
|
|
|
sub _term { |
351
|
1496
|
|
|
1496
|
|
2550
|
my ($self) = @_; |
352
|
1496
|
|
|
|
|
4605
|
my $term = Term->new( undef, 0 ); |
353
|
1496
|
|
|
|
|
2590
|
my $ts = []; |
354
|
1496
|
|
|
|
|
2227
|
my $i = 0; |
355
|
|
|
|
|
|
|
|
356
|
1496
|
|
|
|
|
3085
|
$self->skipspace; # otherwise we crash when we hit leading |
357
|
|
|
|
|
|
|
# spaces |
358
|
1496
|
100
|
66
|
|
|
2871
|
if ( $self->current =~ /^[[:lower:]'"]$/ ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
359
|
692
|
|
|
|
|
1403
|
$term->{functor} = $self->getname; |
360
|
692
|
|
|
|
|
1146
|
$term->{bound} = 1; |
361
|
692
|
|
|
|
|
866
|
$term->{deref} = 0; |
362
|
|
|
|
|
|
|
|
363
|
692
|
100
|
|
|
|
2195
|
if ( '(' eq $self->current ) { |
364
|
508
|
|
|
|
|
939
|
$self->advance; |
365
|
508
|
|
|
|
|
1073
|
$self->skipspace; |
366
|
508
|
|
|
|
|
1614
|
$ts->[ $i++ ] = $self->_term; |
367
|
508
|
|
|
|
|
1079
|
$self->skipspace; |
368
|
|
|
|
|
|
|
|
369
|
508
|
|
|
|
|
1216
|
while ( ',' eq $self->current ) { |
370
|
334
|
|
|
|
|
698
|
$self->advance; |
371
|
334
|
|
|
|
|
685
|
$self->skipspace; |
372
|
334
|
|
|
|
|
811
|
$ts->[ $i++ ] = $self->_term; |
373
|
334
|
|
|
|
|
710
|
$self->skipspace; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
508
|
50
|
|
|
|
1034
|
if ( ')' ne $self->current ) { |
377
|
0
|
|
|
|
|
0
|
$self->parseerror( |
378
|
0
|
|
|
|
|
0
|
"Expecting: ')'. Got (@{[$self->current]})"); |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
508
|
|
|
|
|
1065
|
$self->advance; |
382
|
508
|
|
|
|
|
1332
|
$term->{args} = []; |
383
|
|
|
|
|
|
|
|
384
|
508
|
|
|
|
|
2484
|
$term->{args}[$_] = $ts->[$_] for 0 .. ( $i - 1 ); |
385
|
508
|
|
|
|
|
986
|
$term->{arity} = $i; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
else { |
388
|
184
|
|
|
|
|
350
|
$term->{arity} = 0; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
elsif ( $self->current =~ /^[[:upper:]]$/ ) { |
392
|
674
|
|
|
|
|
997
|
$term->{bound} = 1; |
393
|
674
|
|
|
|
|
856
|
$term->{deref} = 1; |
394
|
674
|
|
|
|
|
1257
|
my ( $ref, $string ) = $self->getvar; |
395
|
674
|
|
|
|
|
1165
|
$term->{ref} = $ref; |
396
|
674
|
|
|
|
|
1202
|
$term->{varname} = $string; |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
elsif ( '_' eq $self->current && $self->peek =~ /^[\]\|\.;\s\,\)]$/ ) { |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
# temporary hack to allow anonymous variables |
401
|
|
|
|
|
|
|
# this should really be cleaned up |
402
|
5
|
|
|
|
|
8
|
$term->{bound} = 1; |
403
|
5
|
|
|
|
|
9
|
$term->{deref} = 1; |
404
|
5
|
|
|
|
|
13
|
my ( $ref, $string ) = $self->get_anon; |
405
|
5
|
|
|
|
|
9
|
$term->{ref} = $ref; |
406
|
5
|
|
|
|
|
11
|
$term->{varname} = $string; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
elsif ( $self->current =~ /^[-.[:digit:]]$/ ) { |
409
|
75
|
|
|
|
|
158
|
return Number->new( $self->getnum ); |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
elsif ( '[' eq $self->current ) { |
412
|
23
|
|
|
|
|
52
|
$self->advance; |
413
|
|
|
|
|
|
|
|
414
|
23
|
100
|
|
|
|
51
|
if ( ']' eq $self->current ) { |
415
|
3
|
|
|
|
|
12
|
$self->advance; |
416
|
3
|
|
|
|
|
8
|
$term->{functor} = NULL; |
417
|
3
|
|
|
|
|
5
|
$term->{arity} = 0; |
418
|
3
|
|
|
|
|
7
|
$term->{bound} = 1; |
419
|
3
|
|
|
|
|
5
|
$term->{deref} = 0; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
else { |
422
|
20
|
|
|
|
|
49
|
$self->skipspace; |
423
|
20
|
|
|
|
|
103
|
$ts->[ $i++ ] = $self->_term; |
424
|
20
|
|
|
|
|
55
|
$self->skipspace; |
425
|
|
|
|
|
|
|
|
426
|
20
|
|
|
|
|
51
|
while ( ',' eq $self->current ) { |
427
|
25
|
|
|
|
|
68
|
$self->advance; |
428
|
25
|
|
|
|
|
58
|
$self->skipspace; |
429
|
25
|
|
|
|
|
67
|
$ts->[ $i++ ] = $self->_term; |
430
|
25
|
|
|
|
|
66
|
$self->skipspace; |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
20
|
100
|
|
|
|
149
|
if ( '|' eq $self->current ) { |
434
|
11
|
|
|
|
|
35
|
$self->advance; |
435
|
11
|
|
|
|
|
23
|
$self->skipspace; |
436
|
11
|
|
|
|
|
31
|
$ts->[ $i++ ] = $self->_term; |
437
|
11
|
|
|
|
|
35
|
$self->skipspace; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
else { |
440
|
9
|
|
|
|
|
36
|
$ts->[ $i++ ] = $term->new( NULL, 0 ); |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
|
443
|
20
|
50
|
|
|
|
57
|
if ( ']' ne $self->current ) { |
444
|
0
|
|
|
|
|
0
|
$self->parseerror("Expecting ']'"); |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
20
|
|
|
|
|
48
|
$self->advance; |
448
|
20
|
|
|
|
|
38
|
$term->{bound} = 1; |
449
|
20
|
|
|
|
|
32
|
$term->{deref} = 0; |
450
|
20
|
|
|
|
|
30
|
$term->{functor} = "cons"; |
451
|
20
|
|
|
|
|
43
|
$term->{arity} = 2; |
452
|
20
|
|
|
|
|
52
|
$term->{args} = []; |
453
|
20
|
|
|
|
|
76
|
for my $j ( reverse 1 .. $i - 2 ) { |
454
|
25
|
|
|
|
|
76
|
my $term = $term->new( "cons", 2 ); |
455
|
25
|
|
|
|
|
96
|
$term->setarg( 0, $ts->[$j] ); |
456
|
25
|
|
|
|
|
73
|
$term->setarg( 1, $ts->[ $j + 1 ] ); |
457
|
25
|
|
|
|
|
59
|
$ts->[$j] = $term; |
458
|
|
|
|
|
|
|
} |
459
|
20
|
|
|
|
|
55
|
$term->{args}[0] = $ts->[0]; |
460
|
20
|
|
|
|
|
45
|
$term->{args}[1] = $ts->[1]; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
elsif ( '!' eq $self->current ) { |
464
|
27
|
|
|
|
|
116
|
$self->advance; |
465
|
27
|
|
|
|
|
141
|
return $term->CUT; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
else { |
468
|
0
|
|
|
|
|
0
|
$self->parseerror( |
469
|
0
|
|
|
|
|
0
|
"Term should begin with a letter, a digit, or '[', not a @{[$self->current]}" |
470
|
|
|
|
|
|
|
); |
471
|
|
|
|
|
|
|
} |
472
|
1394
|
|
|
|
|
3914
|
return $term; |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
1; |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
__END__ |