#############################################################################
## Name:        build/Wx/XSP/XSP.yp
## Purpose:     Grammar file for xsubppp.pl
## Author:      Mattia Barbon
## Modified by:
## Created:     01/03/2003
## RCS-ID:      $Id: XSP.yp,v 1.5 2007/03/10 20:38:57 mbarbon Exp $
## Copyright:   (c) 2003, 2007 Mattia Barbon
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

%token OPCURLY CLCURLY OPPAR CLPAR SEMICOLON TILDE DCOLON
%token STAR AMP COMMA EQUAL OPSPECIAL CLSPECIAL
%token INTEGER RAW_CODE ID

%%

top:    raw             { [ $_[1] ] }
      | class           { [ $_[1] ] }
      | directive       { [ $_[1] ] }
      | function        { [ $_[1] ] }
      | top raw         { push @{$_[1]}, $_[2]; $_[1] }
      | top class       { push @{$_[1]}, $_[2]; $_[1] }
      | top directive   { push @{$_[1]}, $_[2]; $_[1] }
      | top function    { push @{$_[1]}, $_[2]; $_[1] }
        ;

directive:      perc_module SEMICOLON
                    { Wx::XSP::Node::Module->new( module => $_[1] ) }
              | perc_file SEMICOLON
                    { Wx::XSP::Node::File->new( file => $_[1] ) }
              | typemap SEMICOLON { add_data_raw( $_[0], [ "\n" ] ) };

typemap:        p_typemap OPCURLY type CLCURLY OPCURLY ID CLCURLY
                    { my $package = "Wx::XSP::Typemap::" . $_[6];
                      my $type = $_[3];
                      my $tm = $package->new( type => $type );
                      Wx::XSP::Typemap::add_typemap_for_type( $type, $tm );
                      undef }
              | p_typemap OPCURLY type CLCURLY OPCURLY ID CLCURLY
                  special_blocks
                    { my $package = "Wx::XSP::Typemap::" . $_[6];
                      my $type = $_[3]; my $c = 0;
                      my %args = map { "arg" . ++$c => $_ }
                                 map { join( '', @$_ ) }
                                     @{$_[8]};
                      my $tm = $package->new( type => $type, %args );
                      Wx::XSP::Typemap::add_typemap_for_type( $type, $tm );
                      undef };

raw:    RAW_CODE        { add_data_raw( $_[0], [ $_[1] ] ) }
      | special_block   { add_data_raw( $_[0], [ @{$_[1]}, '' ] ) };

class: class_head class_body
           { $_[2] ? set_data_class( $_[0],
                                     class   => $_[1],
                                     methods => $_[2] ) : $_[1] };

class_head:  perc_name 'class' ID
                 { $class = create_class( $_[0], $_[3], $_[1] ) }
           | 'class' ID
                 { $class = create_class( $_[0], $_[2] ) };

class_body:  OPCURLY methods CLCURLY SEMICOLON { $_[2] }
           | OPCURLY CLCURLY SEMICOLON { undef };

methods:        method          { [ $_[1] ] }
              | methods method  { push @{$_[1]}, $_[2]; $_[1] }
              | raw             { [ $_[1] ] }
              | methods raw     { push @{$_[1]}, $_[2]; $_[1] }
              | typemap SEMICOLON
              | methods typemap SEMICOLON
              ;

method:         function { my $f = $_[1];
                           my $m = add_data_method
                             ( $_[0],
                               name      => $f->cpp_name,
                               ret_type  => $f->ret_type,
                               arguments => $f->arguments,
                               code      => $f->code,
                               cleanup   => $f->cleanup,
                               class     => $class,
                               );
                           $m->{STATIC} = $_[1]->{STATIC};
                           $m->{PERL_NAME} = $_[1]->{PERL_NAME};
                           $m
                         }
              | ctor
              | perc_name ctor
                    { $_[2]->{PERL_NAME} = $_[1]; $_[2] }
              | dtor ;

