#!/usr/local/bin/perl
package Parser;

use 5.008007;
use strict;
use warnings; 

require Exporter;
require DynaLoader;
our @ISA = qw(DynaLoader Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw() ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();

our $VERSION = '1.261';

#require XSLoader;
#XSLoader::load('Parser', $VERSION);
bootstrap Parser $VERSION;

# Preloaded methods go here.
#### Accessors
sub new {
    my $class = shift;  $class = ref $class if ref $class;
    my $self = { strip_autos=>0,
         @_};

    bless $self, $class;
    return $self;
}


sub read {
    my $self = shift;
    my %param = (@_);
    if (!-r $param{filename}) { print "%Error: file not found: $param{
+filename}, stopped";}
    $self->_read_xs($param{filename}, $param{strip_autos}||$self->{str
+ip_autos});
}
sub read_include {
    my $self = shift;
    my %param = (@_);
    if (!-r $param{filename}) { print "%Error: file not found: $param{
+filename}, stopped";}
    $self->_read_include_xs($param{filename});
}

#In Parser.XS:
# sub _read_xs {class}
# sub _read_include_xs {class}
# sub filename {class}
# sub lineno {class}

######################################################################
#### Called by the parser

sub auto {}
sub cell {}
sub cell_decl {}
sub ctor {}
sub enum_value {}
sub module {}
sub module_continued {}
sub pin {}
sub pin_template {}
sub preproc_sp {}
sub signal {}
sub text {}

sub fileline {
    my $self = shift;
    return ($self->filename||"").":".($self->lineno||"");
}

sub error {
    my ($self,$text,$token)=@_;
    my $fileline = $self->filename.":".$self->lineno;
    croak ("%Error: $fileline: $text\n"
       ."%Error: ".(" "x length($fileline)).": At token '$token'\nStop
+ped");
}

######################################################################
1;
[download]

/* Mine: */
#define SCPARSE_C
#include "scparse.h"

/* Perl */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"

static struct {        /*Eventually a C++ class?? */
    SV* self;        /* Class called from */
    int errors;        /* Number of errors encountered */

    struct {
    SV* prefixSV;    /* Commentary before the next token */
    int lineno;    /* Starting linenumber of above text */
    } prefix;

    int lastLineno;    /* Linenumber of last tolken sent to call back 
+*/
    HV*    symbols;    /* Hash of all symbols found */
} scParserState;

void scparser_set_line (int lineno) {
    scParserState.lastLineno = lineno;
}

void scparser_PrefixCat (char *text, int len)
{
    /* Add comments and other stuff to text that we can just save for 
+later */
    if (!scParserState.prefix.prefixSV) {
    scParserState.prefix.prefixSV = newSVpvn (text, len);
    scParserState.prefix.lineno = scParserLex.lineno;
    } else {
    sv_catpvn (scParserState.prefix.prefixSV, text, len);
    }
}

void scparser_EmitPrefix (void)
{
    /* Call $self->text(text_received) */
    scparser_set_line (scParserState.prefix.lineno);
    if (scParserState.prefix.prefixSV) {
    /* Emit text in prefix */
    {
        dSP;            /* Initialize stack pointer */
        ENTER;            /* everything created after here */
        SAVETMPS;            /* ...is a temporary variable. */
        PUSHMARK(SP);        /* remember the stack pointer */
        XPUSHs(scParserState.self);    /* $self-> */
        XPUSHs(scParserState.prefix.prefixSV);    /* prefix */
        PUTBACK;            /* make local stack pointer global */
        perl_call_method ("text", G_DISCARD | G_VOID);
        FREETMPS;            /* free that return value */
        LEAVE;            /* ...and the XPUSHed "mortal" args.*/
    }
    /* Not a memory leak; perl will free the SV when done with it */
    scParserState.prefix.prefixSV = NULL;
    }
}

void scparser_call (
    int params,        /* Number of parameters.  Negative frees the pa
+rameters */
    const char *method,    /* Name of method to call */
    ...)        /* Arguments to pass to method's @_ */
{
    /* Call $self->auto (passedparam1, parsedparam2) */
    int free_them = 0;
    va_list ap;

    if (params<0) {
    params = -params;
    free_them = 1;
    }

    scparser_EmitPrefix();
    scparser_set_line (scParserLex.lineno);
    va_start(ap, method);
    {
    dSP;                /* Initialize stack pointer */
    ENTER;                /* everything created after here */
    SAVETMPS;            /* ...is a temporary variable. */
    PUSHMARK(SP);            /* remember the stack pointer */
    XPUSHs(scParserState.self);    /* $self-> */

    while (params--) {
        char *text;
        SV *sv;
        text = va_arg(ap, char *);
        sv = newSVpv (text, 0);
        XPUSHs(sv);            /* token */
        if (free_them) free (text);
    }

    PUTBACK;            /* make local stack pointer global */
    perl_call_method (method, G_DISCARD | G_VOID);
    FREETMPS;            /* free that return value */
    LEAVE;                /* ...and the XPUSHed "mortal" args.*/
    }
    va_end(ap);
}

/*********************************************************************
+*/

void scparser_symbol (
    const char *key    /* Symbol detected */
    )
{
    /* $self->symbols{$key} = 1 */
    SV **svp;
    svp = hv_fetch (scParserState.symbols, key, strlen(key), 1);
    if (!SvOK(*svp)) {
    sv_setiv (*svp, scParserLex.lineno);
    }
}

/*********************************************************************
+*/

void scgrammererror (const char *s)
{
    scparser_EmitPrefix ();    /* Dump previous stuff, so error locati
+on is obvious */
    scparser_set_line (scParserLex.lineno);
    scparser_call (2,"error", s, sclextext);
    scParserState.errors++;
}

void scparse_init (SV *CLASS, const char *filename, int strip)
{
    scParserState.self = CLASS;
    scParserState.errors = 0;
    scParserState.symbols = newHV();
    scParserLex.stripAutos = strip;

    sclextext = "";  /* In case we get a error in the open */
}

void scparse_set_filename (const char *filename, int lineno)
{
    scParserLex.filename = strdup(filename);
    scParserLex.lineno = lineno;
    scparser_set_line (lineno);
}

MODULE = Parser  PACKAGE = Parser

#/********************************************************************
+**/
#/* self->lineno() */

int
lineno (CLASS)
SV *CLASS
PROTOTYPE: $
CODE:
{
    if (CLASS) {}  /* Prevent unused warning */
    RETVAL = scParserState.lastLineno;
}
OUTPUT: RETVAL

#/********************************************************************
+**/
#/* self->filename() */

const char *
filename (CLASS)
SV *CLASS
PROTOTYPE: $
CODE:
{
    if (CLASS) {}  /* Prevent unused warning */
    RETVAL = scParserLex.filename;
}
OUTPUT: RETVAL

#/********************************************************************
+**/
#/* self->symbols() */

HV *
symbols (CLASS)
SV *CLASS
PROTOTYPE: $
CODE:
{
    if (CLASS) {}  /* Prevent unused warning */
    RETVAL = scParserState.symbols;
}
OUTPUT: RETVAL

#/********************************************************************
+**/
#/* self->read (filename) */

int 
_read_xs (CLASS, filename, strip_autos)
SV *CLASS
char *filename
int strip_autos
PROTOTYPE: $$$
CODE:
{
    static int/*bool*/ in_parser = 0;

    if (!SvROK(CLASS)) {
    in_parser = 0;
    croak ("Parser::read() not called as class member");
    }

    if (!filename) {
    in_parser = 0;
    croak ("Parser::read() filename=> parameter not passed");
    }

    if (in_parser) {
    croak ("Parser::read() called recursively");
    }
    in_parser = 1;

    scparse_init (CLASS, filename, strip_autos);
    if (!sclex_open (filename)) {
    in_parser = 0;
    croak ("Parser::read() file not found");
    }
    scgrammerparse();
    fclose (sclexin);

    /* Emit final tokens */
    scparser_EmitPrefix ();

    if (scParserState.errors) {
    in_parser = 0;
    croak ("Parser::read() detected parse errors");
    }
    in_parser = 0;
    RETVAL = 1;
}
OUTPUT: RETVAL
#/********************************************************************
+**/
#/* self->read_include (filename) */

int 
_read_include_xs (CLASS, filename)
SV *CLASS
char *filename
PROTOTYPE: $$
CODE:
{
    if (!SvROK(CLASS)) {
    croak ("Parser::read_include() not called as class member");
    }
    if (!filename) {
    croak ("Parser::read_include() filename=> parameter not passed");
    }
    sclex_include (filename);
    RETVAL = 1;
}
OUTPUT: RETVAL
[download]