[system] / trunk / pg / lib / Parser / Context.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Parser/Context.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5696 - (download) (as text) (annotate)
Sat Jun 14 12:14:21 2008 UTC (11 years, 8 months ago) by dpvc
File size: 6933 byte(s)
Added

	 no strict "refs"

to try to avoid new error checking in Perl 5.10.

    1 #########################################################################
    2 
    3 package Parser::Context;
    4 my $pkg = "Parser::Context";
    5 use strict; no strict "refs";
    6 our @ISA = ("Value::Context");
    7 
    8 #
    9 #  Create a new Context object and initialize its data lists
   10 #
   11 sub new {
   12   my $self = shift; my $class = ref($self) || $self;
   13   my $context = $Value::defaultContext->copy;
   14   bless $context, $class;
   15   $context->{parser} = {%{$Parser::class}};
   16   push(@{$context->{data}{values}},'parser');
   17   $context->{_initialized} = 0;
   18   my %data = (
   19     functions => {},
   20     variables => {},
   21     constants => {},
   22     operators => {},
   23     strings   => {},
   24     parens    => {},
   25     lists     => {},
   26     flags     => {},
   27     reduction => {},
   28     @_
   29   );
   30   $context->{_functions} = new Parser::Context::Functions($context,%{$data{functions}});
   31   $context->{_variables} = new Parser::Context::Variables($context,%{$data{variables}});
   32   $context->{_constants} = new Parser::Context::Constants($context,%{$data{constants}});
   33   $context->{_operators} = new Parser::Context::Operators($context,%{$data{operators}});
   34   $context->{_strings}   = new Parser::Context::Strings($context,%{$data{strings}});
   35   $context->{_parens}    = new Parser::Context::Parens($context,%{$data{parens}});
   36   $context->{_reduction} = new Parser::Context::Reduction($context,%{$data{reduction}});
   37   $context->lists->set(%{$data{lists}});
   38   $context->flags->set(%{$data{flags}});
   39   $context->{_initialized} = 1;
   40   $context->update;
   41   return $context;
   42 }
   43 
   44 #
   45 #  Update the token pattern
   46 #
   47 sub update {
   48   my $self = shift; return unless $self->{_initialized};
   49   my @patterns = ([$self->{pattern}{number},-10,'num']);
   50   my @tokens;
   51   foreach my $name (@{$self->{data}{objects}}) {
   52     my $data = $self->{$name};
   53     foreach my $pattern (keys %{$data->{patterns}}) {
   54       my $def = $data->{patterns}{$pattern};
   55       $def = [$def,$data->{tokenType}] unless ref($def) eq 'ARRAY';
   56       push @patterns,[$pattern,@{$def}];
   57     }
   58     push @tokens,%{$data->{tokens}};
   59   }
   60   $self->{pattern}{type} = [];
   61   $self->{pattern}{tokenType} = {@tokens};
   62   push @patterns,[getPattern(keys %{$self->{pattern}{tokenType}}),0,''];
   63   @patterns = sort byPrecedence @patterns;
   64   foreach my $pattern (@patterns) {
   65     push @{$self->{pattern}{type}}, $pattern->[2];
   66     $pattern = $pattern->[0];
   67   }
   68   my $pattern = '('.join(')|(',@patterns).')';
   69   $self->{pattern}{token} = qr/$pattern/;
   70 }
   71 
   72 #
   73 #  Build a regexp pattern from the characters and list of names
   74 #  (protect special characters)
   75 #
   76 sub getPattern {
   77   my $single = ''; my @multi = ();
   78   foreach my $x (sort byName (@_))
   79     {if (length($x) == 1) {$single .= $x} else {push(@multi,$x)}}
   80   foreach my $x (@multi) {$x = protectRegexp($x) unless substr($x,0,3) eq '(?:'}
   81   my @pattern = ();
   82   push(@pattern,join('|',@multi)) if scalar(@multi) > 0;
   83   push(@pattern,protectRegexp($single)) if length($single) == 1;
   84   push(@pattern,"[".protectChars($single)."]") if length($single) > 1;
   85   my $pattern = join('|',@pattern);
   86   $pattern = '^$' if $pattern eq '';
   87   return $pattern;
   88 }
   89 
   90 sub protectRegexp {
   91   my $string = shift;
   92   $string =~ s/[\[\](){}|+.*?\\]/\\$&/g;
   93   return $string;
   94 }
   95 
   96 sub protectChars {
   97   my $string = shift;
   98   $string =~ s/([\^\]])/\\$1/g;
   99   $string =~ s/^(.*)-(.*)$/-$1$2/g;
  100   return $string;
  101 }
  102 
  103 #
  104 #  Sort names so that they can be joined for regexp matching
  105 #  (longest first, then alphabetically)
  106 #
  107 sub byName {
  108   my $result = length($b) <=> length($a);
  109   $result = $a cmp $b unless $result;
  110   return $result;
  111 }
  112 #
  113 #  Sort by precedence, then type
  114 #
  115 sub byPrecedence {
  116   my $result = $a->[1] <=> $b->[1];
  117   $result = $a->[2] cmp $b->[2] unless $result;
  118   $result = $b->[0] cmp $a->[0] unless $result;
  119   return $result;
  120 }
  121 
  122 
  123 
  124 #
  125 #  Access to the data lists
  126 #
  127 sub operators {(shift)->{_operators}}
  128 sub functions {(shift)->{_functions}}
  129 sub constants {(shift)->{_constants}}
  130 sub variables {(shift)->{_variables}}
  131 sub strings   {(shift)->{_strings}}
  132 sub parens    {(shift)->{_parens}}
  133 sub reduction {(shift)->{_reduction}}
  134 
  135 sub reduce     {(shift)->{_reduction}->reduce(@_)}
  136 sub noreduce   {(shift)->{_reduction}->noreduce(@_)}
  137 sub reductions {(shift)->{_reduction}}
  138 
  139 #
  140 #  Store pointer to user's context table
  141 #
  142 my $userContext;
  143 
  144 #
  145 #  Set/Get the current Context object
  146 #
  147 sub current {
  148   my $self = shift; my $contextTable = shift; my $context = shift;
  149   if ($contextTable) {$userContext = $contextTable} else {$contextTable = $userContext}
  150   if (defined($context)) {
  151     if (!ref($context)) {
  152       my $name = $context;
  153       $context = Parser::Context->getCopy($contextTable,$context);
  154       Value::Error("Unknown context '%s'",$name) unless defined($context);
  155     }
  156     $contextTable->{current} = $context;
  157     $Value::context = \$contextTable->{current};
  158   } elsif (!defined($contextTable->{current})) {
  159     $contextTable->{current} = $Parser::Context::Default::context{Numeric}->copy;
  160     $Value::context = \$contextTable->{current};
  161   }
  162   return $contextTable->{current};
  163 }
  164 
  165 #
  166 #  Get a copy of a named context
  167 #   (either from the (optional) list provided, the main user's list
  168 #    or from the default list)
  169 #
  170 sub getCopy {
  171   my $self = shift; my $contextTable;
  172   $contextTable = shift if !defined $_[0] || ref($_[0]) eq 'HASH';
  173   $contextTable = $userContext unless $contextTable;
  174   my $name = shift; my $context = $contextTable->{$name};
  175   $context = $Parser::Context::Default::context{$name} unless $context;
  176   return unless $context;
  177   $context = $context->copy;
  178   $context->{name} = $name;
  179   return $context;
  180 }
  181 
  182 #
  183 #  Obsolete:  use "getCopy" instead
  184 #
  185 sub get {shift->getCopy(@_)}
  186 
  187 #
  188 #  Update the precedences of multiplication so that they
  189 #  are the standard or non-standard ones, depending on the
  190 #  argument.  It should be 'Standard' or 'Non-Standard'.
  191 #
  192 sub usePrecedence {
  193   my $self = shift;
  194   for (shift) {
  195 
  196     /^Standard/i  and do {
  197       $self->operators->set(
  198         ' *' => {precedence => 3},
  199         '* ' => {precedence => 3},
  200         ' /' => {precedence => 3},
  201         '/ ' => {precedence => 3},
  202          fn  => {precedence => 7.5},
  203          ' ' => {precedence => 3},
  204       );
  205       last;
  206     };
  207 
  208     /^Non-Standard/i and do {
  209       $self->operators->set(
  210         ' *' => {precedence => 2.8},
  211         '* ' => {precedence => 2.8},
  212         ' /' => {precedence => 2.8},
  213         '/ ' => {precedence => 2.8},
  214          fn  => {precedence => 2.9},
  215          ' ' => {precedence => 3.1},
  216       );
  217       last;
  218     };
  219 
  220     Value::Error("Precedence type should be one of 'Standard' or 'Non-Standard'");
  221   }
  222 }
  223 
  224 #########################################################################
  225 #
  226 #  Load the subclasses.
  227 #
  228 
  229 END {
  230   use Parser::Context::Constants;
  231   use Parser::Context::Functions;
  232   use Parser::Context::Operators;
  233   use Parser::Context::Parens;
  234   use Parser::Context::Strings;
  235   use Parser::Context::Variables;
  236   use Parser::Context::Reduction;
  237 }
  238 
  239 #########################################################################
  240 
  241 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9