const: 'const'
     | ;

static: 'package_static'
      | 'class_static'
      ;

function:       _func
              | static _func
                    { $_[2]->{STATIC} = $_[1]; $_[2] }
              | perc_name _func
                    { $_[2]->{PERL_NAME} = $_[1];
                      $_[2] }
              | perc_name static _func
                    { $_[3]->{PERL_NAME} = $_[1];
                      $_[3]->{STATIC} = $_[2];
                      $_[3] }
              ;

_func:          type ID OPPAR arg_list CLPAR const metadata SEMICOLON
                    { add_data_function( $_[0],
                                         name      => $_[2],
                                         ret_type  => $_[1],
                                         arguments => $_[4],
                                         class     => $class,
                                         @{ $_[7] } ) }
              | type ID OPPAR CLPAR const metadata SEMICOLON
                    { add_data_function( $_[0],
                                         name     => $_[2],
                                         ret_type => $_[1],
                                         class     => $class,
                                         @{ $_[6] } ) };

ctor:           ID OPPAR arg_list CLPAR metadata SEMICOLON
                    { add_data_ctor( $_[0], name      => $_[1],
                                            arguments => $_[3],
                                            class     => $class,
                                            @{ $_[5] } ) }
              | ID OPPAR CLPAR metadata SEMICOLON
                    { add_data_ctor( $_[0], name  => $_[1],
                                            class => $class,
                                            @{ $_[4] } ) };

dtor:           TILDE ID OPPAR CLPAR metadata SEMICOLON
                    { add_data_dtor( $_[0], name  => $_[2],
                                            class => $class,
                                            @{ $_[5] },
                                      ) };

metadata:       _metadata          { $_[1] }
              | metadata _metadata { [ @{$_[1]}, @{$_[2]} ] }
              |                    { [] }
              ;

_metadata:      perc_code       { $_[1] }
              | perc_cleanup    { $_[1] }
              ;

perc_name:      p_name OPCURLY class_name CLCURLY     { $_[3] };
perc_module:    p_module OPCURLY class_name CLCURLY   { $_[3] };
perc_file:      p_file OPCURLY file_name CLCURLY      { $_[3] };
perc_code:      p_code special_block                  { [ code => $_[2] ] };
perc_cleanup:   p_cleanup special_block               { [ cleanup => $_[2] ] };

type:           'const' type_name STAR { make_cptr( $_[0], $_[2] ) }
              | 'const' type_name AMP  { make_cref( $_[0], $_[2] ) }
              | type_name STAR         { make_ptr( $_[0], $_[1] ) }
              | type_name AMP          { make_ref( $_[0], $_[1] ) }
              | type_name              { make_type( $_[0], $_[1] ) };

type_name:    class_name | basic_type | 'unsigned' basic_type;

basic_type:   'char' | 'short' | 'int' | 'long' | 'unsigned'
            | 'long' 'int' | 'short' 'int';

class_name:     ID
              | ID DCOLON ID { $_[1] . '::' . $_[3] };

file_name:      DASH                            { '-' }
              | ID DOT ID                       { $_[1] . '.' . $_[3] }
              | ID SLASH file_name              { $_[1] . '/' . $_[3] };

arg_list:       argument                { [ $_[1] ] }
              | arg_list COMMA argument { push @{$_[1]}, $_[3]; $_[1] };

argument:       type ID                 { make_argument( @_ ) }
              | type ID EQUAL value
                    { make_argument( @_[0, 1, 2, 4] ) };

value:          INTEGER
              | DASH INTEGER    { '-' . $_[2] }
              | FLOAT
              | QUOTED_STRING
              | ID
              | ID DCOLON ID    { $_[1] . '::' . $_[3] }
              | ID OPPAR value CLPAR { "$_[1]($_[3])" }
              ;


special_blocks:  special_block
                     { [ $_[1] ] }
               | special_blocks special_block
                     { [ @{$_[1]}, $_[2] ] }
               ;

