[perl5.git] / regen / regcomp.pl

#!/usr/bin/perl -w
#
#
# Regenerate (overwriting only if changed):
#
#    pod/perldebguts.pod
#    regnodes.h
#
# from information stored in
#
#    regcomp.sym
#    regexp.h
#
# pod/perldebguts.pod is not completely regenerated.  Only the table of
# regexp nodes is replaced; other parts remain unchanged.
#
# Accepts the standard regen_lib -q and -v args.
#
# This script is normally invoked from regen.pl.

BEGIN {
    # Get function prototypes
    require './regen/regen_lib.pl';
}
use strict;

# NOTE I don't think anyone actually knows what all of these properties mean,
# and I suspect some of them are outright unused. This is a first attempt to
# clean up the generation so maybe one day we can move to something more self
# documenting. (One might argue that an array of hashes of properties would
# be easier to use.)
#
# Why we use the term regnode and nodes, and not say, opcodes, I am not sure.

# General thoughts:
# 1. We use a single continuum to represent both opcodes and states,
#    and in regexec.c we switch on the combined set.
# 2. Opcodes have more information associated to them, states are simpler,
#    basically just an identifier/number that can be used to switch within
#    the state machine.
# 3. Some opcode are order dependent.
# 4. Output files often use "tricks" to reduce diff effects. Some of what
#    we do below is more clumsy looking than it could be because of this.

# Op/state properties:
#
# Property      In      Descr
# ----------------------------------------------------------------------------
# name          Both    Name of op/state
# id            Both    integer value for this opcode/state
# optype        Both    Either 'op' or 'state'
# line_num      Both    line_num number of the input file for this item.
# type          Op      Type of node (aka regkind)
# code          Op      Apparently not used
# suffix        Op      which regnode struct this uses, so if this is '1', it
#                       uses 'struct regnode_1'
# flags         Op      S for simple; V for varies
# longj         Op      Boolean as to if this node is a longjump
# comment       Both    Comment about node, if any.  Placed in perlredebguts
#                       as its description
# pod_comment   Both    Special comments for pod output (preceding lines in def)
#                       Such lines begin with '#*'

# Global State
my @all;    # all opcodes/state
my %all;    # hash of all opcode/state names

my @ops;    # array of just opcodes
my @states; # array of just states

my $longest_name_length= 0; # track lengths of names for nicer reports
my (%type_alias);           # map the type (??)

# register a newly constructed node into our state tables.
# ensures that we have no name collisions (on name anyway),
# and issues the "id" for the node.
sub register_node {
    my ($node)= @_;

    if ( $all{ $node->{name} } ) {
        die "Duplicate item '$node->{name}' in regcomp.sym line $node->{line_num} "
            . "previously defined on line $all{ $node->{name} }{line_num}\n";
    } elsif (!$node->{optype}) {
        die "must have an optype in node ", Dumper($node);
    } elsif ($node->{optype} eq "op") {
        push @ops, $node;
    } elsif ($node->{optype} eq "state") {
        push @states, $node;
    } else {
        die "Uknown optype '$node->{optype}' in ", Dumper($node);
    }
    $node->{id}= 0 + @all;
    push @all, $node;
    $all{ $node->{name} }= $node;

    if ($node->{longj} && $node->{longj} != 1) {
        die "longj field must be in [01] if present in ", Dumper($node);
    }

}

# Parse and add an opcode definition to the global state.
# What an opcode definition looks like is given in regcomp.sym.
#
# Not every opcode definition has all of the components. We should maybe make
# this nicer/easier to read in the future. Also note that the above is tab
# sensitive.

# Special comments for an entry precede it, and begin with '#*' and are placed
# in the generated pod file just before the entry.

sub parse_opcode_def {
    my ( $text, $line_num, $pod_comment )= @_;
    my $node= {
        line_num    => $line_num,
        pod_comment => $pod_comment,
        optype      => "op",
    };

    # first split the line into three, the initial NAME, a middle part
    # that we call "desc" which contains various (not well documented) things,
    # and a comment section.
    @{$node}{qw(name desc comment)}= /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/
        or die "Failed to match $_";

    # the content of the "desc" field from the first step is extracted here:
    @{$node}{qw(type code suffix flags longj)}= split /[,\s]\s*/, $node->{desc};

    defined $node->{$_} or $node->{$_} = ""
        for qw(type code suffix flags longj);

    register_node($node); # has to be before the type_alias code below

    if ( !$all{ $node->{type} } and !$type_alias{ $node->{type} } ) {

        #warn "Regop type '$node->{type}' from regcomp.sym line $line_num"
        #     ." is not an existing regop, and will be aliased to $node->{name}\n"
        #    if -t STDERR;
        $type_alias{ $node->{type} }= $node->{name};
    }

    $longest_name_length= length $node->{name}
        if length $node->{name} > $longest_name_length;
}

# parse out a state definition and add the resulting data
# into the global state. may create multiple new states from
# a single definition (this is part of the point).
# Format for states:
# REGOP \t typelist [ \t typelist]
# typelist= namelist
#         = namelist:FAIL
#         = name:count
# Eg:
# WHILEM          A_pre,A_min,A_max,B_min,B_max:FAIL
# BRANCH          next:FAIL
# CURLYM          A,B:FAIL
#
# The CURLYM definition would create the states:
# CURLYM_A, CURLYM_A_fail, CURLYM_B, CURLYM_B_fail
sub parse_state_def {
    my ( $text, $line_num, $pod_comment )= @_;
    my ( $type, @lists )= split /\s+/, $text;
    die "No list? $type" if !@lists;
    foreach my $list (@lists) {
        my ( $names, $special )= split /:/, $list, 2;
        $special ||= "";
        foreach my $name ( split /,/, $names ) {
            my $real=
                $name eq 'resume'
                ? "resume_$type"
                : "${type}_$name";
            my @suffix;
            if ( !$special ) {
                @suffix= ("");
            }
            elsif ( $special =~ /\d/ ) {
                @suffix= ( 1 .. $special );
            }
            elsif ( $special eq 'FAIL' ) {
                @suffix= ( "", "_fail" );
            }
            else {
                die "unknown :type ':$special'";
            }
            foreach my $suffix (@suffix) {
                my $node= {
                    name        => "$real$suffix",
                    optype      => "state",
                    type        => $type || "",
                    comment     => "state for $type",
                    line_num    => $line_num,
                };
                register_node($node);
            }
        }
    }
}

