410 |
411 | 1004
412 |
--------------------------------------------------------------------------------
/_config.yml:
--------------------------------------------------------------------------------
1 | theme: jekyll-theme-merlot
--------------------------------------------------------------------------------
/bnf2html.perl.txt:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env perl
2 | #
3 | # @(#)$Id: bnf2html.pl,v 3.16 2017/11/14 06:53:22 jleffler Exp $
4 | #
5 | # Convert SQL-92, SQL-99 BNF plain text file into hyperlinked HTML.
6 |
7 | use strict;
8 | use warnings;
9 | use POSIX qw(strftime);
10 | #use Data::Dumper;
11 |
12 | use constant debug => 0;
13 |
14 | my(%rules); # Indexed by rule names w/o angle-brackets; each entry is a ref to a hash.
15 | my(%keywords); # Index by keywords; each entry is a ref to a hash.
16 | my(%names); # Indexed by rule names w/o angle-brackets; each entry is a ref to an array of line numbers
17 |
18 | sub top
19 | {
20 | print "Top
\n\n";
21 | }
22 |
23 | # Usage: add_rule_name(\%names, $rulename, $.);
24 | sub add_rule_name
25 | {
26 | my($reflist, $lhs, $line) = @_;
27 | #print "\nrulename = $lhs; line = $line\n";
28 | if (defined ${$reflist}{$lhs})
29 | {
30 | #print Data::Dumper->Dump([ ${$reflist}{$lhs} ], qw[ ${$reflist}{$lhs} ]);
31 | #print Data::Dumper->Dump([ \@{${$reflist}{$lhs}} ], qw[ \@{${$reflist}{$lhs}} ]);
32 | my @lines = @{${$reflist}{$lhs}};
33 | print STDERR "\n$0: Rule <$lhs> at line $line already seen at line(s) ", join(", ", @lines), "\n\n";
34 | }
35 | else
36 | {
37 | ${$reflist}{$lhs} = [];
38 | }
39 | push @{${$reflist}{$lhs}}, $line;
40 | }
41 |
42 | # Usage: add_entry(\%keywords, $keyword, $rule);
43 | # Usage: add_entry(\%rules, $rhs, $rule);
44 | sub add_entry
45 | {
46 | my($reflist, $lhs, $rhs) = @_;
47 | ${$reflist}{$lhs} = {} unless defined ${$reflist}{$lhs};
48 | ${$reflist}{$lhs}{$rhs} = 1;
49 | }
50 |
51 | sub add_refs
52 | {
53 | my($def, $tail) = @_;
54 | print "\n\n" if debug;
55 | return if $tail =~ m/^!!/;
56 | return if $tail =~ m/^&(?:lt|gt|amp);$/;
57 | while ($tail)
58 | {
59 | $tail =~ s/^\s*//;
60 | if ($tail =~ m%^\<([-:/\w\s]+)\>%)
61 | {
62 | print "\n" if debug;
63 | add_entry(\%rules, $1, $def);
64 | $tail =~ s%^\<([-:/\w\s]+)\>%%;
65 | }
66 | elsif ($tail =~ m%^([-:/\w]+)%)
67 | {
68 | my($token) = $1;
69 | print "\n" if debug;
70 | add_entry(\%keywords, $token, $def) if $token =~ m%[[:alpha:]][[:alpha:]]% || $token eq 'C';
71 | $tail =~ s%^[-:/\w]+%%;
72 | }
73 | else
74 | {
75 | # Otherwise, it is punctuation (such as the BNF metacharacters).
76 | $tail =~ s%^[^-:/\w]%%;
77 | }
78 | }
79 | }
80 |
81 | # NB: webcode replaces tabs with blanks!
82 | open( my $WEBCODE, "-|", "webcode @ARGV") or die "$!";
83 |
84 | # Read first line of file - use as title in head and in H1 heading in body
85 | $_ = <$WEBCODE>;
86 | exit 0 unless defined($_);
87 | chomp;
88 |
89 | # Is it wicked to use double quoting with single quotes, as in qq'text'?
90 | # It is used quite extensively in this script - beware!
91 | print qq'\n';
92 | print "\n";
93 | print "\n\n";
94 | print " $_ \n\n\n\n";
95 | print " $_ \n\n";
96 | print qq' \n';
97 |
98 | print " Cross-Reference: rules \n';
100 | print " Cross-Reference: keywords \n';
102 | print " $quote %;
148 | print $quote;
149 | $tcount++;
150 | }
151 | elsif ($tail =~ m%^\<([-:/\w\s]+)\>%)
152 | {
153 | my($nonterm) = $&;
154 | $newtail = $';
155 | print "\n" if debug;
156 | $nonterm =~ s%\<([-:/\w\s]+)\>%\<$1\> %;
157 | print " $nonterm";
158 | $tcount++;
159 | }
160 | elsif ($tail =~ m%^[\w_]([-._\w]*[\w_])?%)
161 | {
162 | # Keyword
163 | my($keyword) = $&;
164 | $newtail = $';
165 | print "\n" if debug;
166 | print(($keyword =~ m/^\d\d+$/) ? $keyword : qq' $keyword ');
167 | $tcount++;
168 | }
169 | else
170 | {
171 | # Metacharacter, string literal, etc.
172 | $tail =~ m%\S+%;
173 | my($symbol) = $&;
174 | $newtail = $';
175 | print "\n" if debug;
176 | if ($symbol eq '|')
177 | {
178 | print "/* Nothing */ " if $tcount == 0;
179 | $tcount = 0;
180 | }
181 | else
182 | {
183 | $symbol =~ s%...omitted...%/* $& */ %i;
184 | $tcount++;
185 | }
186 | print " $symbol";
187 | }
188 | $tail = $newtail;
189 | }
190 | return($tcount);
191 | }
192 |
193 | sub undo_web_coding
194 | {
195 | my($line) = @_;
196 | $line =~ s%>%>%g;
197 | $line =~ s%<%<%g;
198 | $line =~ s%&%&%g;
199 | return $line;
200 | }
201 |
202 | my $hr_count = 0;
203 | my $tcount = 0; # Ick!
204 | my $def; # Current rule
205 |
206 | # Don't forget - the input has been web-encoded!
207 |
208 | while (<$WEBCODE>)
209 | {
210 | chomp;
211 | next if /^===*$/o;
212 | s/\s+$//o; # Remove trailing white space
213 | if (/^$/)
214 | {
215 | print "\n";
216 | }
217 | elsif (/^---*$/)
218 | {
219 | print "\n";
233 | print "Derived from $v1\n";
234 | my $today = iso8601_format(time);
235 | print "
\n";
238 | }
239 | elsif (/\s+::=/)
240 | {
241 | # Definition line
242 | $def = $_;
243 | $def =~ s%\<([-:/()\w\s]+)\>.*%$1%;
244 | my($tail) = $_;
245 | $tail =~ s%.*::=\s*%%;
246 | print qq' <$def> ::=';
247 | $tcount = 0;
248 | add_rule_name(\%names, $def, $.);
249 | if ($def eq "vertical bar")
250 | {
251 | # Needs special case attention to avoid a /* Nothing */ comment appearing.
252 | # Problem pointed out by Jens Odborg (jho1965us@gmail.com) 2016-04-14.
253 | # This builds knowledge of the SQL language definition into this script;
254 | # ugly, but trying to fix it in the print_tail function is probably worse.
255 | print " |";
256 | }
257 | elsif ($tail)
258 | {
259 | add_refs($def, $tail);
260 | print " ";
261 | $tcount = print_tail($tail, $tcount);
262 | }
263 | print "\n";
264 | }
265 | elsif (/^\s/)
266 | {
267 | # Expansion line
268 | add_refs($def, $_);
269 | print "
\<$1\> %g;
279 | print "$_\n";
280 | }
281 | elsif (m%^--##%)
282 | {
283 | $_ = undo_web_coding($_);
284 | s%^--##\s*%%;
285 | print "$_\n";
286 | }
287 | elsif (m/^--%start\s+(\w+)/)
288 | {
289 | # Designated start symbol
290 | my $start = $1;
291 | print qq'Start symbol: $start
\n';
292 | }
293 | else
294 | {
295 | # Anything unrecognized passed through unchanged!
296 | print "$_\n";
297 | }
298 | }
299 |
300 | close $WEBCODE;
301 |
302 | # Print index of initial letters for keywords.
303 | sub print_index_key
304 | {
305 | my($prefix, @keys) = @_;
306 | my %letters = ();
307 | foreach my $keyword (@keys)
308 | {
309 | my $initial = uc substr $keyword, 0, 1;
310 | $letters{$initial} = 1;
311 | }
312 | foreach my $letter ('A' .. 'Z')
313 | {
314 | if (defined($letters{$letter}))
315 | {
316 | print qq' $letter \n';
317 | }
318 | else
319 | {
320 | print qq'$letter\n';
321 | }
322 | }
323 | print "\n";
324 | }
325 |
326 | ### Generate cross-reference tables
327 |
328 | {
329 | print " Cross-Reference Table: Rules \n";
333 |
334 | print_index_key("rules", keys %rules);
335 |
336 | print "\n";
337 | print " Rule (non-terminal) Rules using it \n";
338 | my %letters = ();
339 |
340 | foreach my $rule (sort { uc $a cmp uc $b } keys %rules)
341 | {
342 | my $initial = uc substr $rule, 0, 1;
343 | my $label = "";
344 | if (!defined($letters{$initial}))
345 | {
346 | $letters{$initial} = 1;
347 | $label = qq' ';
348 | }
349 | print qq' $label $rule \n ';
350 | my $pad = "";
351 | foreach my $ref (sort { uc $a cmp uc $b } keys %{$rules{$rule}})
352 | {
353 | print qq'$pad <$ref> \n';
354 | $pad = " ";
355 | }
356 | print " \n \n";
357 | }
358 | print "
\n";
359 | print " Cross-Reference Table: Keywords \n";
367 |
368 | print_index_key("keywords", keys %keywords);
369 |
370 | print "\n";
371 | print " Keyword Rules using it \n";
372 | my %letters = ();
373 | foreach my $keyword (sort { uc $a cmp uc $b } keys %keywords)
374 | {
375 | my $initial = uc substr $keyword, 0, 1;
376 | my $label = "";
377 | if (!defined($letters{$initial}))
378 | {
379 | $letters{$initial} = 1;
380 | $label = qq' ';
381 | }
382 | print qq' $label $keyword \n ';
383 | my $pad = "";
384 | foreach my $ref (sort { uc $a cmp uc $b } keys %{$keywords{$keyword}})
385 | {
386 | print qq'$pad <$ref> \n';
387 | $pad = " ";
388 | }
389 | print " \n \n";
390 | }
391 | print "
\n";
392 | print " jonathan.leffler@gmail.com .';
399 |
400 | print "\n\n\n";
401 |
402 | __END__
403 |
404 | =pod
405 |
406 | =head1 PROGRAM
407 |
408 | bnf2html - Convert (ISO SQL) BNF Notation to Hyperlinked HTML
409 |
410 | =head1 SYNTAX
411 |
412 | bnf2html [file ...]
413 |
414 | =head1 DESCRIPTION
415 |
416 | The bnf2html filters the annotated BNF (Backus-Naur Form) from its input
417 | files and converts it into HTML on standard output.
418 |
419 | The HTML is heavily hyperlinked.
420 | Each rule (LHS) links to a table of other rules where it is used on the
421 | RHS.
422 | Similarly, each symbol on the RHS is linked to the rule that defines it.
423 | Thus, it is possible to find where items are used and defined quite
424 | easily.
425 |
426 | =head1 INPUT FORMAT
427 |
428 | This script is adapted to the BNF notation using in the SQL standard
429 | (ISO/IEC 9075:2003, for example).
430 | It also takes various forms of annotations.
431 |
432 | The first line of the file is used as the title in the head section.
433 | It is also used as the text for a H1 header at the top of the body.
434 |
435 | Lines consisting of two or more equal signs are ignored.
436 |
437 | Lines consisting of two or more dashes are converted to a horizontal
438 | rule.
439 |
440 | Lines starting with the SCCS identification string '@(#)' are used to
441 | print version information about the file converted and the script doing
442 | the converting.
443 |
444 | Lines containing space, colon, colon, equals are treated as rules.
445 |
446 | Lines starting with white space are treated as continuations of a rule.
447 |
448 | Lines starting dash, dash, (optionally a slash) and then one or more tag
449 | letters are converted into an HTML start or end tag.
450 |
451 | Any line starting dash, dash, hash, hash has any HTML entities
452 | introduced by the WEBCODE program removed.
453 |
454 | The should be at most one line starting '--%start'; this indicates the
455 | start symbol for the bnf2yacc converter, but is effectively ignored by
456 | bnf2html.
457 |
458 | Any other line is passed through verbatim.
459 |
460 | =head1 AUTHOR
461 |
462 | Jonathan Leffler
463 |
464 | =cut
465 |
--------------------------------------------------------------------------------
/bnf2html.pl:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env perl
2 | #
3 | # @(#)$Id: bnf2html.pl,v 3.16 2017/11/14 06:53:22 jleffler Exp $
4 | #
5 | # Convert SQL-92, SQL-99 BNF plain text file into hyperlinked HTML.
6 |
7 | use strict;
8 | use warnings;
9 | use POSIX qw(strftime);
10 | #use Data::Dumper;
11 |
12 | use constant debug => 0;
13 |
14 | my(%rules); # Indexed by rule names w/o angle-brackets; each entry is a ref to a hash.
15 | my(%keywords); # Index by keywords; each entry is a ref to a hash.
16 | my(%names); # Indexed by rule names w/o angle-brackets; each entry is a ref to an array of line numbers
17 |
18 | sub top
19 | {
20 | print "Top
\n\n";
21 | }
22 |
23 | # Usage: add_rule_name(\%names, $rulename, $.);
24 | sub add_rule_name
25 | {
26 | my($reflist, $lhs, $line) = @_;
27 | #print "\nrulename = $lhs; line = $line\n";
28 | if (defined ${$reflist}{$lhs})
29 | {
30 | #print Data::Dumper->Dump([ ${$reflist}{$lhs} ], qw[ ${$reflist}{$lhs} ]);
31 | #print Data::Dumper->Dump([ \@{${$reflist}{$lhs}} ], qw[ \@{${$reflist}{$lhs}} ]);
32 | my @lines = @{${$reflist}{$lhs}};
33 | print STDERR "\n$0: Rule <$lhs> at line $line already seen at line(s) ", join(", ", @lines), "\n\n";
34 | }
35 | else
36 | {
37 | ${$reflist}{$lhs} = [];
38 | }
39 | push @{${$reflist}{$lhs}}, $line;
40 | }
41 |
42 | # Usage: add_entry(\%keywords, $keyword, $rule);
43 | # Usage: add_entry(\%rules, $rhs, $rule);
44 | sub add_entry
45 | {
46 | my($reflist, $lhs, $rhs) = @_;
47 | ${$reflist}{$lhs} = {} unless defined ${$reflist}{$lhs};
48 | ${$reflist}{$lhs}{$rhs} = 1;
49 | }
50 |
51 | sub add_refs
52 | {
53 | my($def, $tail) = @_;
54 | print "\n\n" if debug;
55 | return if $tail =~ m/^!!/;
56 | return if $tail =~ m/^&(?:lt|gt|amp);$/;
57 | while ($tail)
58 | {
59 | $tail =~ s/^\s*//;
60 | if ($tail =~ m%^\<([-:/\w\s]+)\>%)
61 | {
62 | print "\n" if debug;
63 | add_entry(\%rules, $1, $def);
64 | $tail =~ s%^\<([-:/\w\s]+)\>%%;
65 | }
66 | elsif ($tail =~ m%^([-:/\w]+)%)
67 | {
68 | my($token) = $1;
69 | print "\n" if debug;
70 | add_entry(\%keywords, $token, $def) if $token =~ m%[[:alpha:]][[:alpha:]]% || $token eq 'C';
71 | $tail =~ s%^[-:/\w]+%%;
72 | }
73 | else
74 | {
75 | # Otherwise, it is punctuation (such as the BNF metacharacters).
76 | $tail =~ s%^[^-:/\w]%%;
77 | }
78 | }
79 | }
80 |
81 | # NB: webcode replaces tabs with blanks!
82 | open( my $WEBCODE, "-|", "webcode @ARGV") or die "$!";
83 |
84 | # Read first line of file - use as title in head and in H1 heading in body
85 | $_ = <$WEBCODE>;
86 | exit 0 unless defined($_);
87 | chomp;
88 |
89 | # Is it wicked to use double quoting with single quotes, as in qq'text'?
90 | # It is used quite extensively in this script - beware!
91 | print qq'\n';
92 | print "\n";
93 | print "\n\n";
94 | print " $_ \n\n\n\n";
95 | print " $_ \n\n";
96 | print qq' \n';
97 |
98 | print " Cross-Reference: rules \n';
100 | print " Cross-Reference: keywords \n';
102 | print " $quote %;
148 | print $quote;
149 | $tcount++;
150 | }
151 | elsif ($tail =~ m%^\<([-:/\w\s]+)\>%)
152 | {
153 | my($nonterm) = $&;
154 | $newtail = $';
155 | print "\n" if debug;
156 | $nonterm =~ s%\<([-:/\w\s]+)\>%\<$1\> %;
157 | print " $nonterm";
158 | $tcount++;
159 | }
160 | elsif ($tail =~ m%^[\w_]([-._\w]*[\w_])?%)
161 | {
162 | # Keyword
163 | my($keyword) = $&;
164 | $newtail = $';
165 | print "\n" if debug;
166 | print(($keyword =~ m/^\d\d+$/) ? $keyword : qq' $keyword ');
167 | $tcount++;
168 | }
169 | else
170 | {
171 | # Metacharacter, string literal, etc.
172 | $tail =~ m%\S+%;
173 | my($symbol) = $&;
174 | $newtail = $';
175 | print "\n" if debug;
176 | if ($symbol eq '|')
177 | {
178 | print "/* Nothing */ " if $tcount == 0;
179 | $tcount = 0;
180 | }
181 | else
182 | {
183 | $symbol =~ s%...omitted...%/* $& */ %i;
184 | $tcount++;
185 | }
186 | print " $symbol";
187 | }
188 | $tail = $newtail;
189 | }
190 | return($tcount);
191 | }
192 |
193 | sub undo_web_coding
194 | {
195 | my($line) = @_;
196 | $line =~ s%>%>%g;
197 | $line =~ s%<%<%g;
198 | $line =~ s%&%&%g;
199 | return $line;
200 | }
201 |
202 | my $hr_count = 0;
203 | my $tcount = 0; # Ick!
204 | my $def; # Current rule
205 |
206 | # Don't forget - the input has been web-encoded!
207 |
208 | while (<$WEBCODE>)
209 | {
210 | chomp;
211 | next if /^===*$/o;
212 | s/\s+$//o; # Remove trailing white space
213 | if (/^$/)
214 | {
215 | print "\n";
216 | }
217 | elsif (/^---*$/)
218 | {
219 | print "\n";
233 | print "Derived from $v1\n";
234 | my $today = iso8601_format(time);
235 | print "
\n";
238 | }
239 | elsif (/\s+::=/)
240 | {
241 | # Definition line
242 | $def = $_;
243 | $def =~ s%\<([-:/()\w\s]+)\>.*%$1%;
244 | my($tail) = $_;
245 | $tail =~ s%.*::=\s*%%;
246 | print qq' <$def> ::=';
247 | $tcount = 0;
248 | add_rule_name(\%names, $def, $.);
249 | if ($def eq "vertical bar")
250 | {
251 | # Needs special case attention to avoid a /* Nothing */ comment appearing.
252 | # Problem pointed out by Jens Odborg (jho1965us@gmail.com) 2016-04-14.
253 | # This builds knowledge of the SQL language definition into this script;
254 | # ugly, but trying to fix it in the print_tail function is probably worse.
255 | print " |";
256 | }
257 | elsif ($tail)
258 | {
259 | add_refs($def, $tail);
260 | print " ";
261 | $tcount = print_tail($tail, $tcount);
262 | }
263 | print "\n";
264 | }
265 | elsif (/^\s/)
266 | {
267 | # Expansion line
268 | add_refs($def, $_);
269 | print "
\<$1\> %g;
279 | print "$_\n";
280 | }
281 | elsif (m%^--##%)
282 | {
283 | $_ = undo_web_coding($_);
284 | s%^--##\s*%%;
285 | print "$_\n";
286 | }
287 | elsif (m/^--%start\s+(\w+)/)
288 | {
289 | # Designated start symbol
290 | my $start = $1;
291 | print qq'Start symbol: $start
\n';
292 | }
293 | else
294 | {
295 | # Anything unrecognized passed through unchanged!
296 | print "$_\n";
297 | }
298 | }
299 |
300 | close $WEBCODE;
301 |
302 | # Print index of initial letters for keywords.
303 | sub print_index_key
304 | {
305 | my($prefix, @keys) = @_;
306 | my %letters = ();
307 | foreach my $keyword (@keys)
308 | {
309 | my $initial = uc substr $keyword, 0, 1;
310 | $letters{$initial} = 1;
311 | }
312 | foreach my $letter ('A' .. 'Z')
313 | {
314 | if (defined($letters{$letter}))
315 | {
316 | print qq' $letter \n';
317 | }
318 | else
319 | {
320 | print qq'$letter\n';
321 | }
322 | }
323 | print "\n";
324 | }
325 |
326 | ### Generate cross-reference tables
327 |
328 | {
329 | print " Cross-Reference Table: Rules \n";
333 |
334 | print_index_key("rules", keys %rules);
335 |
336 | print "\n";
337 | print " Rule (non-terminal) Rules using it \n";
338 | my %letters = ();
339 |
340 | foreach my $rule (sort { uc $a cmp uc $b } keys %rules)
341 | {
342 | my $initial = uc substr $rule, 0, 1;
343 | my $label = "";
344 | if (!defined($letters{$initial}))
345 | {
346 | $letters{$initial} = 1;
347 | $label = qq' ';
348 | }
349 | print qq' $label $rule \n ';
350 | my $pad = "";
351 | foreach my $ref (sort { uc $a cmp uc $b } keys %{$rules{$rule}})
352 | {
353 | print qq'$pad <$ref> \n';
354 | $pad = " ";
355 | }
356 | print " \n \n";
357 | }
358 | print "
\n";
359 | print " Cross-Reference Table: Keywords \n";
367 |
368 | print_index_key("keywords", keys %keywords);
369 |
370 | print "\n";
371 | print " Keyword Rules using it \n";
372 | my %letters = ();
373 | foreach my $keyword (sort { uc $a cmp uc $b } keys %keywords)
374 | {
375 | my $initial = uc substr $keyword, 0, 1;
376 | my $label = "";
377 | if (!defined($letters{$initial}))
378 | {
379 | $letters{$initial} = 1;
380 | $label = qq' ';
381 | }
382 | print qq' $label $keyword \n ';
383 | my $pad = "";
384 | foreach my $ref (sort { uc $a cmp uc $b } keys %{$keywords{$keyword}})
385 | {
386 | print qq'$pad <$ref> \n';
387 | $pad = " ";
388 | }
389 | print " \n \n";
390 | }
391 | print "
\n";
392 | print " jonathan.leffler@gmail.com .';
399 |
400 | print "\n\n\n";
401 |
402 | __END__
403 |
404 | =pod
405 |
406 | =head1 PROGRAM
407 |
408 | bnf2html - Convert (ISO SQL) BNF Notation to Hyperlinked HTML
409 |
410 | =head1 SYNTAX
411 |
412 | bnf2html [file ...]
413 |
414 | =head1 DESCRIPTION
415 |
416 | The bnf2html filters the annotated BNF (Backus-Naur Form) from its input
417 | files and converts it into HTML on standard output.
418 |
419 | The HTML is heavily hyperlinked.
420 | Each rule (LHS) links to a table of other rules where it is used on the
421 | RHS.
422 | Similarly, each symbol on the RHS is linked to the rule that defines it.
423 | Thus, it is possible to find where items are used and defined quite
424 | easily.
425 |
426 | =head1 INPUT FORMAT
427 |
428 | This script is adapted to the BNF notation using in the SQL standard
429 | (ISO/IEC 9075:2003, for example).
430 | It also takes various forms of annotations.
431 |
432 | The first line of the file is used as the title in the head section.
433 | It is also used as the text for a H1 header at the top of the body.
434 |
435 | Lines consisting of two or more equal signs are ignored.
436 |
437 | Lines consisting of two or more dashes are converted to a horizontal
438 | rule.
439 |
440 | Lines starting with the SCCS identification string '@(#)' are used to
441 | print version information about the file converted and the script doing
442 | the converting.
443 |
444 | Lines containing space, colon, colon, equals are treated as rules.
445 |
446 | Lines starting with white space are treated as continuations of a rule.
447 |
448 | Lines starting dash, dash, (optionally a slash) and then one or more tag
449 | letters are converted into an HTML start or end tag.
450 |
451 | Any line starting dash, dash, hash, hash has any HTML entities
452 | introduced by the WEBCODE program removed.
453 |
454 | The should be at most one line starting '--%start'; this indicates the
455 | start symbol for the bnf2yacc converter, but is effectively ignored by
456 | bnf2html.
457 |
458 | Any other line is passed through verbatim.
459 |
460 | =head1 AUTHOR
461 |
462 | Jonathan Leffler
463 |
464 | =cut
465 |
--------------------------------------------------------------------------------
/bnf2yacc.perl.txt:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -w
2 | #
3 | # @(#)$Id: bnf2yacc.pl,v 1.16 2017/11/14 06:53:22 jleffler Exp $
4 | #
5 | # Convert SQL-92, SQL-99 BNF plain text file into YACC grammar.
6 |
7 | use strict;
8 | $| = 1;
9 |
10 | use constant debug => 0;
11 |
12 | my $heading = "";
13 | my %tokens;
14 | my %nonterminals;
15 | my %rules;
16 | my %used;
17 | my $start;
18 | my @grammar;
19 |
20 | my $nt_number = 0;
21 |
22 | # Generate a new non-terminal identifier
23 | sub new_non_terminal
24 | {
25 | my($prefix) = @_;
26 | $prefix = "" unless defined $prefix;
27 | return sprintf "${prefix}nt_%03d", ++$nt_number;
28 | }
29 |
30 | # map_non_terminal converts names that are not acceptable to Yacc into names that are.
31 | # Non-identifier characters are converted to underscores.
32 | # If the first character is not alphabetic, prefix 'j_'.
33 | # Case-convert to lower case.
34 | sub map_non_terminal
35 | {
36 | my($nt) = @_;
37 | $nt =~ s/\W+/_/go;
38 | $nt = "j_$nt" unless $nt =~ m/^[a-zA-Z]/o;
39 | $nt =~ tr/[A-Z]/[a-z]/;
40 | $nt =~ s/__+/_/go;
41 | return $nt;
42 | }
43 |
44 | # scan_rhs breaks up the RHS of a rule into a token stream
45 | # Keywords (terminals) are prefixed with a '#' marker.
46 | sub scan_rhs
47 | {
48 | my($tail) = @_;
49 | my(@rhs);
50 | while ($tail)
51 | {
52 | print "RHS: $tail\n" if debug;
53 | my $name;
54 | if ($tail =~ m%^(\s*<([-:/()_\w\s]+)>\s*)%o)
55 | {
56 | # Simpler regex for non-terminal: <[^>]+>
57 | # Non-terminal
58 | my $n = $2;
59 | print "N: $n\n" if debug;
60 | $tail = substr $tail, length($1);
61 | $name = map_non_terminal($n);
62 | $nonterminals{$name} = 1;
63 | $used{$name} = 1;
64 | push @rhs, $name;
65 | }
66 | elsif ($tail =~ m%^(\s*(\w[-\w\d_.]*)\s*)%o)
67 | {
68 | # Terminal (keyword)
69 | # Dot '.' is used in Interfaces.SQL in Ada syntax
70 | # Dash '-' is used in EXEC-SQL in the keywords.
71 | my $t = $2;
72 | print "T: $t\n" if debug;
73 | $tail = substr $tail, length($1);
74 | $name = $t;
75 | $tokens{$name} = 1;
76 | push @rhs, "#$name";
77 | }
78 | elsif ($tail =~ m%^\s*(\.\.\.omitted\.\.\.)\s*%o)
79 | {
80 | # Something omitted from the grammar.
81 | # Triple punctuation detected before double.
82 | my $str = "/* $1 */";
83 | push @rhs, $str;
84 | last;
85 | }
86 | elsif ($tail =~ m{^(\s*([-.<=>|]{2})\s*)$}o)
87 | {
88 | # Double-punctuation (non-metacharacters)
89 | # .., <=, >=, <>, ||, ->
90 | my $p = $2;
91 | print "DP: $p\n" if debug;
92 | $tail = substr $tail, length($1);
93 | $name = "'$p'";
94 | push @rhs, $name;
95 | }
96 | elsif ($tail =~ m{^(\s*([][{}"'%&()*+,-./:;<=>?^_|])\s*)$}o)
97 | {
98 | # Punctuation (non-metacharacters)
99 | # Note that none of '@', '~', '!' or '\' have any significance in SQL
100 | my $p = $2;
101 | print "P: $p\n" if debug;
102 | $tail = substr $tail, length($1);
103 | $p = "\\'" if $p eq "'";
104 | $name = "'$p'";
105 | push @rhs, $name;
106 | }
107 | elsif ($tail =~ m%^(\s*('[^']*'))\s*%o ||
108 | $tail =~ m%^(\s*("[^"]*"))\s*%o)
109 | {
110 | # Terminal in quotes - single or double.
111 | # (Possibly a multi-character string).
112 | my $q = $2;
113 | print "Q: $q\n" if debug;
114 | $tail = substr $tail, length($1);
115 | $q =~ m%^(['"])(.+)['"]$%o;
116 | # Expand multi-character string constants.
117 | # into repeated single-character constants.
118 | my($o) = $1;
119 | my($l) = $2;
120 | while (length($l))
121 | {
122 | my($c) = substr $l, 0, 1;
123 | $name = "$o$c$o";
124 | $l = substr $l, 1, length($l)-1;
125 | push @rhs, $name;
126 | }
127 | }
128 | elsif ($tail =~ m%^(\s*([{}\|\[\]]|\.\.\.)\s*)%o)
129 | {
130 | # Punctuation (metacharacters)
131 | my $p = $2;
132 | print "M: $p\n" if debug;
133 | $tail = substr $tail, length($1);
134 | $name = $p;
135 | push @rhs, $name;
136 | }
137 | elsif ($tail =~ m%^\s*!!%o)
138 | {
139 | # Exhortation to see the syntax rules - usually.
140 | my $str = "/* $tail */";
141 | push @rhs, $str;
142 | last;
143 | }
144 | else
145 | {
146 | # Unknown!
147 | print "/* UNK: $tail */\n";
148 | print STDERR "UNK:$.: $tail\n";
149 | last;
150 | }
151 | }
152 | return(@rhs);
153 | }
154 |
155 | # Format a Yacc rule given LHS and RHS array
156 | sub record_rule
157 | {
158 | my($lhs, $comment, @rule) = @_;
159 | my($production) = "";
160 | print "==>> record_rule ($lhs : @rule)\n" if debug;
161 | $production .= "/*\n" if $comment;
162 | $production .= "$lhs\n\t:\t";
163 | my $pad = "";
164 | my $br_count = 0;
165 | for (my $i = 0; $i <= $#rule; $i++)
166 | {
167 | my $item = $rule[$i];
168 | print "==== item $item\n" if debug;
169 | if ($item eq "|" && $br_count == 0)
170 | {
171 | $production .= "\n\t|\t";
172 | $pad = "";
173 | }
174 | else
175 | {
176 | $production .= "$pad$item";
177 | $pad = " ";
178 | $br_count++ if ($item eq '[' or $item eq '{');
179 | $br_count-- if ($item eq ']' or $item eq '}');
180 | }
181 | }
182 | $production .= "\n\t;\n";
183 | $production .= "*/\n" if $comment;
184 | $production .= "\n";
185 | print "$production" if debug;
186 | push @grammar, $production;
187 | print "<<== record_rule\n" if debug;
188 | }
189 |
190 | sub print_iterator
191 | {
192 | my($lhs,$rhs) = @_;
193 | my($production) = "";
194 | print "==>> print_iterator ($lhs $rhs)\n" if debug;
195 | $production .= "$lhs\n\t:\t$rhs\n\t|\t$lhs $rhs\n\t;\n\n";
196 | print "<<== print_iterator\n" if debug;
197 | push @grammar, $production;
198 | }
199 |
200 | # Process an optional item enclosed in square brackets
201 | sub find_balanced_bracket
202 | {
203 | my($lhs,@rhs) = @_;
204 | my(@rule) = ( "/* Nothing */", "|");
205 | print "==>> find_balanced_bracket ($lhs : @rhs)\n" if debug;
206 | while (my $name = shift @rhs)
207 | {
208 | print " name = $name\n" if debug;
209 | if ($name eq ']')
210 | {
211 | # Found closing bracket
212 | # Terminate search
213 | last;
214 | }
215 | elsif ($name eq '[')
216 | {
217 | # Found nested optional clause
218 | my $tag = new_non_terminal('opt_');
219 | @rhs = find_balanced_bracket($tag, @rhs);
220 | push @rule, $tag;
221 | }
222 | elsif ($name eq '{')
223 | {
224 | # Found start of sequence
225 | my $tag = new_non_terminal('seq_');
226 | @rhs = find_balanced_brace($tag, @rhs);
227 | push @rule, $tag;
228 | }
229 | elsif ($name eq '}')
230 | {
231 | # Found unbalanced close brace.
232 | # Error!
233 | }
234 | elsif ($name eq '...')
235 | {
236 | # Found iteration.
237 | my $tag = new_non_terminal('lst_');
238 | print "==== find_balanced_bracket: iterator (@rule)\n" if debug;
239 | my($old) = pop @rule;
240 | push @rule, $tag;
241 | print "==== find_balanced_bracket: iterator ($tag/$old - @rule)\n" if debug;
242 | print_iterator($tag, $old);
243 | }
244 | else
245 | {
246 | $name =~ s/^#//;
247 | push @rule, $name;
248 | $used{$name} = 1;
249 | }
250 | }
251 | record_rule($lhs, 0, @rule);
252 | print "<<== find_balanced_bracket: @rhs)\n" if debug;
253 | return(@rhs);
254 | }
255 |
256 | # Process an sequence item enclosed in curly braces
257 | sub find_balanced_brace
258 | {
259 | my($lhs,@rhs) = @_;
260 | my(@rule);
261 | print "==>> find_balanced_brace ($lhs : @rhs)\n" if debug;
262 | while (my $name = shift @rhs)
263 | {
264 | print " name = $name\n" if debug;
265 | if ($name eq '}')
266 | {
267 | # Found closing brace
268 | # Terminate search
269 | last;
270 | }
271 | elsif ($name eq '[')
272 | {
273 | # Found nested optional clause
274 | my $tag = new_non_terminal('opt_');
275 | @rhs = find_balanced_bracket($tag, @rhs);
276 | push @rule, $tag;
277 | }
278 | elsif ($name eq '{')
279 | {
280 | # Found start of sequence
281 | my $tag = new_non_terminal('seq_');
282 | @rhs = find_balanced_brace($tag, @rhs);
283 | push @rule, $tag;
284 | }
285 | elsif ($name eq ']')
286 | {
287 | # Found unbalanced close brace.
288 | # Error!
289 | }
290 | elsif ($name eq '...')
291 | {
292 | # Found iteration.
293 | my $tag = new_non_terminal('lst_');
294 | print "==== find_balanced_brace: iterator (@rule)\n" if debug;
295 | my($old) = pop @rule;
296 | push @rule, $tag;
297 | print "==== find_balanced_brace: iterator ($tag/$old - @rule)\n" if debug;
298 | print_iterator($tag, $old);
299 | }
300 | else
301 | {
302 | $name =~ s/^#//;
303 | push @rule, $name;
304 | $used{$name} = 1;
305 | }
306 | }
307 | record_rule($lhs, 0, @rule);
308 | print "<<== find_balanced_brace: @rhs)\n" if debug;
309 | return(@rhs);
310 | }
311 |
312 | # Note that the [ and { parts are nice and easy because they are
313 | # balanced operators. The iteration operator ... is much harder to
314 | # process because it is a trailing modifier. When processing the list
315 | # of symbols, you need to establish whether there is a trailing iterator
316 | # after the current symbol, and modify the behaviour appropriately.
317 | sub process_rhs
318 | {
319 | my($lhs, $tail) = @_;
320 | my(@rhs) = scan_rhs($tail);
321 | print "==>> process_rhs ($lhs : @rhs)\n" if debug;
322 | # List parsed rule in output only if debugging.
323 | record_rule($lhs, 1, @rhs) if debug;
324 | my(@rule);
325 | while (my $name = shift @rhs)
326 | {
327 | print "name = $name\n" if debug;
328 | if ($name eq '[')
329 | {
330 | my $tag = new_non_terminal('opt_');
331 | @rhs = find_balanced_bracket($tag, @rhs);
332 | push @rule, $tag;
333 | }
334 | elsif ($name eq ']')
335 | {
336 | # Found a close bracket for something unbalanced.
337 | # Error!
338 | }
339 | elsif ($name eq '{')
340 | {
341 | # Start of mandatory sequence of items, possibly containing alternatives.
342 | my $tag = new_non_terminal('seq_');
343 | @rhs = find_balanced_brace($tag, @rhs);
344 | push @rule, $tag;
345 | }
346 | elsif ($name eq '}')
347 | {
348 | # Found a close brace for something unbalanced.
349 | # Error!
350 | }
351 | elsif ($name eq '|')
352 | {
353 | # End of one alternative and start of a new one.
354 | print "==== process_rhs: alternative $name\n" if debug;
355 | push @rule, $name;
356 | }
357 | elsif ($name eq '...')
358 | {
359 | # Found iteration.
360 | my $tag = new_non_terminal('lst_');
361 | my($old) = pop @rule;
362 | push @rule, $tag;
363 | print "==== process_rhs: iterator\n" if debug;
364 | print_iterator($tag, $old);
365 | }
366 | elsif ($name =~ m/^#/)
367 | {
368 | # Keyword token
369 | print "==== process_rhs: token $name\n" if debug;
370 | $name =~ s/^#//;
371 | push @rule, $name;
372 | }
373 | else
374 | {
375 | # Non-terminal (or comment)
376 | print "==== process_rhs: non-terminal $name\n" if debug;
377 | push @rule, $name;
378 | }
379 | }
380 | print "==== process_rhs: @rule\n" if debug;
381 | record_rule($lhs, 0, @rule);
382 | print "<<== process_rhs\n" if debug;
383 | }
384 |
385 | sub count_unmatched_keys
386 | {
387 | my($ref1, $ref2) = @_;
388 | my(%keys) = %$ref1;
389 | my(%match) = %$ref2;
390 | my($count) = 0;
391 | foreach my $key (keys %keys)
392 | {
393 | $count++ unless defined $match{$key};
394 | }
395 | return $count;
396 | }
397 |
398 | # ------------------------------------------------------------
399 |
400 | open INPUT, "cat @ARGV |" or die "$!";
401 | $_ = ::=
646 |
647 |
648 |
649 | [ ]
650 | [ ]
651 | [ ... ]
652 | ...
653 |
654 | SQL_client_module_definition
655 | : module_name_clause language_clause module_authorization_clause opt_nt_0001 opt_nt_0002 opt_nt_0003 lst_nt_0004
656 | ;
657 | opt_nt_0001
658 | : /* Nothing */
659 | | module_path_specification
660 | ;
661 | opt_nt_0002
662 | : /* Nothing */
663 | | module_transform_group_specification
664 | ;
665 | opt_nt_0003
666 | : /* Nothing */
667 | | lst_nt_0005
668 | ;
669 | lst_nt_0004
670 | : module_contents
671 | | lst_nt_0004 module_contents
672 | ;
673 | lst_nt_0005
674 | : temporary_table_declaration
675 | | lst_nt_0005 temporary_table_declaration
676 | ;
677 |
678 | The next example is interesting - it is fairly typical of the grammar,
679 | but is not minimal. The rule could be written ' ::=
680 | [ ... ]' without altering the
681 | meaning. It is not clear whether this program should apply this
682 | transformation automatically.
683 |
684 | ::= [ { }... ]
685 |
686 | identifier_body
687 | : identifier_start opt_nt_0006
688 | ;
689 | opt_nt_0006
690 | : /* Nothing */
691 | | lst_nt_0007
692 | ;
693 | lst_nt_0007
694 | : seq_nt_0008
695 | | lst_nt_0007 seq_nt_0008
696 | ;
697 | seq_nt_0008
698 | : identifier_part
699 | ;
700 |
701 | /* Optimized alternative to lst_nt_0007 */
702 | lst_nt_0007
703 | : identifier_part
704 | | lst_nt_0007 identifier_part
705 | ;
706 |
707 | ::=
708 | [ { | }... ]
709 |
710 | sql_language_identifier
711 | : sql_language_identifier_start opt_nt_0009
712 | ;
713 | opt_nt_0009
714 | : /* Nothing */
715 | | lst_nt_0010
716 | ;
717 | lst_nt_0010
718 | : seq_nt_0011
719 | | lst_nt_0010 seq_nt_0011
720 | ;
721 | seq_nt_0011
722 | : underscore
723 | | sql_language_identifier_part
724 | ;
725 |
726 | The next rule is the first example with keywords.
727 |
728 | ::=
729 | SCHEMA
730 | | AUTHORIZATION
731 | | SCHEMA AUTHORIZATION
732 |
733 | module_authorization_clause
734 | : SCHEMA schema_name
735 | | AUTHORIZATION module_authorization_identifier
736 | | SCHEMA schema_name AUTHORIZATION module_authorization_identifier
737 | ;
738 |
739 | ::=
740 | TRANSFORM GROUP { | }
741 |
742 | transform_group_specification
743 | : TRANSFORM GROUP seq_nt_0012
744 | ;
745 | seq_nt_0012
746 | : single_group_specification
747 | | multiple_group_specification
748 | ;
749 |
750 | ::= [ { }... ]
751 |
752 | multiple_group_specification
753 | : group_specification opt_nt_0013
754 | ;
755 | opt_nt_0013
756 | : /* Nothing */
757 | | lst_nt_0014
758 | ;
759 | lst_nt_0014
760 | : seq_nt_0015
761 | | lst_nt_0014 seq_nt_0015
762 | ;
763 | seq_nt_0015
764 | : comma group_specification
765 | ;
766 |
767 | Except for the presence of a token () after the optional
768 | list, the next example is equivalent to the previous one. It does show,
769 | however, that there is an element of lookahead required to tell whether
770 | an optional item contains a list or a sequence or a simple list of
771 | terminals and non-terminals.
772 |
773 | ::=
774 | [ { }... ]
775 |
776 | table_element_list
777 | : left_paren table_element opt_nt_0016 right_paren
778 | ;
779 | opt_nt_0016
780 | : /* Nothing */
781 | | lst_nt_0017
782 | ;
783 | lst_nt_0017
784 | : seq_nt_0018
785 | | lst_nt_0017 seq_nt_0018
786 | ;
787 | seq_nt_0018
788 | : comma table_element
789 | ;
790 |
791 | The next example is interesting because the sequence item contains
792 | alternatives with no optionality or iteration. It suggests that the
793 | term 'sequence' is not necessarily the 'mot juste'.
794 |
795 | ::=
796 |
797 | { | }
798 | [ ]
799 | [ ]
800 | [ ... ]
801 | [ ]
802 |
803 | column_definition
804 | : column_name seq_nt_0019 opt_nt_0020 opt_nt_0021 opt_nt_0022 opt_nt_0023
805 | ;
806 | seq_nt_0019
807 | : data_type
808 | | domain_name
809 | ;
810 | opt_nt_0020
811 | : /* Nothing */
812 | | reference_scope_check
813 | ;
814 | opt_nt_0021
815 | : /* Nothing */
816 | | default_clause
817 | ;
818 | opt_nt_0022
819 | : /* Nothing */
820 | | lst_nt_0024
821 | ;
822 | opt_nt_0023
823 | : /* Nothing */
824 | | collate_clause
825 | ;
826 | lst_nt_0024
827 | : column_constraint_definition
828 | | lst_nt_0024 column_constraint_definition
829 | ;
830 |
831 |
832 | ::= | [ { }... ]
833 |
834 | select_list
835 | : asterisk
836 | | select_sublist opt_nt_0025
837 | ;
838 | opt_nt_0025
839 | : /* Nothing */
840 | | lst_nt_0026
841 | ;
842 | lst_nt_0026
843 | : seq_nt_0027
844 | | lst_nt_0026 seq_nt_0027
845 | ;
846 | seq_nt_0027
847 | : comma select_sublist
848 | ;
849 |
850 | The next statement does not introduce any new grammatical features. It
851 | does, however, trigger a shift/reduce conflict because an LALR(1)
852 | grammar cannot resolve with one lookahead token whether the token WITH
853 | is part of the WITH HIERARCHY OPTION or part of the WITH GRANT OPTION.
854 | Note that should use a non-terminal such as , but such structural changes cannot readily be done by this
856 | program.
857 |
858 | ::=
859 | GRANT TO [ { }... ]
860 | [ WITH HIERARCHY OPTION ] [ WITH GRANT OPTION ] [ GRANTED BY ]
861 |
862 | grant_privilege_statement
863 | : GRANT privileges TO grantee opt_nt_0028 opt_nt_0029 opt_nt_0030 opt_nt_0031
864 | ;
865 | opt_nt_0028
866 | : /* Nothing */
867 | | lst_nt_0032
868 | ;
869 | opt_nt_0029
870 | : /* Nothing */
871 | | WITH HIERARCHY OPTION
872 | ;
873 | opt_nt_0030
874 | : /* Nothing */
875 | | WITH GRANT OPTION
876 | ;
877 | opt_nt_0031
878 | : /* Nothing */
879 | | GRANTED BY grantor
880 | ;
881 | lst_nt_0032
882 | : seq_nt_0033
883 | | lst_nt_0032 seq_nt_0033
884 | ;
885 | seq_nt_0033
886 | : comma grantee
887 | ;
888 |
889 | The next statement reuses material introduced previously, but in a
890 | slightly more complex manner.
891 |
892 | ::=
893 | [ { }... ]
894 | | VALUE -
[ { }... ]
895 |
896 | set_descriptor_information
897 | : set_header_information opt_nt_0034
898 | | VALUE item_number set_item_information opt_nt_0035
899 | ;
900 | opt_nt_0034
901 | : /* Nothing */
902 | | lst_nt_0036
903 | ;
904 | opt_nt_0035
905 | : /* Nothing */
906 | | lst_nt_0037
907 | ;
908 | lst_nt_0036
909 | : seq_nt_0038
910 | | lst_nt_0036 seq_nt_0038
911 | ;
912 | lst_nt_0037
913 | : seq_nt_0039
914 | | lst_nt_0037 seq_nt_0039
915 | ;
916 | seq_nt_0038
917 | : comma set_header_information
918 | ;
919 | seq_nt_0039
920 | : comma set_item_information
921 | ;
922 |
923 | The next statement introduces deeper nesting than any of the previous
924 | ones. The expansion produces two rules (opt_nt_0040 and opt_nt_0044)
925 | that are identical. This is indicative of problems with the grammar on
926 | which it is working, which would be better written with a couple of new
927 | non-terminals, and . However, this
929 | is a stylistic change that should also be made in many other places in
930 | the grammar.
931 |
932 | ::=
933 | SQL TYPE IS CLOB AS LOCATOR
934 | [ ] [ { [ ] } ... ]
935 |
936 | c_blob_locator_variable
937 | : SQL TYPE IS CLOB AS LOCATOR c_host_identifier opt_nt_0040 opt_nt_0041
938 | ;
939 | opt_nt_0040
940 | : /* Nothing */
941 | | c_initial_value
942 | ;
943 | opt_nt_0041
944 | : /* Nothing */
945 | | lst_nt_0042
946 | ;
947 | lst_nt_0042
948 | : seq_nt_0043
949 | | lst_nt_0042 seq_nt_0043
950 | ;
951 | seq_nt_0043
952 | : comma c_host_identifier opt_nt_0044
953 | ;
954 | opt_nt_0044
955 | : /* Nothing */
956 | | c_initial_value
957 | ;
958 |
959 | =cut
960 |
--------------------------------------------------------------------------------
/bnf2yacc.pl:
--------------------------------------------------------------------------------
1 | #!/usr/bin/perl -w
2 | #
3 | # @(#)$Id: bnf2yacc.pl,v 1.16 2017/11/14 06:53:22 jleffler Exp $
4 | #
5 | # Convert SQL-92, SQL-99 BNF plain text file into YACC grammar.
6 |
7 | use strict;
8 | $| = 1;
9 |
10 | use constant debug => 0;
11 |
12 | my $heading = "";
13 | my %tokens;
14 | my %nonterminals;
15 | my %rules;
16 | my %used;
17 | my $start;
18 | my @grammar;
19 |
20 | my $nt_number = 0;
21 |
22 | # Generate a new non-terminal identifier
23 | sub new_non_terminal
24 | {
25 | my($prefix) = @_;
26 | $prefix = "" unless defined $prefix;
27 | return sprintf "${prefix}nt_%03d", ++$nt_number;
28 | }
29 |
30 | # map_non_terminal converts names that are not acceptable to Yacc into names that are.
31 | # Non-identifier characters are converted to underscores.
32 | # If the first character is not alphabetic, prefix 'j_'.
33 | # Case-convert to lower case.
34 | sub map_non_terminal
35 | {
36 | my($nt) = @_;
37 | $nt =~ s/\W+/_/go;
38 | $nt = "j_$nt" unless $nt =~ m/^[a-zA-Z]/o;
39 | $nt =~ tr/[A-Z]/[a-z]/;
40 | $nt =~ s/__+/_/go;
41 | return $nt;
42 | }
43 |
44 | # scan_rhs breaks up the RHS of a rule into a token stream
45 | # Keywords (terminals) are prefixed with a '#' marker.
46 | sub scan_rhs
47 | {
48 | my($tail) = @_;
49 | my(@rhs);
50 | while ($tail)
51 | {
52 | print "RHS: $tail\n" if debug;
53 | my $name;
54 | if ($tail =~ m%^(\s*<([-:/()_\w\s]+)>\s*)%o)
55 | {
56 | # Simpler regex for non-terminal: <[^>]+>
57 | # Non-terminal
58 | my $n = $2;
59 | print "N: $n\n" if debug;
60 | $tail = substr $tail, length($1);
61 | $name = map_non_terminal($n);
62 | $nonterminals{$name} = 1;
63 | $used{$name} = 1;
64 | push @rhs, $name;
65 | }
66 | elsif ($tail =~ m%^(\s*(\w[-\w\d_.]*)\s*)%o)
67 | {
68 | # Terminal (keyword)
69 | # Dot '.' is used in Interfaces.SQL in Ada syntax
70 | # Dash '-' is used in EXEC-SQL in the keywords.
71 | my $t = $2;
72 | print "T: $t\n" if debug;
73 | $tail = substr $tail, length($1);
74 | $name = $t;
75 | $tokens{$name} = 1;
76 | push @rhs, "#$name";
77 | }
78 | elsif ($tail =~ m%^\s*(\.\.\.omitted\.\.\.)\s*%o)
79 | {
80 | # Something omitted from the grammar.
81 | # Triple punctuation detected before double.
82 | my $str = "/* $1 */";
83 | push @rhs, $str;
84 | last;
85 | }
86 | elsif ($tail =~ m{^(\s*([-.<=>|]{2})\s*)$}o)
87 | {
88 | # Double-punctuation (non-metacharacters)
89 | # .., <=, >=, <>, ||, ->
90 | my $p = $2;
91 | print "DP: $p\n" if debug;
92 | $tail = substr $tail, length($1);
93 | $name = "'$p'";
94 | push @rhs, $name;
95 | }
96 | elsif ($tail =~ m{^(\s*([][{}"'%&()*+,-./:;<=>?^_|])\s*)$}o)
97 | {
98 | # Punctuation (non-metacharacters)
99 | # Note that none of '@', '~', '!' or '\' have any significance in SQL
100 | my $p = $2;
101 | print "P: $p\n" if debug;
102 | $tail = substr $tail, length($1);
103 | $p = "\\'" if $p eq "'";
104 | $name = "'$p'";
105 | push @rhs, $name;
106 | }
107 | elsif ($tail =~ m%^(\s*('[^']*'))\s*%o ||
108 | $tail =~ m%^(\s*("[^"]*"))\s*%o)
109 | {
110 | # Terminal in quotes - single or double.
111 | # (Possibly a multi-character string).
112 | my $q = $2;
113 | print "Q: $q\n" if debug;
114 | $tail = substr $tail, length($1);
115 | $q =~ m%^(['"])(.+)['"]$%o;
116 | # Expand multi-character string constants.
117 | # into repeated single-character constants.
118 | my($o) = $1;
119 | my($l) = $2;
120 | while (length($l))
121 | {
122 | my($c) = substr $l, 0, 1;
123 | $name = "$o$c$o";
124 | $l = substr $l, 1, length($l)-1;
125 | push @rhs, $name;
126 | }
127 | }
128 | elsif ($tail =~ m%^(\s*([{}\|\[\]]|\.\.\.)\s*)%o)
129 | {
130 | # Punctuation (metacharacters)
131 | my $p = $2;
132 | print "M: $p\n" if debug;
133 | $tail = substr $tail, length($1);
134 | $name = $p;
135 | push @rhs, $name;
136 | }
137 | elsif ($tail =~ m%^\s*!!%o)
138 | {
139 | # Exhortation to see the syntax rules - usually.
140 | my $str = "/* $tail */";
141 | push @rhs, $str;
142 | last;
143 | }
144 | else
145 | {
146 | # Unknown!
147 | print "/* UNK: $tail */\n";
148 | print STDERR "UNK:$.: $tail\n";
149 | last;
150 | }
151 | }
152 | return(@rhs);
153 | }
154 |
155 | # Format a Yacc rule given LHS and RHS array
156 | sub record_rule
157 | {
158 | my($lhs, $comment, @rule) = @_;
159 | my($production) = "";
160 | print "==>> record_rule ($lhs : @rule)\n" if debug;
161 | $production .= "/*\n" if $comment;
162 | $production .= "$lhs\n\t:\t";
163 | my $pad = "";
164 | my $br_count = 0;
165 | for (my $i = 0; $i <= $#rule; $i++)
166 | {
167 | my $item = $rule[$i];
168 | print "==== item $item\n" if debug;
169 | if ($item eq "|" && $br_count == 0)
170 | {
171 | $production .= "\n\t|\t";
172 | $pad = "";
173 | }
174 | else
175 | {
176 | $production .= "$pad$item";
177 | $pad = " ";
178 | $br_count++ if ($item eq '[' or $item eq '{');
179 | $br_count-- if ($item eq ']' or $item eq '}');
180 | }
181 | }
182 | $production .= "\n\t;\n";
183 | $production .= "*/\n" if $comment;
184 | $production .= "\n";
185 | print "$production" if debug;
186 | push @grammar, $production;
187 | print "<<== record_rule\n" if debug;
188 | }
189 |
190 | sub print_iterator
191 | {
192 | my($lhs,$rhs) = @_;
193 | my($production) = "";
194 | print "==>> print_iterator ($lhs $rhs)\n" if debug;
195 | $production .= "$lhs\n\t:\t$rhs\n\t|\t$lhs $rhs\n\t;\n\n";
196 | print "<<== print_iterator\n" if debug;
197 | push @grammar, $production;
198 | }
199 |
200 | # Process an optional item enclosed in square brackets
201 | sub find_balanced_bracket
202 | {
203 | my($lhs,@rhs) = @_;
204 | my(@rule) = ( "/* Nothing */", "|");
205 | print "==>> find_balanced_bracket ($lhs : @rhs)\n" if debug;
206 | while (my $name = shift @rhs)
207 | {
208 | print " name = $name\n" if debug;
209 | if ($name eq ']')
210 | {
211 | # Found closing bracket
212 | # Terminate search
213 | last;
214 | }
215 | elsif ($name eq '[')
216 | {
217 | # Found nested optional clause
218 | my $tag = new_non_terminal('opt_');
219 | @rhs = find_balanced_bracket($tag, @rhs);
220 | push @rule, $tag;
221 | }
222 | elsif ($name eq '{')
223 | {
224 | # Found start of sequence
225 | my $tag = new_non_terminal('seq_');
226 | @rhs = find_balanced_brace($tag, @rhs);
227 | push @rule, $tag;
228 | }
229 | elsif ($name eq '}')
230 | {
231 | # Found unbalanced close brace.
232 | # Error!
233 | }
234 | elsif ($name eq '...')
235 | {
236 | # Found iteration.
237 | my $tag = new_non_terminal('lst_');
238 | print "==== find_balanced_bracket: iterator (@rule)\n" if debug;
239 | my($old) = pop @rule;
240 | push @rule, $tag;
241 | print "==== find_balanced_bracket: iterator ($tag/$old - @rule)\n" if debug;
242 | print_iterator($tag, $old);
243 | }
244 | else
245 | {
246 | $name =~ s/^#//;
247 | push @rule, $name;
248 | $used{$name} = 1;
249 | }
250 | }
251 | record_rule($lhs, 0, @rule);
252 | print "<<== find_balanced_bracket: @rhs)\n" if debug;
253 | return(@rhs);
254 | }
255 |
256 | # Process an sequence item enclosed in curly braces
257 | sub find_balanced_brace
258 | {
259 | my($lhs,@rhs) = @_;
260 | my(@rule);
261 | print "==>> find_balanced_brace ($lhs : @rhs)\n" if debug;
262 | while (my $name = shift @rhs)
263 | {
264 | print " name = $name\n" if debug;
265 | if ($name eq '}')
266 | {
267 | # Found closing brace
268 | # Terminate search
269 | last;
270 | }
271 | elsif ($name eq '[')
272 | {
273 | # Found nested optional clause
274 | my $tag = new_non_terminal('opt_');
275 | @rhs = find_balanced_bracket($tag, @rhs);
276 | push @rule, $tag;
277 | }
278 | elsif ($name eq '{')
279 | {
280 | # Found start of sequence
281 | my $tag = new_non_terminal('seq_');
282 | @rhs = find_balanced_brace($tag, @rhs);
283 | push @rule, $tag;
284 | }
285 | elsif ($name eq ']')
286 | {
287 | # Found unbalanced close brace.
288 | # Error!
289 | }
290 | elsif ($name eq '...')
291 | {
292 | # Found iteration.
293 | my $tag = new_non_terminal('lst_');
294 | print "==== find_balanced_brace: iterator (@rule)\n" if debug;
295 | my($old) = pop @rule;
296 | push @rule, $tag;
297 | print "==== find_balanced_brace: iterator ($tag/$old - @rule)\n" if debug;
298 | print_iterator($tag, $old);
299 | }
300 | else
301 | {
302 | $name =~ s/^#//;
303 | push @rule, $name;
304 | $used{$name} = 1;
305 | }
306 | }
307 | record_rule($lhs, 0, @rule);
308 | print "<<== find_balanced_brace: @rhs)\n" if debug;
309 | return(@rhs);
310 | }
311 |
312 | # Note that the [ and { parts are nice and easy because they are
313 | # balanced operators. The iteration operator ... is much harder to
314 | # process because it is a trailing modifier. When processing the list
315 | # of symbols, you need to establish whether there is a trailing iterator
316 | # after the current symbol, and modify the behaviour appropriately.
317 | sub process_rhs
318 | {
319 | my($lhs, $tail) = @_;
320 | my(@rhs) = scan_rhs($tail);
321 | print "==>> process_rhs ($lhs : @rhs)\n" if debug;
322 | # List parsed rule in output only if debugging.
323 | record_rule($lhs, 1, @rhs) if debug;
324 | my(@rule);
325 | while (my $name = shift @rhs)
326 | {
327 | print "name = $name\n" if debug;
328 | if ($name eq '[')
329 | {
330 | my $tag = new_non_terminal('opt_');
331 | @rhs = find_balanced_bracket($tag, @rhs);
332 | push @rule, $tag;
333 | }
334 | elsif ($name eq ']')
335 | {
336 | # Found a close bracket for something unbalanced.
337 | # Error!
338 | }
339 | elsif ($name eq '{')
340 | {
341 | # Start of mandatory sequence of items, possibly containing alternatives.
342 | my $tag = new_non_terminal('seq_');
343 | @rhs = find_balanced_brace($tag, @rhs);
344 | push @rule, $tag;
345 | }
346 | elsif ($name eq '}')
347 | {
348 | # Found a close brace for something unbalanced.
349 | # Error!
350 | }
351 | elsif ($name eq '|')
352 | {
353 | # End of one alternative and start of a new one.
354 | print "==== process_rhs: alternative $name\n" if debug;
355 | push @rule, $name;
356 | }
357 | elsif ($name eq '...')
358 | {
359 | # Found iteration.
360 | my $tag = new_non_terminal('lst_');
361 | my($old) = pop @rule;
362 | push @rule, $tag;
363 | print "==== process_rhs: iterator\n" if debug;
364 | print_iterator($tag, $old);
365 | }
366 | elsif ($name =~ m/^#/)
367 | {
368 | # Keyword token
369 | print "==== process_rhs: token $name\n" if debug;
370 | $name =~ s/^#//;
371 | push @rule, $name;
372 | }
373 | else
374 | {
375 | # Non-terminal (or comment)
376 | print "==== process_rhs: non-terminal $name\n" if debug;
377 | push @rule, $name;
378 | }
379 | }
380 | print "==== process_rhs: @rule\n" if debug;
381 | record_rule($lhs, 0, @rule);
382 | print "<<== process_rhs\n" if debug;
383 | }
384 |
385 | sub count_unmatched_keys
386 | {
387 | my($ref1, $ref2) = @_;
388 | my(%keys) = %$ref1;
389 | my(%match) = %$ref2;
390 | my($count) = 0;
391 | foreach my $key (keys %keys)
392 | {
393 | $count++ unless defined $match{$key};
394 | }
395 | return $count;
396 | }
397 |
398 | # ------------------------------------------------------------
399 |
400 | open INPUT, "cat @ARGV |" or die "$!";
401 | $_ = ::=
646 |
647 |
648 |