special_block:          special_block_start lines special_block_end
                            { $_[2] }
              |         special_block_start special_block_end
                            { [] }
              ;

special_block_start:    OPSPECIAL       { push_lex_mode( $_[0], 'special' ) };

special_block_end:      CLSPECIAL       { pop_lex_mode( $_[0], 'special' ) };

lines: line             { [ $_[1] ] } 
     | lines line       { push @{$_[1]}, $_[2]; $_[1] };

%%

use Wx::XSP::Node;
use Wx::XSP::Typemap;

my %tokens = ( '::' => 'DCOLON',
               '%{' => 'OPSPECIAL',
               '%}' => 'CLSPECIAL',
               '{%' => 'OPSPECIAL',
                '{' => 'OPCURLY',
                '}' => 'CLCURLY',
                '(' => 'OPPAR',
                ')' => 'CLPAR',
                ';' => 'SEMICOLON',
                '%' => 'PERC',
                '~' => 'TILDE',
                '*' => 'STAR',
                '&' => 'AMP',
                ',' => 'COMMA',
                '=' => 'EQUAL',
                '/' => 'SLASH',
                '.' => 'DOT',
                '-' => 'DASH',
               # these are here due to my lack of skill with yacc
               '%name' => 'p_name',
               '%typemap' => 'p_typemap',
               '%file' => 'p_file',
               '%module' => 'p_module',
               '%code' => 'p_code',
               '%cleanup' => 'p_cleanup',
             );

my %keywords = ( const => 1,
                 class => 1,
                 unsigned => 1,
                 short => 1,
                 long => 1,
                 int => 1,
                 char => 1,
                 package_static => 1,
                 class_static => 1,
                 );

sub get_lex_mode { return $_[0]->YYData->{LEX}{MODES}[0] || '' }

sub push_lex_mode {
  my( $p, $mode ) = @_;

  push @{$p->YYData->{LEX}{MODES}}, $mode;
}

sub pop_lex_mode {
  my( $p, $mode ) = @_;

  die "Unexpected mode: '$mode'"
    unless get_lex_mode( $p ) eq $mode;

  pop @{$p->YYData->{LEX}{MODES}};
}

sub read_more {
  my( $fh, $buf ) = @_;
  my $v = <$fh>;

  return unless defined $v;

  $$buf .= $v;

  return 1;
}

