[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 5439 - (download) (as text) (annotate)
Tue Aug 28 21:53:42 2007 UTC (12 years, 5 months ago) by dpvc
File size: 6915 byte(s)
Updated contexts to include a "name" field that at least tracks what
context you started with (though it can be modified and no longer be
the same as the original context).

Remove the individual named variables in the Default.pm file; they are
now available only through the %Parser::Context::Default::context
hash.

Remove the >< and . operators, the <...> parentheses, the norm and
unit functions, and the i, j, and k constants from the Point context.
So the Point context no longer includes vectors and vector
operaterations.

    1 #########################################################################
    2 
    3 package Parser::Context;
    4 my $pkg = "Parser::Context";
    5 use strict;
    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