# $Source: /usr/cvsroot/ConveyPerl/lib/Macro.pm,v $
# $Id: Macro.pm,v 1.2 2002/02/14 16:42:15 marco Exp $
#
# Copyright (c) 2002, Edward Marco Baringer. All Rights Reserved.
# This module is free software. It may be used, redistributed
# and/or modified under the terms of the Perl Artistic License
# (see http://www.perl.com/perl/misc/Artistic.html)
package Macro;
require 5.005_62;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = ( );
our $VERSION = '0.2';
use Filter::Simple;
use Text::Balanced qw ( extract_codeblock );
use Parse::RecDescent;
$::RD_HINT = 1;
#$::RD_TRACE = 1;
sub build_macro_grammar {
my $template = Filter::Simple::show(shift);
my $generator = Filter::Simple::show(shift);
my $prefix = "__MACRO_HELPER_RULE";
$template =~ s/^\s*{//;
$template =~ s/\}\s*$//;
$template =~ s/^\s*//;
$template =~ s/\s*$//;
# we want to allow regexp like repeat specifiers *, +, ?, {n,m},
# but Parse::RecDescent wants a different format, (s?), (s), (?)
# and (n..m) repesctivley
$template =~ s/\)\s*\+/)(s)/g;
$template =~ s/\)\s*\*/)(s\?)/g;
$template =~ s/\)\s*\?/)(?)/g;
$template =~ s/\)\s*{\s*(\d+)\s*,\s*(\d+)\s*}/)($1..$2)/g;
my $name = gensym();
return
{ name => $name,
grammar =>
# ok, this is what the user specified
$name . ' : ' . $template . ' { &{ sub ' . $generator . '}(do { shift @item; @item}) }' . "\n\n"
};
}
sub extract_macro {
my $coderef = shift();
my $code = ${$coderef};
my $grammar = undef;
# now we go and search for the _first_ macro template
if ($code =~ /^(macro\s*)/g) {
my $start = pos($code) - length($1);
my $code_pre = substr($code, 0, $start);
# we have already consumed all the white space, so if this is
# followed by a {} pair
my $code_chunk = substr($code, pos($code));
my ($template, $remainder) = extract_codeblock($code_chunk, '{}', '');
if (defined $template) {
# ok, now just check and see if we have another block
# (this time the optional white space is ok not, the
# remainder refered to here is what was returned by the
# previous call to extract_codeblock
my ($generator, $remainder) = extract_codeblock($remainder, '{}');
if (defined $generator) {
# ok, we've got a macro
$grammar = build_macro_grammar($template, $generator);
# remove this from $code
$code = $code_pre . $remainder;
}
}
}
$$coderef = $code;
return $grammar;
}
FILTER_ONLY
code => sub {
my $code = $_;
my (undef, @macro_files) = @_;
my @macros;
foreach my $ext_macro (@macro_files) {
open MACRO_FILE, "<$ext_macro" or die "Can't open $ext_macro: $!\n";
local $/ = undef;
# quick note, since this $code is in this block the "other"
# $code will be ok
my $code = <MACRO_FILE>;
close MACRO_FILE;
my $seen_code = "";
while ($code ne '') {
if (my $new_macro_grammar = extract_macro(\$code)) {
push @macros, $new_macro_grammar;
}
$seen_code = substr($code, 0, 1);
$code = substr($code, 1);
}
}
my $macro_parser;
# we go through the code expanding and defining new macros. this
# used to be two distinct steps, but if we want macros which
# define macros we need to do these together
my $seen_code = "";
# this first pass will get all the macros explicitly written in
# the source code, if there are macro defining macros we'll get
# them later and it will slow things down a bit, oh well.
while ($code ne '') {
if (my $new_macro_grammar = extract_macro(\$code)) {
push @macros, $new_macro_grammar;
}
$seen_code .= substr($code, 0, 1);
$code = substr($code, 1);
}
$code = $seen_code;
my $standard_grammar_rules =
# and these are all the 'standard' rules (notice how we're
# assholes and don't let the user define their own rules? ha ha ha
'integer : /[-+]?\d+/ { $return = $item[1]; }' . "\n\n" .
'real : /[-+]?\d+\.?\d*/ { $return = $item[1]; }' . "\n\n" .
'function_name : /[A-Za-z_][A-Za-z0-9_]*/ { $return = $item[1]; }' . "\n\n" .
'arg_list : <rulevar: $seperator = quotemeta($arg[0] || "," )> ' . "\n\n" .
'arg_list : <rulevar: $open_delim = quotemeta($arg[1] || "(" )> ' . "\n\n" .
'arg_list : <rulevar: $close_delim = quotemeta($arg[2] || $arg[1] || ")")> ' . "\n\n" .
'arg_list : { $thisparser->{"local"}{"seperator"} = $seperator;' . "\n" .
' $thisparser->{"local"}{"close_delim"} = $close_delim; } ' . "\n" .
' /$open_delim/ __MACRO_INNER_arg_list_element(s? /$seperator/) /$close_delim/ ' .
' { $return = $item[3]; }' . "\n\n" .
'__MACRO_INNER_arg_list_element : <rulevar: $seperator = $thisparser->{"local"}{"seperator"}> ' . "\n\n" .
'__MACRO_INNER_arg_list_element : <rulevar: $close_delim = $thisparser->{"local"}{"close_delim"}> ' . "\n\n" .
'__MACRO_INNER_arg_list_element : <perl_quotelike>' . "\n" .
' { $return = join "", map { $_ || "" } @{ $item[1] } } |' . "\n" .
' /' . $Filter::Simple::placeholder . '/' . "\n" .
' { $return = Filter::Simple::show($item[1]) } |' . "\n" .
' /(\\\\(\\s|$seperator|$close_delim)|.*?(?=$seperator|\\s|$close_delim))+/ ' . "\n" .
' { $item[1] =~ s/\\\\(\\s|$seperator|$close_delim)/$1/g; $return = $item[1]; }' . "\n\n";
my $all_grammar = "macro : " . join(" | ", map { $_->{name} } @macros) . "\n\n" .
join("\n\n", map { $_->{grammar} } @macros) . "\n\n" .
$standard_grammar_rules;
@macros = (Parse::RecDescent->new($all_grammar));
$seen_code = "";
while ($code ne '') {
foreach my $macro (@macros) {
if (defined ($macro->macro($code))) {
# ok, we have a match. in order to get around a weird
# maybe bug in Parse::RecDescent we need to redo it
my $expansion = $macro->macro(\$code);
$code = $expansion . $code;
}
}
while (my $new_macro_grammar = extract_macro(\$code)) {
my $grammar = $new_macro_grammar->{grammar};
my $name = $new_macro_grammar->{name};
$grammar =~ s/^\s*$name/macro/;
push @macros, Parse::RecDescent->new($new_macro_grammar->{grammar} . $standard_grammar_rules);
}
$code =~ s/^(\s+|.)//;
$seen_code .= $1;
}
$code = $seen_code;
$_ = $code;
};
{
my $gen_sym_counter = 0;
sub gensym {
my $sym = shift || "G";
return $sym . sprintf("%010d", $gen_sym_counter++);
}
}
1;
__END__;