sub yylex {
  my $data = $_[0]->YYData->{LEX};
  my $fh = $data->{FH};
  my $buf = $data->{BUFFER};

  for(;;) {
    if( !length( $$buf ) && !read_more( $fh, $buf ) ) {
      return ( '', undef );
    }

    if( get_lex_mode( $_[0] ) eq 'special' ) {
      if( $$buf =~ s/^%}// ) {
        return ( 'CLSPECIAL', '%}' );
      } elsif( $$buf =~ s/^([^\n]*)\n$// ) {
        my $line = $1;

        if( $line =~ m/^(.*?)\%}(.*)$/ ) {
          $$buf = "%}$2\n";
          $line = $1;
        }

        return ( 'line', $line );
      }
    } else {
      $$buf =~ s/^[\s\n\r]+//;
      next unless length $$buf;

      if( $$buf =~ s/^([+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)// ) {
        return ( 'FLOAT', $1 );
      } elsif( $$buf =~ s/^( \%}
                      | \%{ | {\%
                      | \%name | \%typemap | \%module | \%typemap | \%code
                      | \%file | \%cleanup
                      | [{}();%~*&,=\/\.\-]
                      | ::
                       )//x ) {
        return ( $tokens{$1}, $1 );
      } elsif( $$buf =~ s/^(INCLUDE:.*)(?:\r\n|\r|\n)// ) {
        return ( 'RAW_CODE', "$1\n" );
      } elsif( $$buf =~ m/^([a-zA-Z_]\w*)\W/ ) {
        $$buf =~ s/^(\w+)//;

        return ( $1, $1 ) if exists $keywords{$1};

        return ( 'ID', $1 );
      } elsif( $$buf =~ s/^(\d+)// ) {
        return ( 'INTEGER', $1 );
      } elsif( $$buf =~ s/^("[^"]*")// ) {
        return ( 'QUOTED_STRING', $1 );
      } elsif( $$buf =~ s/^(#.*)(?:\r\n|\r|\n)// ) {
        return ( 'RAW_CODE', $1 );
      } else {
        die $$buf;
      }
    }
  }
}

sub yyerror {
  my $data = $_[0]->YYData->{LEX};
  my $buf = $data->{BUFFER};
  my $fh = $data->{FH};
   
  print STDERR "Error: line " . $fh->input_line_number . " (",
    $_[0]->YYCurtok, ') (',
    $_[0]->YYCurval, ') "', ( $buf ? $$buf : '--empty buffer--' ),
      q{"} . "\n";
  print STDERR "Expecting: (", ( join ", ", map { "'$_'" } $_[0]->YYExpect ),
        ")\n";
}

sub make_cptr { Wx::XSP::Node::Type->new( base => $_[1],
                                        const => 1, pointer => 1 ) }
sub make_cref { Wx::XSP::Node::Type->new( base => $_[1],
                                        const => 1, reference => 1 ) }
sub make_ref  { Wx::XSP::Node::Type->new( base => $_[1], reference => 1 ) }
sub make_ptr  { Wx::XSP::Node::Type->new( base => $_[1], pointer => 1 ) }
sub make_type { Wx::XSP::Node::Type->new( base => $_[1] ) }

sub add_data_raw {
  my $p = shift;
  my $rows = shift;

  Wx::XSP::Node::Raw->new( rows => $rows );
}

sub make_argument {
  my( $p, $type, $name, $default ) = @_;

  Wx::XSP::Node::Argument->new( type    => $type,
                              name    => $name,
                              default => $default );
}

sub create_class {
  my( $parser, $name, $perl ) = @_;
  my $class = Wx::XSP::Node::Class->new( perl_name => $perl,
                                         cpp_name  => $name,
                                         );
  return $class;
}

sub set_data_class {
  my( $parser, %args ) = @_;
  $args{class}->{METHODS} = $args{methods};

  return $args{class};
}

sub add_data_function {
  my( $parser, %args ) = @_;

  Wx::XSP::Node::Function->new( cpp_name  => $args{name},
                                class     => $args{class},
                                ret_type  => $args{ret_type},
                                arguments => $args{arguments},
                                code      => $args{code},
                                cleanup   => $args{cleanup},
                                );
}

sub add_data_method {
  my( $parser, %args ) = @_;

  die "PANIC: method $args{name} without class" unless $args{class};
  Wx::XSP::Node::Method->new( cpp_name  => $args{name},
                              class     => $args{class},
                              ret_type  => $args{ret_type},
                              arguments => $args{arguments},
                              code      => $args{code},
                              cleanup   => $args{cleanup},
                              );
}

sub add_data_ctor {
  my( $parser, %args ) = @_;

  die "PANIC: constructor $args{name} without class" unless $args{class};
  Wx::XSP::Node::Constructor->new( cpp_name  => $args{name},
                                   class     => $args{class},
                                   arguments => $args{arguments},
                                   code      => $args{code},
                                   );
}

sub add_data_dtor {
  my( $parser, %args ) = @_;

  die "PANIC: destructor $args{name} without class" unless $args{class};
  Wx::XSP::Node::Destructor->new( cpp_name  => $args{name},
                                  class     => $args{class},
                                  code      => $args{code},
                                  );
}

sub is_directive {
  my( $p, $d, $name ) = @_;

  return $d->[0] eq $name;
}

#sub assert_directive {
#  my( $p, $d, $name ) = @_;
#
#  if( $d->[0] ne $name )
#    { $p->YYError }
#  1;
#}