sub process_flags {
    my ( $flag, $varname, $comment )= @_;
    $comment= '' unless defined $comment;

    my @selected;
    my $bitmap= '';
    for my $node (@ops) {
        my $set= $node->{flags} && $node->{flags} eq $flag ? 1 : 0;

        # Whilst I could do this with vec, I'd prefer to do longhand the arithmetic
        # ops in the C code.
        my $current= do {
            no warnings;
            ord substr $bitmap, ( $node->{id} >> 3 );
        };
        substr( $bitmap, ( $node->{id} >> 3 ), 1 )=
            chr( $current | ( $set << ( $node->{id} & 7 ) ) );

        push @selected, $node->{name} if $set;
    }
    my $out_string= join ', ', @selected, 0;
    $out_string =~ s/(.{1,70},) /$1\n    /g;

    my $out_mask= join ', ', map { sprintf "0x%02X", ord $_ } split '', $bitmap;

    return $comment . <<"EOP";
#define REGNODE_\U$varname\E(node) (PL_${varname}_bitmask[(node) >> 3] & (1 << ((node) & 7)))

#ifndef DOINIT
EXTCONST U8 PL_${varname}\[] __attribute__deprecated__;
#else
EXTCONST U8 PL_${varname}\[] __attribute__deprecated__ = {
    $out_string
};
#endif /* DOINIT */

#ifndef DOINIT
EXTCONST U8 PL_${varname}_bitmask[];
#else
EXTCONST U8 PL_${varname}_bitmask[] = {
    $out_mask
};
#endif /* DOINIT */
EOP
}

sub read_definition {
    my ( $file )= @_;
    my ( $seen_sep, $pod_comment )= "";
    open my $in_fh, "<", $file
        or die "Failed to open '$file' for reading: $!";
    while (<$in_fh>) {

        # Special pod comments
        if (/^#\* ?/) { $pod_comment .= "# $'"; }

        # Truly blank lines possibly surrounding pod comments
        elsif (/^\s*$/) { $pod_comment .= "\n" }

        next if /\A\s*#/ || /\A\s*\z/;

        s/\s*\z//;
        if (/^-+\s*$/) {
            $seen_sep= 1;
            next;
        }

        if ($seen_sep) {
            parse_state_def( $_, $., $pod_comment );
        }
        else {
            parse_opcode_def( $_, $., $pod_comment );
        }
        $pod_comment= "";
    }
    close $in_fh;
    die "Too many regexp/state opcodes! Maximum is 256, but there are ", 0 + @all,
        " in file!"
        if @all > 256;
}

# use fixed width to keep the diffs between regcomp.pl recompiles
# as small as possible.
my ( $width, $rwidth, $twidth )= ( 22, 12, 9 );

sub print_state_defs {
    my ($out)= @_;
    printf $out <<EOP,
/* Regops and State definitions */

#define %*s\t%d
#define %*s\t%d

EOP
        -$width,
        REGNODE_MAX => $#ops,
        -$width, REGMATCH_STATE_MAX => $#all;

    my %rev_type_alias= reverse %type_alias;
    for my $node (@ops) {
        printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
            -$width, $node->{name}, $node->{id}, $node->{id}, $node->{comment};
        if ( defined( my $alias= $rev_type_alias{ $node->{name} } ) ) {
            printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
                -$width, $alias, $node->{id}, $node->{id}, "type alias";
        }
    }

    print $out "\t/* ------------ States ------------- */\n";
    for my $node (@states) {
        printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n",
            -$width, $node->{name}, $node->{id} - $#ops, $node->{comment};
    }
}

sub print_regkind {
    my ($out)= @_;
    print $out <<EOP;

/* PL_regkind[] What type of regop or state is this. */

#ifndef DOINIT
EXTCONST U8 PL_regkind[];
#else
EXTCONST U8 PL_regkind[] = {
EOP
    use Data::Dumper;
    foreach my $node (@all) {
        print Dumper($node) if !defined $node->{type} or !defined( $node->{name} );
        printf $out "\t%*s\t/* %*s */\n",
            -1 - $twidth, "$node->{type},", -$width, $node->{name};
        print $out "\t/* ------------ States ------------- */\n"
            if $node->{id} == $#ops and $node->{id} != $#all;
    }

    print $out <<EOP;
};
#endif
EOP
}

sub wrap_ifdef_print {
    my $out= shift;
    my $token= shift;
    print $out <<EOP;

#ifdef $token
EOP
    $_->($out) for @_;
    print $out <<EOP;
#endif /* $token */

EOP
}

sub print_regarglen {
    my ($out)= @_;
    print $out <<EOP;

/* regarglen[] - How large is the argument part of the node (in regnodes) */

static const U8 regarglen[] = {
EOP

    foreach my $node (@ops) {
        my $size= 0;
        $size= "EXTRA_SIZE(struct regnode_$node->{suffix})" if $node->{suffix};

        printf $out "\t%*s\t/* %*s */\n", -37, "$size,", -$rwidth, $node->{name};
    }

    print $out <<EOP;
};
EOP
}

sub print_reg_off_by_arg {
    my ($out)= @_;
    print $out <<EOP;

/* reg_off_by_arg[] - Which argument holds the offset to the next node */

static const char reg_off_by_arg[] = {
EOP

    foreach my $node (@ops) {
        my $size= $node->{longj} || 0;

        printf $out "\t%d,\t/* %*s */\n", $size, -$rwidth, $node->{name};
    }

    print $out <<EOP;
};

EOP
}

sub print_reg_name {
    my ($out)= @_;
    print $out <<EOP;

/* reg_name[] - Opcode/state names in string form, for debugging */

#ifndef DOINIT
EXTCONST char * PL_reg_name[];
#else
EXTCONST char * const PL_reg_name[] = {
EOP

    my $ofs= 0;
    my $sym= "";
    foreach my $node (@all) {
        my $size= $node->{longj} || 0;

        printf $out "\t%*s\t/* $sym%#04x */\n",
            -3 - $width, qq("$node->{name}",), $node->{id} - $ofs;
        if ( $node->{id} == $#ops and @ops != @all ) {
            print $out "\t/* ------------ States ------------- */\n";
            $ofs= $#ops;
            $sym= 'REGNODE_MAX +';
        }
    }

    print $out <<EOP;
};
#endif /* DOINIT */

EOP
}

sub print_reg_extflags_name {
    my ($out)= @_;
    print $out <<EOP;
/* PL_reg_extflags_name[] - Opcode/state names in string form, for debugging */

#ifndef DOINIT
EXTCONST char * PL_reg_extflags_name[];
#else
EXTCONST char * const PL_reg_extflags_name[] = {
EOP

    my %rxfv;
    my %definitions;    # Remember what the symbol definitions are
    my $val= 0;
    my %reverse;
    my $REG_EXTFLAGS_NAME_SIZE= 0;
    foreach my $file ( "op_reg_common.h", "regexp.h" ) {
        open my $in_fh, "<", $file or die "Can't read '$file': $!";
        while (<$in_fh>) {

            # optional leading '_'.  Return symbol in $1, and strip it from
            # comment of line.  Currently doesn't handle comments running onto
            # next line
            if (s/^ \# \s* define \s+ ( _? RXf_ \w+ ) \s+ //xi) {
                chomp;
                my $define= $1;
                my $orig= $_;
                s{ /\* .*? \*/ }{ }x;    # Replace comments by a blank

                # Replace any prior defined symbols by their values
                foreach my $key ( keys %definitions ) {
                    s/\b$key\b/$definitions{$key}/g;
                }

                # Remove the U suffix from unsigned int literals
                s/\b([0-9]+)U\b/$1/g;

                my $newval= eval $_;     # Get numeric definition

                $definitions{$define}= $newval;

                next unless $_ =~ /<</;    # Bit defines use left shift
                if ( $val & $newval ) {
                    my @names= ( $define, $reverse{$newval} );
                    s/PMf_// for @names;
                    if ( $names[0] ne $names[1] ) {
                        die sprintf
                            "ERROR: both $define and $reverse{$newval} use 0x%08X (%s:%s)",
                            $newval, $orig, $_;
                    }
                    next;
                }
                $val |= $newval;
                $rxfv{$define}= $newval;
                $reverse{$newval}= $define;
            }
        }
    }
    my %vrxf= reverse %rxfv;
    printf $out "\t/* Bits in extflags defined: %s */\n", unpack 'B*', pack 'N',
        $val;
    my %multibits;
    for ( 0 .. 31 ) {
        my $power_of_2= 2**$_;
        my $n= $vrxf{$power_of_2};
        my $extra= "";
        if ( !$n ) {

            # Here, there was no name that matched exactly the bit.  It could be
            # either that it is unused, or the name matches multiple bits.
            if ( !( $val & $power_of_2 ) ) {
                $n= "UNUSED_BIT_$_";
            }
            else {

                # Here, must be because it matches multiple bits.  Look through
                # all possibilities until find one that matches this one.  Use
                # that name, and all the bits it matches
                foreach my $name ( keys %rxfv ) {
                    if ( $rxfv{$name} & $power_of_2 ) {
                        $n= $name . ( $multibits{$name}++ );
                        $extra= sprintf qq{ : "%s" - 0x%08x}, $name,
                            $rxfv{$name}
                            if $power_of_2 != $rxfv{$name};
                        last;
                    }
                }
            }
        }
        s/\bRXf_(PMf_)?// for $n, $extra;
        printf $out qq(\t%-20s/* 0x%08x%s */\n), qq("$n",), $power_of_2, $extra;
        $REG_EXTFLAGS_NAME_SIZE++;
    }

    print $out <<EOP;
};
#endif /* DOINIT */

#ifdef DEBUGGING
#  define REG_EXTFLAGS_NAME_SIZE $REG_EXTFLAGS_NAME_SIZE
#endif
EOP

}

sub print_reg_intflags_name {
    my ($out)= @_;
    print $out <<EOP;

/* PL_reg_intflags_name[] - Opcode/state names in string form, for debugging */

#ifndef DOINIT
EXTCONST char * PL_reg_intflags_name[];
#else
EXTCONST char * const PL_reg_intflags_name[] = {
EOP

    my %rxfv;
    my %definitions;    # Remember what the symbol definitions are
    my $val= 0;
    my %reverse;
    my $REG_INTFLAGS_NAME_SIZE= 0;
    foreach my $file ("regcomp.h") {
        open my $fh, "<", $file or die "Can't read $file: $!";
        while (<$fh>) {

            # optional leading '_'.  Return symbol in $1, and strip it from
            # comment of line
            if (
                m/^ \# \s* define \s+ ( PREGf_ ( \w+ ) ) \s+ 0x([0-9a-f]+)(?:\s*\/\*(.*)\*\/)?/xi
                )
            {
                chomp;
                my $define= $1;
                my $abbr= $2;
                my $hex= $3;
                my $comment= $4;
                my $val= hex($hex);
                $comment= $comment ? " - $comment" : "";

                printf $out qq(\t%-30s/* 0x%08x - %s%s */\n), qq("$abbr",),
                    $val, $define, $comment;
                $REG_INTFLAGS_NAME_SIZE++;
            }
        }
    }

    print $out <<EOP;
};
#endif /* DOINIT */

EOP
    print $out <<EOQ;
#ifdef DEBUGGING
#  define REG_INTFLAGS_NAME_SIZE $REG_INTFLAGS_NAME_SIZE
#endif

EOQ
}

sub print_process_flags {
    my ($out)= @_;

    print $out process_flags( 'V', 'varies', <<'EOC');
/* The following have no fixed length. U8 so we can do strchr() on it. */
EOC

    print $out process_flags( 'S', 'simple', <<'EOC');

/* The following always have a length of 1. U8 we can do strchr() on it. */
/* (Note that length 1 means "one character" under UTF8, not "one octet".) */
EOC

}

sub do_perldebguts {
    my $guts= open_new( 'pod/perldebguts.pod', '>' );

    my $node;
    my $code;
    my $name_fmt= '<' x  ( $longest_name_length - 1 );
    my $descr_fmt= '<' x ( 58 - $longest_name_length );
    eval <<EOD or die $@;
format GuTS =
 ^*~~
 \$node->{pod_comment}
 ^$name_fmt ^<<<<<<<<< ^$descr_fmt~~
 \$node->{name}, \$code, defined \$node->{comment} ? \$node->{comment} : ''
.
1;
EOD
    
    my $old_fh= select($guts);
    $~= "GuTS";

    open my $oldguts, '<', 'pod/perldebguts.pod'
        or die "$0 cannot open pod/perldebguts.pod for reading: $!";
    while (<$oldguts>) {
        print;
        last if /=for regcomp.pl begin/;
    }

    print <<'END_OF_DESCR';

 # TYPE arg-description [regnode-struct-suffix] [longjump-len] DESCRIPTION
END_OF_DESCR
    for my $n (@ops) {
        $node= $n;
        $code= "$node->{code} " . ( $node->{suffix} || "" );
        $code .= " $node->{longj}" if $node->{longj};
        if ( $node->{pod_comment} ||= "" ) {

            # Trim multiple blanks
            $node->{pod_comment} =~ s/^\n\n+/\n/;
            $node->{pod_comment} =~ s/\n\n+$/\n\n/;
        }
        write;
    }
    print "\n";

    while (<$oldguts>) {
        last if /=for regcomp.pl end/;
    }
    do { print } while <$oldguts>; #win32 can't unlink an open FH
    close $oldguts or die "Error closing pod/perldebguts.pod: $!";
    select $old_fh;
    close_and_rename($guts);
}

read_definition("regcomp.sym");
my $out= open_new( 'regnodes.h', '>',
    { by => 'regen/regcomp.pl', from => 'regcomp.sym' } );
print_state_defs($out);
print_regkind($out);
wrap_ifdef_print(
    $out,
    "REG_COMP_C",
    \&print_regarglen,
    \&print_reg_off_by_arg
);
print_reg_name($out);
print_reg_extflags_name($out);
print_reg_intflags_name($out);
print_process_flags($out);
read_only_bottom_close_and_rename($out);

do_perldebguts();
Commit	Line	Data
916e4025	1	#!/usr/bin/perl -w
f83e001e YO	2	#
f83e001e YO	3	#
6294c161 DM	4	# Regenerate (overwriting only if changed):
6294c161 DM	5	#
65aa4ca7	6	# pod/perldebguts.pod
6294c161 DM	7	# regnodes.h
	8	#
	9	# from information stored in
	10	#
	11	# regcomp.sym
	12	# regexp.h
	13	#
65aa4ca7 FC	14	# pod/perldebguts.pod is not completely regenerated. Only the table of
	15	# regexp nodes is replaced; other parts remain unchanged.
	16	#
6294c161 DM	17	# Accepts the standard regen_lib -q and -v args.
	18	#
	19	# This script is normally invoked from regen.pl.
	20
36bb303b NC	21	BEGIN {
36bb303b NC	22	# Get function prototypes
3d7c117d	23	require './regen/regen_lib.pl';
36bb303b	24	}
03363afd	25	use strict;
03363afd	26
f83e001e YO	27	# NOTE I don't think anyone actually knows what all of these properties mean,
	28	# and I suspect some of them are outright unused. This is a first attempt to
	29	# clean up the generation so maybe one day we can move to something more self
	30	# documenting. (One might argue that an array of hashes of properties would
	31	# be easier to use.)
	32	#
	33	# Why we use the term regnode and nodes, and not say, opcodes, I am not sure.
	34
	35	# General thoughts:
	36	# 1. We use a single continuum to represent both opcodes and states,
	37	# and in regexec.c we switch on the combined set.
	38	# 2. Opcodes have more information associated to them, states are simpler,
	39	# basically just an identifier/number that can be used to switch within
	40	# the state machine.
	41	# 3. Some opcode are order dependent.
	42	# 4. Output files often use "tricks" to reduce diff effects. Some of what
	43	# we do below is more clumsy looking than it could be because of this.
	44
	45	# Op/state properties:
	46	#
	47	# Property In Descr
	48	# ----------------------------------------------------------------------------
	49	# name Both Name of op/state
	50	# id Both integer value for this opcode/state
	51	# optype Both Either 'op' or 'state'
e21ef692	52	# line_num Both line_num number of the input file for this item.
f83e001e	53	# type Op Type of node (aka regkind)
e21ef692 KW	54	# code Op Apparently not used
	55	# suffix Op which regnode struct this uses, so if this is '1', it
	56	# uses 'struct regnode_1'
	57	# flags Op S for simple; V for varies
46167d76	58	# longj Op Boolean as to if this node is a longjump
e21ef692 KW	59	# comment Both Comment about node, if any. Placed in perlredebguts
e21ef692 KW	60	# as its description
f83e001e	61	# pod_comment Both Special comments for pod output (preceding lines in def)
e21ef692	62	# Such lines begin with '#*'
f83e001e YO	63
	64	# Global State
	65	my @all; # all opcodes/state
	66	my %all; # hash of all opcode/state names
	67
	68	my @ops; # array of just opcodes
	69	my @states; # array of just states
	70
	71	my $longest_name_length= 0; # track lengths of names for nicer reports
	72	my (%type_alias); # map the type (??)
	73
	74	# register a newly constructed node into our state tables.
	75	# ensures that we have no name collisions (on name anyway),
	76	# and issues the "id" for the node.
	77	sub register_node {
	78	my ($node)= @_;
	79
	80	if ( $all{ $node->{name} } ) {
	81	die "Duplicate item '$node->{name}' in regcomp.sym line $node->{line_num} "
	82	. "previously defined on line $all{ $node->{name} }{line_num}\n";
	83	} elsif (!$node->{optype}) {
	84	die "must have an optype in node ", Dumper($node);
	85	} elsif ($node->{optype} eq "op") {
	86	push @ops, $node;
	87	} elsif ($node->{optype} eq "state") {
	88	push @states, $node;
	89	} else {
	90	die "Uknown optype '$node->{optype}' in ", Dumper($node);
03363afd	91	}
f83e001e YO	92	$node->{id}= 0 + @all;
	93	push @all, $node;
	94	$all{ $node->{name} }= $node;
46167d76 KW	95
	96	if ($node->{longj} && $node->{longj} != 1) {
	97	die "longj field must be in [01] if present in ", Dumper($node);
	98	}
	99
f83e001e	100	}
d3d47aac	101
f83e001e	102	# Parse and add an opcode definition to the global state.
e21ef692	103	# What an opcode definition looks like is given in regcomp.sym.
f83e001e	104	#
e21ef692 KW	105	# Not every opcode definition has all of the components. We should maybe make
e21ef692 KW	106	# this nicer/easier to read in the future. Also note that the above is tab
f83e001e YO	107	# sensitive.
f83e001e YO	108
e21ef692 KW	109	# Special comments for an entry precede it, and begin with '#*' and are placed
	110	# in the generated pod file just before the entry.
	111
f83e001e YO	112	sub parse_opcode_def {
	113	my ( $text, $line_num, $pod_comment )= @_;
	114	my $node= {
	115	line_num => $line_num,
	116	pod_comment => $pod_comment,
	117	optype => "op",
	118	};
d3d47aac	119
f83e001e YO	120	# first split the line into three, the initial NAME, a middle part
	121	# that we call "desc" which contains various (not well documented) things,
	122	# and a comment section.
	123	@{$node}{qw(name desc comment)}= /^(\S+)\s+([^\t]+?)\s;\s(.*)/
	124	or die "Failed to match $_";
d3d47aac	125
f83e001e	126	# the content of the "desc" field from the first step is extracted here:
484678fc	127	@{$node}{qw(type code suffix flags longj)}= split /[,\s]\s*/, $node->{desc};
d3d47aac	128
d1bd48a0	129	defined $node->{$_} or $node->{$_} = ""
484678fc	130	for qw(type code suffix flags longj);
f83e001e YO	131
	132	register_node($node); # has to be before the type_alias code below
	133
	134	if ( !$all{ $node->{type} } and !$type_alias{ $node->{type} } ) {
	135
	136	#warn "Regop type '$node->{type}' from regcomp.sym line $line_num"
	137	# ." is not an existing regop, and will be aliased to $node->{name}\n"
	138	# if -t STDERR;
	139	$type_alias{ $node->{type} }= $node->{name};
	140	}
	141
	142	$longest_name_length= length $node->{name}
	143	if length $node->{name} > $longest_name_length;
	144	}
	145
	146	# parse out a state definition and add the resulting data
	147	# into the global state. may create multiple new states from
	148	# a single definition (this is part of the point).
	149	# Format for states:
	150	# REGOP \t typelist [ \t typelist]
	151	# typelist= namelist
	152	# = namelist:FAIL
	153	# = name:count
	154	# Eg:
	155	# WHILEM A_pre,A_min,A_max,B_min,B_max:FAIL
	156	# BRANCH next:FAIL
	157	# CURLYM A,B:FAIL
	158	#
	159	# The CURLYM definition would create the states:
	160	# CURLYM_A, CURLYM_A_fail, CURLYM_B, CURLYM_B_fail
	161	sub parse_state_def {
	162	my ( $text, $line_num, $pod_comment )= @_;
	163	my ( $type, @lists )= split /\s+/, $text;
	164	die "No list? $type" if !@lists;
	165	foreach my $list (@lists) {
	166	my ( $names, $special )= split /:/, $list, 2;
	167	$special \|\|= "";
	168	foreach my $name ( split /,/, $names ) {
	169	my $real=
	170	$name eq 'resume'
	171	? "resume_$type"
	172	: "${type}_$name";
	173	my @suffix;
	174	if ( !$special ) {
	175	@suffix= ("");
	176	}
	177	elsif ( $special =~ /\d/ ) {
	178	@suffix= ( 1 .. $special );
	179	}
	180	elsif ( $special eq 'FAIL' ) {
	181	@suffix= ( "", "_fail" );
	182	}
	183	else {
	184	die "unknown :type ':$special'";
	185	}
	186	foreach my $suffix (@suffix) {
	187	my $node= {
	188	name => "$real$suffix",
	189	optype => "state",
	190	type => $type \|\| "",
	191	comment => "state for $type",
	192	line_num => $line_num,
	193	};
	194	register_node($node);
03363afd YO	195	}
03363afd YO	196	}
03363afd YO	197	}
03363afd YO	198	}
d09b2d29	199
f9ef50a7	200	sub process_flags {
f83e001e YO	201	my ( $flag, $varname, $comment )= @_;
	202	$comment= '' unless defined $comment;
	203
	204	my @selected;
	205	my $bitmap= '';
	206	for my $node (@ops) {
	207	my $set= $node->{flags} && $node->{flags} eq $flag ? 1 : 0;
	208
	209	# Whilst I could do this with vec, I'd prefer to do longhand the arithmetic
	210	# ops in the C code.
	211	my $current= do {
	212	no warnings;
	213	ord substr $bitmap, ( $node->{id} >> 3 );
	214	};
	215	substr( $bitmap, ( $node->{id} >> 3 ), 1 )=
	216	chr( $current \| ( $set << ( $node->{id} & 7 ) ) );
	217
	218	push @selected, $node->{name} if $set;
	219	}
	220	my $out_string= join ', ', @selected, 0;
	221	$out_string =~ s/(.{1,70},) /$1\n /g;
ded4dd2a	222
f83e001e	223	my $out_mask= join ', ', map { sprintf "0x%02X", ord $_ } split '', $bitmap;
ded4dd2a	224
f83e001e	225	return $comment . <<"EOP";
ded4dd2a	226	#define REGNODE_\U$varname\E(node) (PL_${varname}_bitmask[(node) >> 3] & (1 << ((node) & 7)))
e52fc539	227
f9ef50a7	228	#ifndef DOINIT
916e4025	229	EXTCONST U8 PL_${varname}\[] __attribute__deprecated__;
f9ef50a7	230	#else
916e4025	231	EXTCONST U8 PL_${varname}\[] __attribute__deprecated__ = {
f9ef50a7 NC	232	$out_string
	233	};
	234	#endif /* DOINIT */
	235
ded4dd2a NC	236	#ifndef DOINIT
	237	EXTCONST U8 PL_${varname}_bitmask[];
	238	#else
	239	EXTCONST U8 PL_${varname}_bitmask[] = {
	240	$out_mask
	241	};
	242	#endif /* DOINIT */
f9ef50a7 NC	243	EOP
	244	}
	245
f83e001e YO	246	sub read_definition {
	247	my ( $file )= @_;
	248	my ( $seen_sep, $pod_comment )= "";
	249	open my $in_fh, "<", $file
	250	or die "Failed to open '$file' for reading: $!";
	251	while (<$in_fh>) {
	252
	253	# Special pod comments
	254	if (/^#\* ?/) { $pod_comment .= "# $'"; }
	255
	256	# Truly blank lines possibly surrounding pod comments
	257	elsif (/^\s*$/) { $pod_comment .= "\n" }
	258
	259	next if /\A\s#/ \|\| /\A\s\z/;
	260
	261	s/\s*\z//;
	262	if (/^-+\s*$/) {
	263	$seen_sep= 1;
	264	next;
	265	}
	266
	267	if ($seen_sep) {
	268	parse_state_def( $_, $., $pod_comment );
	269	}
	270	else {
	271	parse_opcode_def( $_, $., $pod_comment );
	272	}
	273	$pod_comment= "";
	274	}
	275	close $in_fh;
	276	die "Too many regexp/state opcodes! Maximum is 256, but there are ", 0 + @all,
	277	" in file!"
	278	if @all > 256;
	279	}
	280
	281	# use fixed width to keep the diffs between regcomp.pl recompiles
	282	# as small as possible.
	283	my ( $width, $rwidth, $twidth )= ( 22, 12, 9 );
	284
	285	sub print_state_defs {
	286	my ($out)= @_;
	287	printf $out <<EOP,
6bda09f9 YO	288	/* Regops and State definitions */
6bda09f9 YO	289
03363afd YO	290	#define %*s\t%d
	291	#define %*s\t%d
	292
d09b2d29	293	EOP
f83e001e YO	294	-$width,
	295	REGNODE_MAX => $#ops,
	296	-$width, REGMATCH_STATE_MAX => $#all;
	297
	298	my %rev_type_alias= reverse %type_alias;
	299	for my $node (@ops) {
	300	printf $out "#define\t%s\t%d\t/ %#04x %s */\n",
	301	-$width, $node->{name}, $node->{id}, $node->{id}, $node->{comment};
	302	if ( defined( my $alias= $rev_type_alias{ $node->{name} } ) ) {
	303	printf $out "#define\t%s\t%d\t/ %#04x %s */\n",
	304	-$width, $alias, $node->{id}, $node->{id}, "type alias";
	305	}
	306	}
d3d47aac	307
f83e001e YO	308	print $out "\t/* ------------ States ------------- */\n";
	309	for my $node (@states) {
	310	printf $out "#define\t%s\t(REGNODE_MAX + %d)\t/ %s */\n",
	311	-$width, $node->{name}, $node->{id} - $#ops, $node->{comment};
	312	}
d09b2d29 IZ	313	}
d09b2d29 IZ	314
f83e001e YO	315	sub print_regkind {
	316	my ($out)= @_;
	317	print $out <<EOP;
03363afd	318
6bda09f9	319	/* PL_regkind[] What type of regop or state is this. */
d09b2d29 IZ	320
d09b2d29 IZ	321	#ifndef DOINIT
22c35a8c	322	EXTCONST U8 PL_regkind[];
d09b2d29	323	#else
22c35a8c	324	EXTCONST U8 PL_regkind[] = {
d09b2d29	325	EOP
f83e001e YO	326	use Data::Dumper;
	327	foreach my $node (@all) {
	328	print Dumper($node) if !defined $node->{type} or !defined( $node->{name} );
	329	printf $out "\t%s\t/ %s /\n",
	330	-1 - $twidth, "$node->{type},", -$width, $node->{name};
	331	print $out "\t/* ------------ States ------------- */\n"
	332	if $node->{id} == $#ops and $node->{id} != $#all;
	333	}
d09b2d29	334
f83e001e	335	print $out <<EOP;
d09b2d29 IZ	336	};
d09b2d29 IZ	337	#endif
f83e001e YO	338	EOP
	339	}
	340
	341	sub wrap_ifdef_print {
	342	my $out= shift;
	343	my $token= shift;
	344	print $out <<EOP;
	345
	346	#ifdef $token
	347	EOP
	348	$_->($out) for @_;
	349	print $out <<EOP;
	350	#endif /* $token */
	351
	352	EOP
	353	}
	354
	355	sub print_regarglen {
	356	my ($out)= @_;
	357	print $out <<EOP;
d09b2d29	358
6bda09f9	359	/* regarglen[] - How large is the argument part of the node (in regnodes) */
d09b2d29	360
29de9391	361	static const U8 regarglen[] = {
d09b2d29 IZ	362	EOP
d09b2d29 IZ	363
f83e001e YO	364	foreach my $node (@ops) {
f83e001e YO	365	my $size= 0;
484678fc	366	$size= "EXTRA_SIZE(struct regnode_$node->{suffix})" if $node->{suffix};
d09b2d29	367
f83e001e YO	368	printf $out "\t%s\t/ %s /\n", -37, "$size,", -$rwidth, $node->{name};
	369	}
	370
	371	print $out <<EOP;
d09b2d29	372	};
f83e001e YO	373	EOP
	374	}
	375
	376	sub print_reg_off_by_arg {
	377	my ($out)= @_;
	378	print $out <<EOP;
d09b2d29	379
6bda09f9 YO	380	/* reg_off_by_arg[] - Which argument holds the offset to the next node */
6bda09f9 YO	381
29de9391	382	static const char reg_off_by_arg[] = {
d09b2d29 IZ	383	EOP
d09b2d29 IZ	384
f83e001e YO	385	foreach my $node (@ops) {
f83e001e YO	386	my $size= $node->{longj} \|\| 0;
9b155405	387
f83e001e YO	388	printf $out "\t%d,\t/* %s /\n", $size, -$rwidth, $node->{name};
f83e001e YO	389	}
d09b2d29	390
f83e001e	391	print $out <<EOP;
d09b2d29	392	};
9b155405	393
f83e001e YO	394	EOP
	395	}
	396
	397	sub print_reg_name {
	398	my ($out)= @_;
	399	print $out <<EOP;
13d6edb4	400
6bda09f9 YO	401	/* reg_name[] - Opcode/state names in string form, for debugging */
6bda09f9 YO	402
22429478	403	#ifndef DOINIT
13d6edb4	404	EXTCONST char * PL_reg_name[];
22429478	405	#else
4764e399	406	EXTCONST char * const PL_reg_name[] = {
9b155405 IZ	407	EOP
9b155405 IZ	408
f83e001e YO	409	my $ofs= 0;
	410	my $sym= "";
	411	foreach my $node (@all) {
	412	my $size= $node->{longj} \|\| 0;
	413
	414	printf $out "\t%s\t/ $sym%#04x */\n",
	415	-3 - $width, qq("$node->{name}",), $node->{id} - $ofs;
	416	if ( $node->{id} == $#ops and @ops != @all ) {
	417	print $out "\t/* ------------ States ------------- */\n";
	418	$ofs= $#ops;
	419	$sym= 'REGNODE_MAX +';
	420	}
	421	}
9b155405	422
f83e001e	423	print $out <<EOP;
9b155405	424	};
22429478	425	#endif /* DOINIT */
d09b2d29	426
337ff307	427	EOP
f83e001e	428	}
337ff307	429
f83e001e YO	430	sub print_reg_extflags_name {
	431	my ($out)= @_;
	432	print $out <<EOP;
f7819f85 A	433	/* PL_reg_extflags_name[] - Opcode/state names in string form, for debugging */
	434
	435	#ifndef DOINIT
	436	EXTCONST char * PL_reg_extflags_name[];
	437	#else
	438	EXTCONST char * const PL_reg_extflags_name[] = {
d09b2d29 IZ	439	EOP
d09b2d29 IZ	440
f83e001e YO	441	my %rxfv;
	442	my %definitions; # Remember what the symbol definitions are
	443	my $val= 0;
	444	my %reverse;
	445	my $REG_EXTFLAGS_NAME_SIZE= 0;
	446	foreach my $file ( "op_reg_common.h", "regexp.h" ) {
	447	open my $in_fh, "<", $file or die "Can't read '$file': $!";
	448	while (<$in_fh>) {
	449
	450	# optional leading '_'. Return symbol in $1, and strip it from
f2323142 KW	451	# comment of line. Currently doesn't handle comments running onto
f2323142 KW	452	# next line
f83e001e YO	453	if (s/^ \# \s* define \s+ ( _? RXf_ \w+ ) \s+ //xi) {
	454	chomp;
	455	my $define= $1;
	456	my $orig= $_;
	457	s{ /\* .? \/ }{ }x; # Replace comments by a blank
	458
	459	# Replace any prior defined symbols by their values
	460	foreach my $key ( keys %definitions ) {
	461	s/\b$key\b/$definitions{$key}/g;
	462	}
5c72e80d	463
f83e001e YO	464	# Remove the U suffix from unsigned int literals
f83e001e YO	465	s/\b([0-9]+)U\b/$1/g;
5c72e80d	466
f83e001e	467	my $newval= eval $_; # Get numeric definition
6a080ccd	468
f83e001e	469	$definitions{$define}= $newval;
6a080ccd	470
f83e001e YO	471	next unless $_ =~ /<</; # Bit defines use left shift
	472	if ( $val & $newval ) {
	473	my @names= ( $define, $reverse{$newval} );
	474	s/PMf_// for @names;
	475	if ( $names[0] ne $names[1] ) {
	476	die sprintf
	477	"ERROR: both $define and $reverse{$newval} use 0x%08X (%s:%s)",
	478	$newval, $orig, $_;
	479	}
	480	next;
6976c986	481	}
f83e001e YO	482	$val \|= $newval;
	483	$rxfv{$define}= $newval;
	484	$reverse{$newval}= $define;
1850c8f9	485	}
6a080ccd	486	}
f7819f85	487	}
f83e001e YO	488	my %vrxf= reverse %rxfv;
	489	printf $out "\t/* Bits in extflags defined: %s /\n", unpack 'B', pack 'N',
	490	$val;
	491	my %multibits;
	492	for ( 0 .. 31 ) {
	493	my $power_of_2= 2**$_;
	494	my $n= $vrxf{$power_of_2};
	495	my $extra= "";
	496	if ( !$n ) {
	497
	498	# Here, there was no name that matched exactly the bit. It could be
	499	# either that it is unused, or the name matches multiple bits.
	500	if ( !( $val & $power_of_2 ) ) {
	501	$n= "UNUSED_BIT_$_";
	502	}
	503	else {
	504
	505	# Here, must be because it matches multiple bits. Look through
	506	# all possibilities until find one that matches this one. Use
	507	# that name, and all the bits it matches
	508	foreach my $name ( keys %rxfv ) {
	509	if ( $rxfv{$name} & $power_of_2 ) {
	510	$n= $name . ( $multibits{$name}++ );
	511	$extra= sprintf qq{ : "%s" - 0x%08x}, $name,
	512	$rxfv{$name}
	513	if $power_of_2 != $rxfv{$name};
	514	last;
	515	}
5458d9a0 KW	516	}
	517	}
	518	}
f83e001e YO	519	s/\bRXf_(PMf_)?// for $n, $extra;
	520	printf $out qq(\t%-20s/* 0x%08x%s */\n), qq("$n",), $power_of_2, $extra;
	521	$REG_EXTFLAGS_NAME_SIZE++;
5458d9a0	522	}
f83e001e YO	523
f83e001e YO	524	print $out <<EOP;
f7819f85 A	525	};
	526	#endif /* DOINIT */
	527
adc2d0c9 JH	528	#ifdef DEBUGGING
	529	# define REG_EXTFLAGS_NAME_SIZE $REG_EXTFLAGS_NAME_SIZE
	530	#endif
f83e001e	531	EOP
adc2d0c9	532
337ff307	533	}
f83e001e YO	534
	535	sub print_reg_intflags_name {
	536	my ($out)= @_;
	537	print $out <<EOP;
	538
337ff307 YO	539	/* PL_reg_intflags_name[] - Opcode/state names in string form, for debugging */
	540
	541	#ifndef DOINIT
	542	EXTCONST char * PL_reg_intflags_name[];
	543	#else
	544	EXTCONST char * const PL_reg_intflags_name[] = {
	545	EOP
	546
f83e001e YO	547	my %rxfv;
	548	my %definitions; # Remember what the symbol definitions are
	549	my $val= 0;
	550	my %reverse;
	551	my $REG_INTFLAGS_NAME_SIZE= 0;
	552	foreach my $file ("regcomp.h") {
	553	open my $fh, "<", $file or die "Can't read $file: $!";
	554	while (<$fh>) {
	555
	556	# optional leading '_'. Return symbol in $1, and strip it from
	557	# comment of line
	558	if (
	559	m/^ \# \s* define \s+ ( PREGf_ ( \w+ ) ) \s+ 0x([0-9a-f]+)(?:\s\/\(.)\\/)?/xi
	560	)
	561	{
	562	chomp;
	563	my $define= $1;
	564	my $abbr= $2;
	565	my $hex= $3;
	566	my $comment= $4;
	567	my $val= hex($hex);
	568	$comment= $comment ? " - $comment" : "";
	569
	570	printf $out qq(\t%-30s/* 0x%08x - %s%s */\n), qq("$abbr",),
	571	$val, $define, $comment;
	572	$REG_INTFLAGS_NAME_SIZE++;
	573	}
337ff307 YO	574	}
337ff307 YO	575	}
337ff307	576
f83e001e	577	print $out <<EOP;
337ff307 YO	578	};
	579	#endif /* DOINIT */
	580
	581	EOP
f83e001e	582	print $out <<EOQ;
adc2d0c9 JH	583	#ifdef DEBUGGING
	584	# define REG_INTFLAGS_NAME_SIZE $REG_INTFLAGS_NAME_SIZE
	585	#endif
337ff307	586
adc2d0c9 JH	587	EOQ
adc2d0c9 JH	588	}
f9ef50a7	589
f83e001e YO	590	sub print_process_flags {
	591	my ($out)= @_;
	592
	593	print $out process_flags( 'V', 'varies', <<'EOC');
f9ef50a7 NC	594	/* The following have no fixed length. U8 so we can do strchr() on it. */
	595	EOC
	596
f83e001e	597	print $out process_flags( 'S', 'simple', <<'EOC');
ce716c52	598
f9ef50a7 NC	599	/* The following always have a length of 1. U8 we can do strchr() on it. */
	600	/* (Note that length 1 means "one character" under UTF8, not "one octet".) */
	601	EOC
	602
f83e001e	603	}
65aa4ca7	604
f83e001e YO	605	sub do_perldebguts {
f83e001e YO	606	my $guts= open_new( 'pod/perldebguts.pod', '>' );
65aa4ca7	607
f83e001e YO	608	my $node;
	609	my $code;
	610	my $name_fmt= '<' x ( $longest_name_length - 1 );
	611	my $descr_fmt= '<' x ( 58 - $longest_name_length );
	612	eval <<EOD or die $@;
65aa4ca7 FC	613	format GuTS =
65aa4ca7 FC	614	^*~~
f83e001e	615	\$node->{pod_comment}
95fe686d	616	^$name_fmt ^<<<<<<<<< ^$descr_fmt~~
d1bd48a0	617	\$node->{name}, \$code, defined \$node->{comment} ? \$node->{comment} : ''
65aa4ca7	618	.
f83e001e	619	1;
65aa4ca7	620	EOD
f83e001e YO	621
	622	my $old_fh= select($guts);
	623	$~= "GuTS";
65aa4ca7	624
1ae6ead9	625	open my $oldguts, '<', 'pod/perldebguts.pod'
65aa4ca7	626	or die "$0 cannot open pod/perldebguts.pod for reading: $!";
f83e001e	627	while (<$oldguts>) {
65aa4ca7 FC	628	print;
	629	last if /=for regcomp.pl begin/;
	630	}
	631
f83e001e	632	print <<'END_OF_DESCR';
65aa4ca7	633
e21ef692	634	# TYPE arg-description [regnode-struct-suffix] [longjump-len] DESCRIPTION
f83e001e YO	635	END_OF_DESCR
	636	for my $n (@ops) {
	637	$node= $n;
484678fc	638	$code= "$node->{code} " . ( $node->{suffix} \|\| "" );
f83e001e YO	639	$code .= " $node->{longj}" if $node->{longj};
	640	if ( $node->{pod_comment} \|\|= "" ) {
	641
65aa4ca7	642	# Trim multiple blanks
f83e001e YO	643	$node->{pod_comment} =~ s/^\n\n+/\n/;
f83e001e YO	644	$node->{pod_comment} =~ s/\n\n+$/\n\n/;
65aa4ca7 FC	645	}
	646	write;
	647	}
	648	print "\n";
	649
f83e001e	650	while (<$oldguts>) {
65aa4ca7 FC	651	last if /=for regcomp.pl end/;
65aa4ca7 FC	652	}
4ac5f10b DD	653	do { print } while <$oldguts>; #win32 can't unlink an open FH
4ac5f10b DD	654	close $oldguts or die "Error closing pod/perldebguts.pod: $!";
f83e001e YO	655	select $old_fh;
	656	close_and_rename($guts);
	657	}
65aa4ca7	658
f83e001e YO	659	read_definition("regcomp.sym");
	660	my $out= open_new( 'regnodes.h', '>',
	661	{ by => 'regen/regcomp.pl', from => 'regcomp.sym' } );
	662	print_state_defs($out);
	663	print_regkind($out);
	664	wrap_ifdef_print(
	665	$out,
	666	"REG_COMP_C",
	667	\&print_regarglen,
	668	\&print_reg_off_by_arg
	669	);
	670	print_reg_name($out);
	671	print_reg_extflags_name($out);
	672	print_reg_intflags_name($out);
	673	print_process_flags($out);
	674	read_only_bottom_close_and_rename($out);
65aa4ca7	675
f83e001e	676	do_perldebguts();