languages/jako/lib/Jako/Processor.pm

   1 #
   2 # Processor.pm
   3 #
   4 # Copyright (C) 2002-2005, The Perl Foundation.
   5 # This program is free software. It is subject to the same license
   6 # as the Parrot interpreter.
   7 #
   8 # $Id$
   9 #
  10
  11 use strict;
  12 use warnings;
  13
  14 package Jako::Processor;
  15
  16 use Carp;
  17
  18 #
  19 # new()
  20 #
  21
  22 sub new {
  23     confess "Subclass responsibility";
  24 }
  25
  26 #
  27 # debug()
  28 #
  29
  30 sub debug {
  31     my $self = shift;
  32
  33     if (@_) {
  34         $self->{DEBUG} = shift;
  35     }
  36
  37     return $self->{DEBUG};
  38 }
  39
  40 #
  41 # file()
  42 #
  43
  44 sub file {
  45     my $self = shift;
  46
  47     if (@_) { $self->{FILE} = shift; }
  48
  49     return defined $self->{FILE} ? $self->{FILE} : '<NO FILE>';
  50 }
  51
  52 #
  53 # line()
  54 #
  55
  56 sub line {
  57     my $self = shift;
  58
  59     if (@_) { $self->{LINE} = shift; }
  60
  61     return defined $self->{LINE} ? $self->{LINE} : '';
  62 }
  63
  64 ###############################################################################
  65 ###############################################################################
  66 ##
  67 ## TOKEN PROCESSING:
  68 ##
  69 ###############################################################################
  70 ###############################################################################
  71
  72 #
  73 # tokens()
  74 #
  75
  76 sub tokens {
  77     my $self = shift;
  78
  79     if (@_) {
  80         $self->{TOKENS} = [@_];
  81     }
  82     else {
  83         return @{ $self->{TOKENS} };
  84     }
  85 }
  86
  87 #
  88 # token_count()
  89 #
  90 # Returns the number of tokens.
  91 #
  92
  93 sub count {
  94     my $self = shift;
  95
  96     return scalar( @{ $self->{TOKENS} } );
  97 }
  98
  99 #
 100 # pos()
 101 #
 102 # Returns (or sets) the abolute position.
 103 #
 104
 105 sub pos {
 106     my $self = shift;
 107     my ($pos) = @_;
 108
 109     if ( defined $pos ) {
 110         my $count = scalar( @{ $self->{TOKENS} } );
 111
 112         $pos = -1     if $pos < 0;         # Just before the beginning
 113         $pos = $count if $pos > $count;    # Just past the end (in case we get more tokens)
 114
 115         $self->{POS} = $pos;
 116
 117         $self->file( $self->at($pos)->file );
 118         $self->line( $self->at($pos)->line );
 119     }
 120
 121     return defined $self->{POS} ? $self->{POS} : -1;
 122 }
 123
 124 #
 125 # at()
 126 #
 127 # Without an argument, gives the current token. With an argument, gives the
 128 # token at that absolute position. If a count is given, then that many tokens
 129 # (at most, given the possibilitiy of running off the end) are returned. If
 130 # a count is not given, 1 is inferred.
 131 #
 132
 133 sub at {
 134     my $self = shift;
 135     my ( $index, $count ) = @_;
 136
 137     $index = $self->pos unless defined $index;
 138
 139     $count = 1 unless defined $count;
 140
 141     $self->INTERNAL_ERROR( "Attempt to get fewer than 1 token (%s)!", $count )
 142         if $count < 1;
 143
 144     if ( $count > 1 ) {
 145         return map { $self->at( $index + $_ ) } ( 0 .. $count );
 146     }
 147
 148     my $pos = $self->pos;
 149
 150     $self->INTERNAL_ERROR("Position is not defined") unless defined $pos;
 151
 152     return Jako::Token->BOF if $index < 0;
 153     return Jako::Token->EOF if $index >= @{ $self->{TOKENS} };
 154
 155     return $self->{TOKENS}[$index];
 156 }
 157
 158 #
 159 # get()
 160 #
 161 # Without an argument, gives the current token. With an argument, gives the
 162 # token at that offset from the current one. If a count is given, then that
 163 # many tokens (at most, given the possibility of running of the end) are
 164 # returned. If a count is not given, 1 is inferred.
 165 #
 166
 167 sub get {
 168     my $self = shift;
 169     my ( $offset, $count ) = @_;
 170
 171     $offset = 0 unless defined $offset;
 172
 173     my $pos = $self->pos;
 174
 175     $self->INTERNAL_ERROR("Position is not defined") unless defined $pos;
 176     $self->INTERNAL_ERROR("Offset is not defined")   unless defined $offset;
 177
 178     #  DEBUG(0, "Current position is $pos");
 179     $pos += $offset;
 180
 181     #  DEBUG(0, "Getting token at $pos");
 182
 183     return $self->at( $pos, $count );
 184 }
 185
 186 #
 187 # forth()
 188 #
 189 # Moves the current token position $offset tokens forward. Returns the
 190 # token at the new absolute position.
 191 #
 192
 193 sub forth {
 194     my $self = shift;
 195     my ($offset) = @_;
 196
 197     $offset = 1 unless defined $offset;
 198
 199     my $pos = $self->pos;
 200
 201     $self->INTERNAL_ERROR("Position is undefined") unless defined $pos;
 202
 203     #  DEBUG(0, "Position starts as $pos");
 204
 205     $pos += $offset;
 206
 207     #  DEBUG(0, "Setting position to $pos");
 208     $self->pos($pos);
 209
 210     #  DEBUG(0, "forth(): Position is now %d", $self->pos);
 211
 212     my $token = $self->get;
 213
 214     $self->file( $token->file );
 215     $self->line( $token->line );
 216
 217     return $token;
 218 }
 219
 220 #
 221 # back()
 222 #
 223 # Moves the current token position $offset tokens backward. Returns the new
 224 # absolute position.
 225 #
 226
 227 sub back {
 228     my $self = shift;
 229     my ($offset) = @_;
 230
 231     $offset = 1 unless defined $offset;
 232
 233     return $self->forth( -$offset );
 234 }
 235
 236 #
 237 # dump()
 238 #
 239 # Dump the tokens.
 240 #
 241
 242 sub dump {
 243     my $self = shift;
 244
 245     while (1) {
 246         my $tok = $self->forth;
 247
 248         printf STDERR "%6d : %-30s : %5s : %-15s: %1s : %s\n", $self->pos, $tok->file, $tok->line,
 249             $tok->kind, $tok->type || '', $tok->text;
 250
 251         last if $tok->is_eof;
 252     }
 253
 254 =begin commented_out
 255
 256   foreach (my $i = 0; $i < scalar(@{$self->{TOKENS}}); $i++) {
 257     my $tok = $self->at($i);
 258
 259     printf STDERR "%6d : %-30s : %5s : %-15s: %1s : %s\n",
 260       $i,
 261       $tok->file,
 262       $tok->line,
 263       $tok->kind,
 264       $tok->type || '',
 265       $tok->text;
 266
 267     last if $tok->is_eof;
 268   }
 269
 270 =cut
 271
 272 }
 273
 274 #
 275 # require()
 276 #
 277 # Require consumes and returns the token if the requirement is met, otherwise
 278 # a Syntax Error is raised.
 279 #
 280 # If more than one type is specified, the semantics are "or".
 281 #
 282
 283 sub require {
 284     my $self = shift;
 285
 286     #  DEBUG(0, "Requiring '$kind'");
 287
 288     $self->SYNTAX_ERROR(
 289         "Expected %s, but found '%s'.",
 290         @_ > 1 ? "one of (" . join( ", ", @_ ) . ")" : $_[0],
 291         $self->get(1)->text
 292     ) unless grep { $self->get(1)->kind eq $_ } @_;
 293
 294     return $self->forth;
 295 }
 296
 297 #
 298 # REQUIRES:
 299 #
 300
 301 sub require_assign        { return shift->require('assign'); }
 302 sub require_close_brace   { return shift->require('close-brace'); }
 303 sub require_close_bracket { return shift->require('close-bracket'); }
 304 sub require_close_paren   { return shift->require('close-paren'); }
 305 sub require_comma         { return shift->require('comma'); }
 306 sub require_ident         { return shift->require('ident'); }
 307 sub require_literal       { return shift->require('literal'); }
 308 sub require_open_brace    { return shift->require('open-brace'); }
 309 sub require_open_bracket  { return shift->require('open-bracket'); }
 310 sub require_open_paren    { return shift->require('open-paren'); }
 311 sub require_infix_rel     { return shift->require('infix-rel'); }
 312 sub require_semicolon     { return shift->require('semicolon'); }
 313 sub require_type          { return shift->require('type'); }
 314
 315 sub require_value { return shift->require( 'ident', 'literal' ); }
 316
 317 #
 318 # skip()
 319 #
 320 # Skips the token type specified if it is present. Returns undef if nothing
 321 # was skipped, otherwise returns the token skipped.
 322 #
 323 # If more than one type is specified, the semantics are "or".
 324 #
 325
 326 sub skip {
 327     my $self = shift;
 328     my ($kind) = @_;
 329
 330     return undef unless grep { $self->get(1)->kind eq $_ } @_;
 331
 332     return $self->forth;
 333 }
 334
 335 #
 336 # SKIPS:
 337 #
 338
 339 sub skip_assign        { return shift->skip('assign'); }
 340 sub skip_colon         { return shift->skip('colon'); }
 341 sub skip_comma         { return shift->skip('comma'); }
 342 sub skip_close_brace   { return shift->skip('close-brace'); }
 343 sub skip_close_bracket { return shift->skip('close-bracket'); }
 344 sub skip_close_paren   { return shift->skip('close-paren'); }
 345 sub skip_ident         { return shift->skip('ident'); }
 346 sub skip_literal       { return shift->skip('literal'); }
 347 sub skip_new           { return shift->skip('new'); }
 348 sub skip_open_brace    { return shift->skip('open-brace'); }
 349 sub skip_open_bracket  { return shift->skip('open-bracket'); }
 350 sub skip_open_paren    { return shift->skip('open-paren'); }
 351 sub skip_infix_rel     { return shift->skip('infix-rel'); }
 352 sub skip_semicolon     { return shift->skip('semicolon'); }
 353 sub skip_type          { return shift->skip('type'); }
 354
 355 sub skip_value { return shift->skip( 'ident', 'literal' ); }
 356
 357 ###############################################################################
 358 ###############################################################################
 359 ##
 360 ## MESSAGES:
 361 ##
 362 ###############################################################################
 363 ###############################################################################
 364
 365 #
 366 # DEBUG()
 367 #
 368
 369 sub DEBUG {
 370     my ( $self, $level, $format, @args ) = @_;
 371
 372     return unless defined $self->debug and $self->debug >= $level;
 373
 374     my $message = $format ? sprintf( $format, @args ) : '<no message>';
 375
 376     printf STDERR "%s [%s]: Debug message: %s\n", $self->file, $self->line, $message;
 377 }
 378
 379 #
 380 # WARNING()
 381 #
 382
 383 sub WARNING {
 384     my ( $self, $format, @args ) = @_;
 385
 386     my $message = sprintf( $format, @args );
 387
 388     print STDERR "%s [%s]: Warning: %s", $self->file, $self->line, $message;
 389 }
 390
 391 #
 392 # ERROR()
 393 #
 394
 395 sub ERROR {
 396     my ( $self, $kind, $format, @args ) = @_;
 397
 398     my $message = sprintf( $format, @args );
 399
 400     $message = sprintf( "%s [%s]: %s error: %s", $self->file, $self->line, $kind, $message );
 401
 402     if   ( $self->debug ) { confess $message; }
 403     else                  { die "$message\n"; }
 404 }
 405
 406 #
 407 # PARSE_ERROR()
 408 #
 409
 410 sub PARSE_ERROR {
 411     my ( $self, $format, @args ) = @_;
 412     $self->ERROR( 'Parse', $format, @args );
 413 }
 414
 415 #
 416 # SYNTAX_ERROR()
 417 #
 418
 419 sub SYNTAX_ERROR {
 420     my ( $self, $format, @args ) = @_;
 421     $self->ERROR( 'Syntax', $format, @args );
 422 }
 423
 424 #
 425 # INTERNAL_ERROR()
 426 #
 427
 428 sub INTERNAL_ERROR {
 429     my ( $self, $format, @args ) = @_;
 430     $self->ERROR( 'Internal', $format, @args );
 431 }
 432
 433 1;
 434
 435
 436 # Local Variables:
 437 #   mode: cperl
 438 #   cperl-indent-level: 4
 439 #   fill-column: 100
 440 # End:
 441 # vim: expandtab shiftwidth=4: