Moved definition of widget class to gtktypes.lisp

[clg] / tools / makeenums.pl

#!/usr/bin/perl -w

# Information about the current enumeration
# Modifed to generate output for clg


my $flags;			# Is enumeration a bitmask
my $seenbitshift;			# Have we seen bitshift operators?
my $prefix;			# Prefix for this enumeration
my $enumname;			# Name for this enumeration
my $firstenum = 1;		# Is this the first enumeration in file?
my @entries;			# [ $name, $val ] for each entry

sub parse_options {
    my $opts = shift;
    my @opts;

    for $opt (split /\s*,\s*/, $opts) {
	my ($key,$val) = $opt =~ /\s*(\w+)(?:=(\S+))?/;
	defined $val or $val = 1;
	push @opts, $key, $val;
    }
    @opts;
}
sub parse_entries {
    my $file = shift;

    while (<$file>) {
	# Read lines until we have no open comments
	while (m@/\*
	       ([^*]|\*(?!/))*$
	       @x) {
	    my $new;
	    defined ($new = <$file>) || die "Unmatched comment";
	    $_ .= $new;
	}
	# Now strip comments
	s@/\*(?!<)
	    ([^*]+|\*(?!/))*
	   \*/@@gx;
	
	s@\n@ @;
	
	next if m@^\s*$@;

	# Handle include files
	if (/^\#include\s*<([^>]*)>/ ) {
            my $file= "../$1";
	    open NEWFILE, $file or die "Cannot open include file $file: $!\n";
	    
	    if (parse_entries (\*NEWFILE)) {
		return 1;
	    } else {
		next;
	    }
	}
	
	if (/^\s*\}\s*(\w+)/) {
	    $enumname = $1;
	    return 1;
	}

	if (m@^\s*
              (\w+)\s*		         # name
              (?:=(                      # value
                   (?:[^,/]|/(?!\*))*
                  ))?,?\s*
              (?:/\*<		         # options 
                (([^*]|\*(?!/))*)
               >\*/)?
              \s*$
             @x) {
	    my ($name, $value, $options) = ($1,$2,$3);

	    if (!defined $flags && defined $value && $value =~ /<</) {
		$seenbitshift = 1;
	    }
	    if (defined $options) {
		my %options = parse_options($options);
		if (!defined $options{skip}) {
		    push @entries, [ $name, $value, $options{nick} ];
		}
	    } else {
		push @entries, [ $name, $value ];
	    }
	} else {
	    print STDERR "Can't understand: $_\n";
	}
    }
    return 0;
}

sub make_lispname {
    my $enumname = shift;

    $enumname =~ s/([A-Z])/-$1/g;
    return substr (lc ($enumname), 5);
}


my $gen_arrays = 0;
my $gen_defs = 0;

# Parse arguments

if (@ARGV) {
    if ($ARGV[0] eq "arrays") {
	shift @ARGV;
	$gen_arrays = 1;
    } elsif ($ARGV[0] eq "defs") {
	shift @ARGV;
	$gen_defs = 1;
    } else {
	$gen_defs = 1;
    }
    
}

if ($gen_defs) {
    print ";; generated by a modified makeenums.pl  ; -*- lisp -*-\n\n";
} else {
    print "/* Generated by makeenums.pl */\n\n";
}

ENUMERATION:
while (<>) {
    if (eof) {
	close (ARGV);		# reset line numbering
	$firstenum = 1;		# Flag to print filename at next enum
    }

    if (m@^\s*typedef\s+enum\s*
           ({)?\s*
           (?:/\*<
             (([^*]|\*(?!/))*)
            >\*/)?
         @x) {
	if (defined $2) {
	    my %options = parse_options($2);
	    $prefix = $options{prefix};
	    $flags = $options{flags};
	} else {
	    $prefix = undef;
	    $flags = undef;
	}
	# Didn't have trailing '{' look on next lines
	if (!defined $1) {
	    while (<>) {
		if (s/^\s*\{//) {
		    last;
		}
	    }
	}

	$seenbitshift = 0;
	@entries = ();

	# Now parse the entries
	parse_entries (\*ARGV);

	# figure out if this was a flags or enums enumeration

	if (!defined $flags) {
	    $flags = $seenbitshift;
	}

	# Autogenerate a prefix

	if (!defined $prefix) {
	    for (@entries) {
		my $name = $_->[0];
		if (defined $prefix) {
		    my $tmp = ~ ($name ^ $prefix);
		    ($tmp) = $tmp =~ /(^\xff*)/;
		    $prefix = $prefix & $tmp;
		} else {
		    $prefix = $name;
		}
	    }
	    # Trim so that it ends in an underscore
	    $prefix =~ s/_[^_]*$/_/;
	}
	
	for $entry (@entries) {
	    my ($name,$value,$nick) = @{$entry};

            if (!defined $nick) {
 	        ($nick = $name) =~ s/^$prefix//;
	        $nick =~ tr/_/-/;
	        $nick = lc($nick);
	        @{$entry} = ($name, $value, $nick);
            }
	}

	# Spit out the output

	if ($gen_defs) {
	    if ($firstenum) {
		print qq(\n; enumerations from "$ARGV"\n);
		$firstenum = 0;
	    }
	    
	    my $lispname = make_lispname ($enumname);
	    print "\n(deftype (".$lispname." \"".$enumname."\") ()\n  '(". ($flags ? "flags" : "enum");

	    my $comment;
	    for (@entries) {
		my ($name,$value,$nick) = @{$_};

		$comment = 0;
		if (defined $value) {
		    $value =~ s/0x/\#x/;
		    
		    print "\n";
		    if ($flags && not ($value =~ s/1\s+<<\s+(\d+)/$1/)) {
			print ";";
			$comment = 1;
		    }
		    
		    print "    (:$nick $value)";
		} else {
		    print "\n    :$nick";
		}
	    }
	    if ($comment) {
		print "\n   ";
	    }
	    print "))\n";

	} else {
	    my $valuename = $enumname;
            $valuename =~ s/([^A-Z])([A-Z])/$1_$2/g;
            $valuename =~ s/([A-Z][A-Z])([A-Z][0-9a-z])/$1_$2/g;
            $valuename = lc($valuename);

	    print "static const GtkEnumValue _${valuename}_values[] = {\n";
	    for (@entries) {
		my ($name,$value,$nick) = @{$_};
		print qq(  { $name, "$name", "$nick" },\n);
	    }
	    print "  { 0, NULL, NULL }\n";
	    print "};\n";
	}
    }
}