#!/usr/bin/perl -w
################################################################################
#
# Copyright (C) 1998-2000, Ashley Winters <jql@accessone.com>
# All rights reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
use Carp;
$| = 1;
umask 0;
use strict;
my %Types;
my %Cast;
my %Info;
my %Input;
my %Methods;
my %Prototypes;
my %IncCache;
my %Inclusive; # All virtual methods in class and superclasses
my %Exclusive; # Virtual methods first defined in this class
my $Ext = '.pig';
my $Module = '';
my $Class = '';
my $Path = '';
my $File = '';
my $Line = 0;
my(%Operator) = (
"=" => "newcopy",
"()" => "run",
"==" => "beq",
"!=" => "bne",
"*" => "bmul",
"/" => "bdiv",
"+" => "badd",
"-" => "bsub",
"neg" => "uneg",
"*=" => "amul",
"/=" => "adiv",
"+=" => "aadd",
"-=" => "asub",
"<<" => "serialize",
">>" => "deserialize"
);
my $Source = 'src';
my $Sourcedir;
my $Libdir = 'lib';
my $VirtualHeader;
my($Sourcefile, $Headerfile);
my(@ClassList, %ConstantList);
my @Vtbl;
my @VtblIn;
my %LinkList;
my(@Modules, @I, @Include, @l, @L, @S, @r, @c);
my($verbose, $silent, $pedantic);
my $Indent;
my $Method;
my @sourcefiles; # list of files to save;
#&main(); # Start of the program, bottom of the application
sub whisper { print @_ unless $silent }
sub say { whisper @_ unless $verbose }
sub verbose { whisper $_[0] if $verbose }
sub veryverbose { whisper $_[0] if $verbose && $verbose > 1 }
sub source { print SOURCE @_ }
sub header { print HEADER @_ }
sub vheader { print VHEADER @_ }
sub iheader { print IHEADER @_ }
package PerlQt::Method;
sub constructor {
my $self = shift;
return ($self->{'Name'} eq 'new');
}
sub destructor {
my $self = shift;
return ($self->{'Name'} eq 'DESTROY');
}
sub virtual {
my $self = shift;
return (defined($self->{'Virtual'}) &&
$self->{'Virtual'} ne 'static' &&
$self->{'Virtual'} ne 'variable');
}
sub variable {
my $self = shift;
return (defined($self->{'Virtual'}) && $self->{'Virtual'} eq 'variable');
}
sub abstract {
my $self = shift;
return (defined($self->{'Virtual'}) && $self->{'Virtual'} eq 'abstract');
}
sub static {
my $self = shift;
return ($self->constructor || defined $self->{'Virtual'} && $self->{'Virtual'} eq 'static');
}
sub private {
my $self = shift;
return ($self->{'Protection'} eq 'private');
}
sub protected {
my $self = shift;
return ($self->{'Protection'} eq 'protected');
}
sub public {
my $self = shift;
return ($self->{'Protection'} eq 'public');
}
sub const {
my $self = shift;
return $self->{'Const'} || "";
}
sub purpose {
my $self = shift;
return $self->{'Purpose'};
}
sub perlonly {
my $self = shift;
return ($self->purpose eq '&');
}
sub cpponly {
my $self = shift;
return ($self->purpose eq '^');
}
sub everylang {
my $self = shift;
return ($self->purpose eq '*');
}
package PerlQt::ClassInfo;
sub alias {
my $self = shift;
return $self->{'Alias'}[0] if exists $self->{'Alias'};
return ();
}
sub define {
my $self = shift;
return @{$self->{'Define'}} if exists $self->{'Define'};
return ();
}
sub undefine {
my $self = shift;
return @{$self->{'Undef'}} if exists $self->{'Undef'};
return ();
}
sub include {
my $self = shift;
return @{$self->{'Include'}} if exists $self->{'Include'};
return ();
}
sub inherit {
my $self = shift;
return @{$self->{'Inherit'}} if exists $self->{'Inherit'};
return ();
}
sub virtual {
my $self = shift;
return @{$self->{'Virtual'}} if exists $self->{'Virtual'};
return ();
}
sub export {
my $self = shift;
return @{$self->{'Export'}} if exists $self->{'Export'};
return ();
}
sub class {
my $self = shift;
return (!exists $self->{'Class'} || $self->{'Class'});
}
sub copy {
my $self = shift;
return (exists $self->{'Copy'} && $self->{'Copy'});
}
package main;
################################################################################
#
# &cpp_type($psuedotype)
#
# Takes a &slurped psuedo-type and converts it into its C++-equivalent
# value.
#
# Returns a string which indicates the type of C++ argument $psuedotype
# represents.
#
sub cpp_type {
my $arg = shift;
$arg =~ s/\{.*\}//;
$arg =~ s/=.*//;
$arg =~ s/^\s*//;
$arg =~ s/\s*$//;
return $arg;
}
################################################################################
#
# &polyname($proto)
#
# Enhance the method-name of a prototype to indicate argument number and
# types.
#
# Returns a string which can be used to compare two prototypes and check for
# an exact C++ inheritance-override match.
#
sub polyname {
my $proto = shift;
my $name;
# cpp_type($proto->{'Returns'});
$name = $proto->{'Method'};
$name .= "(";
my $x = 0;
for my $argname (@{$proto->{'Arguments'}}) {
next unless $x++ || $proto->static;
my $arg = cpp_type($argname);
$name .= "," if ($x - (1 - $proto->static)) > 1;
$name .= $arg;
}
$name .= ")";
$name =~ s/\bconst\b//g;
$name =~ s/\s+//g;
$name .= 'static' if $proto->static;
return $name;
}
################################################################################
#
# &getline(\*fileglob)
#
# Read a single prototype from $fileglobref for &slurp. The new prototype is
# saved in $_. Erroneous prototypes are passed through without warning.
#
# The line is saved in $_. The line-number (for debugging) is saved in $line.
# Returns true while not EOF.
#
# This is where any C++ => pig translation would need to take place.
# &slurp is a sacred function, and should not be touched by mere mortals.
# &getline is far more useful to the huddled masses yearning to add features.
#
sub getline {
my $handle = shift;
$Line = 0 if $Line eq "EOF";
$_ = readline(*$handle);
$Line++;
s~//.*~~ if $_; # remove comments
unless(defined $_ && !eof(*$handle)) {
$Line = "EOF";
return 0 unless defined $_;
}
return 1;
}
################################################################################
#
# &slurp(\*fileglob)
#
# Read from $fileglobref, parse it, save it in usable data-structures.
#
#
sub slurp {
my $source = shift;
my(@include, @define, @undef, @alias);
my($class, $protection);
my $info;
PARSE:
while(getline($source)) {
warn "Missing newline in $File ($Line): $_\n" unless chomp || !$pedantic;
########################### This section needs some cleanup
if(/^\#(include|define|undef)\s*(.*)$/) {
my $type = $1;
my $arg = $2;
if($type eq 'include') { #include <file.h>
if($arg =~ /^\<(.*)\>$/) {
push @include, $1;
} else {
warn "Bad \#include directive [$_] in $File ($Line)\n";
}
} elsif($type eq 'define') { #define THIS or #define THIS that
if($arg =~ /^(\w+)(\s+.+|)$/) {
push @define, ($2 ? "$1=$2" : $1);
} else {
warn "Bad \#define directive [$_] in $File ($Line)\n";
}
} elsif($type eq 'undef') { #undef THIS
if($arg =~ /^(\w+)\s*$/) {
push @undef, $arg;
} else {
warn "Bad \#undef directive [$_] in $File ($Line)\n";
}
}
next PARSE;
}
# s/\#.*//;
s/^\#/^/;
s/^\/\//\&/;
s/;.*/;/;
if(/^\s*enum\s+\w*\s*\{/) { # begin enumeration
my $enum = $_;
until($enum =~ /\}\;/) {
last PARSE unless getline($source);
warn "Missing newline in $File ($Line): $_\n" unless chomp || !$pedantic;
$enum .= $_;
}
$enum =~ /^\s*enum\s+\w*\s*\{(.*?)\}\;/;
my(@enum) = map { /(\w+)/; $1 } split /,\s*/, $1;
if($class) {
for my $e (@enum) {
$Info{$class}{'Constant'}{$e}{'Type'} = 'enum';
}
# print "Complete enum: $class\::@enum\n";
} else {
for my $e (@enum) {
$Info{$Class}{'Global'}{$e}{'Type'} = 'enum';
}
# print "Global enum: $Class\::@enum\n";
}
next PARSE;
}
if(/^\s*(?:extern\s+)?const\s+(\w+\s*?(?:\*|\&)*)\s*(\w+)\s*\;$/) {
if($class) {
$Info{$class}{'Constant'}{$2}{'Type'} = $1;
# print "Const $1 $class\::$2\n";
} else {
$Info{$Class}{'Global'}{$2}{'Type'} = $1;
# print "Global $1 $Class\::$2\n";
}
next PARSE;
}
if(/^
(suicidal\s+|) # don't delete on destroy?
(virtual\s+|) # virtual class
(class|struct|namespace)\s+ # must have the word 'class' or 'struct'
(\w+)\s* # (virtual)? class QClass
(:.*|) # (virtual)? class QClass : QSuper
\{\s* # (virtual)? class QClass : QSuper {
$/x) {
my($suicidal, $v, $t, $c, $s) = ($1, $2, $3, $4, $5);
$class = $c;
$Info{$class} = $Input{$class}{"\$"}{$class} = {};
$info = bless $Info{$class}, 'PerlQt::ClassInfo';
push @{$info->{'Virtual'}}, $class if $v;
$info->{'Copy'} = 1 if $t eq 'struct';
$info->{'Class'} = 0 if $t eq 'namespace';
$info->{'Suicidal'} = 1 if $suicidal;
$protection = 'public';
if($s) {
my(@list) = split(',', $s);
for my $super (@list) {
if($super =~ /^:?\s*(virtual\s+|)(\w+)\s*$/) {
push @{$info->{'Inherit'}}, $2;
push @{$info->{'Virtual'}}, $2 if $1;
}
}
}
next;
}
if(/^\}(.*);\s*$/) {
for my $alias (split(',', $1)) {
$alias =~ s/^\s*(.*?)\s*$/$1/;
push @alias, $alias;
}
# Since this is the end of the class, we populate $Info{$class}
$Info{$class}{'Alias'} = \@alias if @alias;
$Info{$class}{'Include'} = \@include if @include;
$Info{$class}{'Define'} = \@define if @define;
$Info{$class}{'Undef'} = \@undef if @undef;
$class = undef;
next;
}
if($class) {
if(/^\s*(public|protected|private):\s*$/) {
$protection = $1;
next;
}
s/^(\*|\&|\^|)\s*
((?:(?:virtual|abstract|static|variable)\s+)?)
(const\s+|)
((?:\w+\s*[\*\&]+\s*|[\w:\<\>\*]+\s*\*?[^\w\(\:\{]|[\w:]+\s+)?)
(\{.*?\}\s*|)
(~?\w+\s*\(.*|operator.*)
/$1$protection $2$3$4$5$class\::$6/x;
# print "$_\n";
}
########################### End of nasty section
if(/^ # Method parsing regex
(\+|-|) # $1 => method-diffs. Defaults to "+" if unspecified
(\*|\^|\&|) # $2 => purpose. Defaults to "*"
(.*?) # $3 => protection? attribute? return-type?
\s* # C++ type voodoo =~ m!type\s*(\**\s*)*&?\s*!
(\w+):: # $4 => class-name
(operator\s*\S+ # allow "operator ()" without choking the regex
|~?\w+) # $5 => method-name, allow "~destructor"
\s* # allow "type class::method ()"
\((.*?)\) # $6 => end this argument-list with a space or a ;
(?:\s+([:\w].*))? # $7 => post-arg modifiers and colon-substitutes
; # EVERY method must be terminated with a semi-colon!
(?:\s*\#.*)? # toss any comments at the end of the line
$/x) {
my($sign, $purpose, $ret, $class, $method, $args, $mod) =
($1, $2, $3, $4, $5, $6, $7);
my($perlname, $prot, $virt, $const, $sigslot, $code);
my @args;
# unified diff format, + means add, - means remove
$sign = "+" unless $sign; # default to + (add)
# "*" means visible in Perl and C++
# "&" means visible in Perl
# "^" means visible in C++
$purpose = "*" unless $purpose;
# Class::~Class() => Class::DESTROY
# Class::Class() => Class::new
# Class::operator ?? () => Class::$operator{??}
# Class::method(...) => Class::method
$perlname = ($method =~ /^~/) ? "DESTROY" :
($method eq $class) ? "new" :
($method =~ /operator\s*(.*)$/) ? $Operator{$1} :
$method;
# ^public|protected|private virtual|abstract|static|variable ...+
if($ret =~ s/^(public|protected|private)\s*//) { $prot = $1 }
if($ret =~ s/^(virtual|abstract|static|variable|)\s*//) {
$virt = $1 if $1;
}
if($ret =~ s/^\.{3,}$//) { $ret = length($ret) - 3 }
$prot = "public" unless defined $prot; # default to public
# Class::Class() => Class *Class::Class()
# Class::~Class() => void Class::~Class()
unless($ret) {
if($perlname eq "new") { $ret = "$class *" }
elsif($perlname eq "DESTROY") { $ret = "void" }
else { warn "No return-type [$_] in $File ($Line)\n" }
}
# Class::method() : $this->method();
# Class::method() signal;
# Class::method() const;
if($mod) {
my $origmod = $mod;
if($mod =~ s/\s*:\s*(.*)//) { $code = $1 }
if($mod =~ s/\s*\b(slot|signal)\b\s*//) { $sigslot = $1 }
if($mod =~ s/\s*\bconst\b\s*//) { $const = 1 }
if($mod) {
warn "Invalid method-modifier [$origmod] ($mod) " .
"in $File ($Line)\n";
}
}
# Class::method(...) => Class::method(AV *);
# Class::method(.....) => Class::method(SV *, SV *);
# Class::method(type1 = Thing(6,7,8,9), that2 = this);
# while($args =~ s/^,?\s*([^,\{]+)(\{.*\})?\s*//) {
for my $arg (split(/,\s+/, $args)) {
push @args, $arg;
# if($arg eq "...") {
# push @args, "...";
#"AV *";
# } elsif($arg =~ /^\.{4,}$/) {
# push @args, ("SV *") x (length($arg) - 3);
# } else {
# }
}
# Class::method(int) => Class::method(Class *, int)
# Class::method() const => Class::method(const Class *)
if($perlname ne "new" && (!defined $virt || $virt ne "static")) {
my $arg;
$arg .= "const " if defined $const;
$arg .= "$class *";
unshift @args, $arg;
}
my $info = bless {
Name => $perlname, # Perl method-name
File => \$File, # Filename (for warnings)
Line => $Line, # Line-number (for warnings)
Prototype => $_, # Actual prototype (for warnings)
Diff => $sign, # Add or remove?
Purpose => $purpose, # C++ or Perl or Both?
Protection => $prot, # private/protected/public
Virtual => $virt, # abstract/virtual/static
Returns => $ret, # Return-type
Class => $class, # Classname for *this and inheritance
Method => $method, # Method-name for this->Method()
Arguments => \@args, # Argument-list ref
SigSlot => $sigslot, # signal/slot
Const => $const, # const?
Code => $code # Everything between the : and the ;
}, 'PerlQt::Method';
push @{$Input{$Class}{'Proto'}}, $info;
push @{$Methods{$Class}{$perlname}}, $info;
$Prototypes{$Class}{&polyname($info)} = $info;
} # end if(proto)
elsif(/\S/) {
warn "Invalid line $Line in $File: $_\n"
unless /^\s*;$/;
}
}
}
use Cwd;
sub arguments {
my(@args) = @_;
push @I, cwd . "/include";
push @L, cwd . "/lib";
for(my $i = 0; $i < @args; $i++) {
if($args[$i] =~ /^-(.)(.*)/) {
my($opt, $arg) = ($1, $2);
if($opt eq 'v') {
$verbose = 1;
$verbose += length($arg) if $arg =~ /^v+$/;
} elsif($opt eq 's') {
$silent = 1;
} elsif($opt eq 'p') {
$pedantic = 1;
} elsif($opt eq 'o') {
$Source = $arg ? $arg : $args[++$i];
} elsif($opt eq 'I') {
push @I, $arg ? $arg : $args[++$i];
} elsif($opt eq 'L') {
push @L, $arg ? $arg : $args[++$i];
} elsif($opt eq 'S') {
push @S, $arg ? $arg : $args[++$i];
} elsif($opt eq 'i' && $arg eq 'nclude') {
push @Include, $args[++$i];
} elsif($opt eq 'l') {
push @l, $arg ? $arg : $args[++$i];
} elsif($opt eq 'r') {
my $a = $arg ? $arg : $args[++$i];
$a = "pig_$a";
push @l, $a;
} elsif($opt eq 'c') {
push @c, $arg ? $arg : $args[++$i];
} else {
push @Modules, $args[$i];
}
} else {
push @Modules, $args[$i];
}
}
}
sub find ($) {
my $module = shift;
my(@path) = ('.', @S);
for my $path (@path) {
return "$path/$module" if -d "$path/$module";
}
local($") = "', '";
warn "Cannot find $module in ('@path') for $Class\n";
return undef;
}
sub ismod ($) {
my $module = shift;
my(@path) = ('.', @S);
for my $path (@path) {
return 1 if -e "$path/$module$Ext";
return 1 if -e "$path/$Module/$module$Ext";
}
return 0;
}
sub findmod ($) {
my $module = shift;
my(@path) = ('.', @S);
# print "$Module => $Class\n";
for my $path (@path) {
# print "$path/$Module/$module\n";
return "$path/$module" if -e "$path/$module";
return "$path/$Module/$module" if -e "$path/$Module/$module";
}
local($") = "', '";
warn "Cannot find $module in ('@path') for $Class\n";
return undef;
}
sub mklibdir {
mkdir $Libdir, 0755 unless -d $Libdir;
}
sub mksrcdir ($) {
my $module = shift;
my $srcdir = "$Source/$module";
mkdir $Source, 0755 unless -d $Source;
mkdir $srcdir, 0755 unless -d $srcdir;
return $srcdir;
}
#sub manifest ($) { print MANIFEST $_[0] . "\n" }
#sub makefile ($) { print MAKEFILE "\t$_[0]\$(OBJ_EXT)\n" }
sub makefile ($) { push @sourcefiles, "$Sourcedir/$_[0]\$(OBJ_EXT)" }
sub export ($) { print MODULEEXPORT $_[0] }
#sub startmanifest {
# unless(open MANIFEST, ">$Sourcedir/MANIFEST") {
# warn "Cannot open $Sourcedir/MANIFEST for writing: $!";
# return;
# }
#
# manifest "MANIFEST";
#}
#
#sub endmanifest {
# close MANIFEST;
#}
#
#sub startmakefile {
# unless(open MAKEFILE, ">$Sourcedir/Makefile.PL") {
# warn "Cannot open $Sourcedir/Makefile.PL for writing: $!";
# return;
# }
#
# manifest "Makefile.PL";
#
# print MAKEFILE "use ExtUtils::MakeMaker;\n";
# print MAKEFILE "require 'perlqt.conf';\n\n";
#
# print MAKEFILE "WriteMakefile(\n";
# print MAKEFILE " 'NAME' => '$Module',\n";
# print MAKEFILE " 'VERSION_FROM' => 'perlqt.conf',\n";
# print MAKEFILE " 'CONFIGURE' => sub { return \\%PigConfig },\n";
# print MAKEFILE " 'OBJECT' => q{\n";
#
#
# for my $dir (@c) {
# my $path = ($dir =~ m!^/!) ? $dir : "../../$dir";
# next unless opendir(PIGDIR, $dir);
# my $file;
# while(defined($file = readdir(PIGDIR))) {
# if($file =~ /^(.*)\.c$/) {
# symlink("$path/$file", "$Sourcedir/$file");
# manifest $file;
# makefile $1;
# }
# }
# closedir(PIGDIR);
# }
#
# return 1;
#}
#
#sub endmakefile {
# print MAKEFILE " }\n);\n";
# close MAKEFILE;
#}
sub startmodulecode {
unless(open MODULEEXPORT, ">$Sourcedir/pig_entry_$Module.c") {
warn "Cannot open $Sourcedir/pig_entry_$Module.c for writing: $!";
return;
}
# manifest "$Module.entry.c";
makefile "$Sourcedir/pig_entry_$Module";
export qq'#include "pig.h"\n';
}
sub endmodulecode {
export "\n";
export "struct pig_classinfo PIG_module\[] = {\n";
for my $class (@ClassList) {
my $suicidenote = $Info{$class}{'Suicidal'} ? "PIG_CLASS_SUICIDAL" : "0";
my $const = "0";
my $alias = $Info{$class}->alias || $class;
$const = "PIG_${class}_const" if keys %{$Info{$class}{'Constant'}};
if($Info{$class}->class) {
export qq' {\t"$class",\n\t"$alias",\n\tPIG_${class}_methods,\n\t$const,\n\tPIG_${class}_isa,\n\t';
export qq'PIG_${class}_tocast,\n\tPIG_${class}_fromcast,\n\t$suicidenote\n },\n';
} else {
export qq' {\t"$class",\n\t"$alias",\n\tPIG_${class}_methods,\n\t$const,\n\t0,\n\t';
export qq'0,\n\t0,\n\t0\n },\n';
}
}
export " { 0, 0, 0, 0, 0, 0 }\n";
export "};\n\n";
export "struct pig_constant PIG_constant_$Module\[] = {\n";
for my $cinfo (keys %ConstantList) {
export " { (void *)$cinfo, $ConstantList{$cinfo} },\n";
}
export " { 0, 0 }\n";
export "};\n\n";
# export "struct pig_exportinfolist PIG_export\[] = {\n";
# for my $extern (sort { $ConstantList{$a}{'Name'} cmp $ConstantList{$b}{'Name'} } keys %ConstantList) {
# my $cast = $ConstantList{$extern}{'Cast'};
# export qq' { "%$ConstantList{$extern}{"Name"}", $extern, ';
# if($cast) {
# $cast =~ s/^\s*const\s+//;
# if($cast =~ /^\s*(\w+)/) {
# export qq'"$1"';
# } else {
# warn "$ConstantList{$extern}{'Cast'} is an unacceptable type";
# }
# } else {
# export "0";
# }
# export " },\n";
# }
# export " { 0, 0 }\n";
# export "};\n\n";
export "PIG_EXPORT_TABLE(PIG_$Module)\n";
# export "struct pig_symboltable PIG_export_$Module\[] = {\n";
for my $export (@Vtbl) {
export " PIG_EXPORT_SUBTABLE(PIG_${export}_vtbl)\n";
# export " { 0, (void *)PIG_${export}_export_vtbl },\n";
}
export "PIG_EXPORT_ENDTABLE\n\n";
# export " { 0, 0 }\n};\n\n";
close MODULEEXPORT;
}
sub info () { return $Info{$Class} }
sub readtypemap {
my $typemap = shift;
unless(open TYPEMAP, $typemap) {
die "Could not open typemap $typemap: $!\n";
}
while(<TYPEMAP>) {
s/\#.*//;
if(/(.*\S)\s*=>\s*(.*\S)\s*/) {
my $type = $1;
$Types{$type} = $2;
$Types{$type} =~ s/\s//g;
# print "$typemap $_ [$.] => type $type => $Types{$type}\n";
} elsif(/^(\w+)\s*=\s*(.*)/) {
$Cast{$1} = $2;
# print "cast $1 => $2\n";
}
}
close TYPEMAP;
}
sub list ($) {
my $path = shift;
unless(opendir MODULEDIR, $path) {
warn "Could not open $path for $Module: $!\n";
return ();
}
my(@c, @h, @pig);
for my $file (sort readdir MODULEDIR) {
push @c, $1 if $file =~ /(.+)\.c$/;
push @h, $1 if $file =~ /(.+)\.h$/;
push @pig, $1 if $file =~ /(.+)$Ext$/;
# if($file =~ /^pig\..*$/) {
# readtypemap("$path/$file");
# }
}
closedir MODULEDIR;
# for my $c (@c) { manifest $c . '.c'; } # makefile $c }
# for my $h (@h) { manifest $h . '.h' }
return @pig;
}
sub loadmodule {
my $class = shift;
return if exists $Info{$class};
$File = findmod("$class$Ext");
# warn "Trying to find $class$Ext\n";
unless(open PIG, $File) {
require Carp;
Carp::confess("Cannot open $File for $class for reading: $!");
return;
}
my $ssalc = $Class;
$Class = $class;
slurp(\*PIG);
if(!exists($Methods{$class}{'DESTROY'}) && $Info{$class}->class) {
my $destroy = bless {
Name => "DESTROY",
File => \$File,
Line => 0,
Prototype => "$class\::~$class();",
Diff => '+',
Purpose => '*',
Protection => 'public',
Virtual => undef,
Returns => 'void',
Class => $class,
Method => "~$class()",
Arguments => [ "$class *" ],
SigSlot => undef,
Const => undef,
Code => undef
}, 'PerlQt::Method';
push @{$Input{$class}{'Proto'}}, $destroy;
push @{$Methods{$class}{'DESTROY'}}, $destroy;
$Prototypes{$class}{&polyname($destroy)} = $destroy;
}
$Class = $ssalc;
close PIG;
}
sub readmodule {
my $class = shift;
veryverbose "Reading $class...";
# $Module = $class;
loadmodule($class);
$LinkList{$class}++;
if($Info{$class}{'Inherit'}) {
for my $super ($Info{$class}->inherit) {
next if $Info{$super};
veryverbose "\n";
readmodule($super, $class);
}
}
veryverbose "\n" unless shift;
}
sub startsource ($) {
my $class = shift;
my $info = $Info{$class};
open SOURCE, ">$Sourcedir/pig_$class.c";
# manifest "pig_" . $class . ".c";
makefile "pig_" . $class;
open HEADER, ">$Sourcedir/pig_$class.h";
# manifest "pig_" . $class . ".h";
my $ifndef = uc("pig_${class}_h");
header "#ifndef $ifndef\n";
header "#define $ifndef\n\n";
for my $include (@Include) {
for my $undef ($Info{$class}->undefine) {
header "#undef $undef\n";
}
for my $define ($Info{$class}->define) {
if($define =~ /^(\w+)=(.*)$/) {
header "#undef $1\n";
header "#define $1 $2\n";
} else {
header "#undef $define\n";
header "#define $define\n";
}
}
header qq'#include "$include"\n';
}
for my $include ($info->include) {
for my $undef ($Info{$class}->undefine) {
header "#undef $undef\n";
}
for my $define ($Info{$class}->define) {
if($define =~ /^(\w+)=(.*)$/) {
header "#undef $1\n";
header "#define $1 $2\n";
} else {
header "#undef $define\n";
header "#define $define\n";
}
}
header qq'#include <$include>\n';
}
if($info->virtual) {
open VHEADER, ">$Sourcedir/pig_${class}_v.h";
# manifest "pig_" . $class . "_v.h";
header qq'#include "pig_${class}_v.h"\n';
$ifndef = uc("pig_${class}_v_h");
vheader "#ifndef $ifndef\n";
vheader "#define $ifndef\n\n";
if($info->virtual > 1) {
for my $super ($info->virtual) {
vheader qq'#include "pig_${super}_v.h"\n' if $super ne $class;
}
vheader "\n";
} else {
vheader qq'#include "$VirtualHeader"\n\n' if $info->virtual == 1;
}
}
header "\n";
source "#define " . uc("pig_${class}_c") . "\n";
source qq'#include "pig_$class.h"\n';
my %inclist;
for my $proto (@{$Input{$class}{'Proto'}}) {
next unless $proto->everylang;
my $ret = $proto->{'Returns'};
next if $ret eq 'void';
unless(exists $IncCache{$ret}) {
my $type = fetch_ret($ret, 1);
if($type =~ /^new (\w+)$/) {
$IncCache{$ret} = $1;
} else {
$IncCache{$ret} = 0;
}
}
if($IncCache{$ret} && $IncCache{$ret} ne $class) {
for my $header ($Info{$IncCache{$ret}}->include) {
$inclist{$header}++;
}
}
}
for my $include (sort keys %inclist) {
source qq'#include "$include"\n';
}
source "\n";
}
sub endsource ($) {
my $class = shift;
my $info = $Info{$class};
my $ifndef = uc("pig_${class}_h");
header "#endif // $ifndef\n";
if($info->virtual) {
$ifndef = uc("pig_${class}_v_h");
vheader "#endif // $ifndef\n";
close VHEADER;
}
close HEADER;
close SOURCE;
}
sub startiheader {
open(IHEADER, ">$Sourcedir/pig_import_${Module}.h") || die;
iheader qq'#include "pig.h"\n';
iheader qq'#include "pigtype.h"\n\n';
}
sub endiheader {
iheader "\nPIG_IMPORT_TABLE(PIG_${Module})\n";
# iheader "struct pig_symboltable PIG_import_${Module}\[] = {\n";
for my $import (@Vtbl, @VtblIn) {
iheader " PIG_IMPORT_SUBTABLE(PIG_${import}_vtbl)\n";
# iheader " { 0, (void *)PIG_${import}_import_vtbl },\n";
}
iheader "PIG_IMPORT_ENDTABLE\n\n";
# iheader " { 0, 0 }\n};\n";
close(IHEADER);
}
sub writeheader {
my $start = "struct pig_alias_$Class : $Class {\n";
return if exists $Info{$Class}{'Class'};
for my $proto (@{$Methods{$Class}{'new'}}) {
next if $proto->perlonly;
my $decl = cpp_constructor_decl($proto);
next unless $decl; # BUG
header $start;
$start = "";
header " pig_alias_$decl {}\n";
}
for my $proto (sort { $a->{'Method'} cmp $b->{'Method'} }
values %{$Prototypes{$Class}}) {
next unless $proto->protected; # || $proto->virtual
next if $proto->constructor || $proto->destructor || $proto->abstract ||
$proto->private || $proto->variable || $proto->{'Code'};
header $start;
$start = "";
my $decl = cpp_decl_proto($proto, 'pig');
$decl =~ s/(\w+\()/pig_alias_$1/;
header " ";
header "static " if $proto->static;
header "$decl { ";
header "return " if $proto->{'Returns'} ne 'void';
header "$Class\::$proto->{'Method'}\(" .
cpp_argname_list($proto, 'pig') . "\);";
header " }\n";
}
header "};\n\n" unless $start;
}
sub by_protection { # SLOW!!!
my $x = '';
$x = "A" if $a->public;
$x = "B" if $a->protected;
$x = "C" if $a->private;
$x .= $a->{'Method'};
my $y = '';
$y = "A" if $b->public;
$y = "B" if $b->protected;
$y = "C" if $b->private;
$y .= $b->{'Method'};
$x cmp $y;
}
sub write_virtual_methods_def {
vheader "#define pig_virtual_${Class}_methods";
for my $super (info->virtual) {
vheader " \\\n pig_virtual_${super}_methods" if $super ne $Class;
}
my $prot = '';
for my $proto (sort by_protection values %Exclusive) {
next unless $proto->virtual;
next if $proto->destructor;
if($prot ne $proto->{'Protection'}) {
$prot = $proto->{'Protection'};
vheader " \\\n";
vheader "$prot:";
}
my $decl = cpp_decl_proto($proto); # BUG: Can be removed
vheader " \\\n virtual $decl;" if $decl;
}
vheader "\n\n";
}
sub write_virtual_class {
my $header = shift;
my @vlist;
vheader "extern pigfptr _pig_virtual_$Class\[];\n\n";
vheader "struct pig_virtual_$Class : ";
if(info->virtual > 1) {
my $i = 0;
for my $super (info->virtual) {
next if $super eq $Class;
vheader ", " if $i++;
vheader "pig_virtual_$super";
}
} else {
vheader "virtual pig_virtual";
}
vheader " {\n";
my $idx = 0;
for my $poly (sort keys %Exclusive) {
my $proto = $Exclusive{$poly};
next unless $proto->virtual;
next if $proto->destructor;
push @vlist, $proto;
my $decl = cpp_decl_proto($proto, "pig");
my $ptr = cpp_call_fptr($proto, "pig", "_pig_virtual_${Class}\[$idx]", "const pig_virtual");
$decl =~ s/(\w+\()/pig_virtual_$1/;
vheader " $decl {\n";
vheader "\t";
vheader "return " if $proto->{'Returns'} ne 'void';
vheader $ptr;
vheader ";\n }\n";
$idx++;
}
vheader "};\n\n";
source "PIG_EXPORT_TABLE(PIG_${Class}_vtbl)\n" unless $header;
# source "struct pig_symboltable PIG_${Class}_export_vtbl[] = {\n";
export "PIG_DECLARE_EXPORT_TABLE(PIG_${Class}_vtbl)\n" unless $header;
# export "extern struct pig_symboltable PIG_${Class}_export_vtbl[];\n";
$idx++ unless $idx;
push @Vtbl, $Class unless $header;
push @VtblIn, $Class if $header;
iheader "pigfptr _pig_virtual_$Class\[$idx];\n";
$idx = 0;
iheader "PIG_IMPORT_TABLE(PIG_${Class}_vtbl)\n";
# iheader "struct pig_symboltable PIG_${Class}_import_vtbl[] = {\n";
for my $proto (@vlist) {
my $decl;
$decl .= cpp_type($proto->{'Returns'}) . " (*)(const pig_virtual *";
my $x = 0;
for my $arg (@{$proto->{'Arguments'}}) {
next unless $x++ || $proto->static;
$decl .= ", ";
$decl .= cpp_type($arg);
}
$decl .= ")";
my $poly = polyname($proto);
source qq~ PIG_EXPORT_VIRTUAL("$Class\::$poly", ($decl)pig_virtual_${Class}__$proto->{'Name'})\n~ unless $header;
# source qq~ { "virtual $Class\::$poly", (void *)($decl)pig_virtual_${Class}__$proto->{'Name'} },\n~;
iheader qq~ PIG_IMPORT_VIRTUAL("$Class\::$poly", &_pig_virtual_${Class}\[$idx])\n~;
# iheader qq~ { "virtual $Class\::$poly", (void *)&_pig_virtual_${Class}\[$idx] },\n~;
$idx++;
}
source "PIG_EXPORT_ENDTABLE\n" unless $header;
# source " { 0, 0 }\n};\n";
iheader "PIG_IMPORT_ENDTABLE\n\n";
# iheader " { 0, 0 }\n};\n\n";
# for my $proto (@vlist) {
# }
}
sub cpp_deftype {
my $arg = shift;
return ($arg =~ /^.*=\s*(.*)/) ? $1 : undef;
}
sub cpp_defaultarg {
my $arg = shift;
my $def = cpp_deftype($arg);
# print "$def\n";
return defined($def) ? " = $def" : "";
}
sub cpp_decl_proto {
my $proto = shift;
my $pre = shift;
my $nodefault = shift;
my $decl;
unless($proto->constructor || $proto->destructor) {
$decl .= cpp_type($proto->{'Returns'}) . " ";
}
$decl .= "$proto->{'Method'}(";
my $x = 0;
for my $arg (@{$proto->{'Arguments'}}) {
next unless $x++ || $proto->static;
$decl .= ", " if ($x - (1 - $proto->static)) > 1;
if($arg eq '...') {
$decl .= $arg;
next;
}
my $type = cpp_type($arg);
return '' unless $type; # BUG!
$decl .= $type;
$decl .= " $pre" . ($x-1) if $pre;
# print "$arg\n";
$decl .= cpp_defaultarg($arg) unless $nodefault;
}
$decl .= ")";
if($proto->const) {
$decl .= " const";
}
return $decl;
}
sub cpp_call_fptr {
my($proto, $pre, $ptr, $class) = @_;
my $call;
$call = "(*(" . cpp_type($proto->{'Returns'}) . " (";
# $call .= "$class\::" if $class;
$call .= "*)(";
my $x = 0;
$call .= "$class *" if $class;
for my $arg (@{$proto->{'Arguments'}}) {
next unless $x++ || $proto->static;
$call .= ", " if $class || ($x - (1 - $proto->static)) > 1;
my $type = cpp_type($arg);
$call .= $type;
}
$call .= "))$ptr)(";
$call .= "this" if $class;
$x = 0;
for my $arg (@{$proto->{'Arguments'}}) {
next unless $x++ || $proto->static;
$call .= ", " if $class || ($x - (1 - $proto->static)) > 1;
$call .= "$pre" . ($x-1);
}
$call .= ")";
return $call;
}
sub cpp_argname_list {
my $proto = shift;
my $pre = shift;
my $arglist = '';
my $x = 0;
for my $arg (@{$proto->{'Arguments'}}) {
next unless $x++ || $proto->static;
next if $arg eq '...';
$arglist .= ", " if ($x - (1 - $proto->static)) > 1;
$arglist .= $pre . ($x-1);
}
return $arglist
}
sub cpp_constructor_decl {
my $proto = shift;
my @ret;
my $s = '';
$s .= cpp_decl_proto($proto, 'pig');
return $s unless $s; # BUG!
$s .= " : $Class(";
$s .= cpp_argname_list($proto, 'pig');
$s .= ")";
return $s;
}
sub write_enhanced_class {
vheader "class pig_enhanced_$Class : public $Class, private pig_virtual_$Class {\n";
vheader " pig_virtual_${Class}_methods\n";
vheader "public:\n";
for my $proto (@{$Methods{$Class}{'new'}}) {
next if $proto->perlonly;
vheader " pig_enhanced_" . cpp_constructor_decl($proto) .
", pig_virtual((void *)this) {}\n";
}
vheader " virtual ~pig_enhanced_$Class();\n";
vheader "};\n\n";
}
sub writevheader {
write_virtual_methods_def;
write_virtual_class;
write_enhanced_class;
}
sub fetch_varg {
my $argument = shift;
my $argname = shift;
my $arg = cpp_type($argument);
my $def = cpp_deftype($argument);
my $cast = cpp_cast($argument);
my $type = pig_type($argument);
$type =~ s/^\s*//;
$type =~ s/\s*$//;
$type =~ s/\s*([\*\&])/$1/g;
my $s = '';
my $cmp = $arg;
$cmp =~ s/\s*([\*\&])/$1/g;
if(exists $Types{$type}) {
my $c = '';
if(exists $Cast{$Types{$type}} &&
$Cast{$Types{$type}} =~ /\(.*\)/) {
$c = $Cast{$Types{$type}};
}
my $pre = "";
my $xtype = $Types{$type};
if($xtype =~ s/(\W).*//) {
$pre = '&' if $1 eq '&';
}
$s .= "pig_type_${xtype}_push(${pre}${c}$argname)";
} elsif($cmp ne $type) {
if($type =~ /^(\w+)\s*\*$/) {
$s = "pig_type_${1}_push($argname)";
} else {
$type =~ s/\W.*//;
$s = "pig_type_${type}_push($argname)";
}
} elsif($cast =~ /^(?:const\s+)?(\w+)/) {
my $class = $1;
loadmodule($class);
if($cast =~ /^const\s+(\w+)\s*\*$/) {
$s = qq'pig_type_const_object_push($argname, "$1")';
} elsif($cast =~ /^const\s+(\w+)\s*\&$/) {
$s = qq'pig_type_const_object_ref_push(&$argname, "$1")';
} elsif($cast =~ /^(\w+)\s*\*$/) {
$s = qq'pig_type_object_push($argname, "$1")';
} elsif($cast =~ /^(\w+)\s*\&$/) {
$s = qq'pig_type_object_ref_push(&$argname, "$1")';
} elsif($cast =~ /^(\w+)$/) {
$s = qq'pig_type_object_push(&$argname, "$1")';
} else {
print "NO $argument\n";
}
} else {
print "--$argument\n";
$s = "($arg)pig_argument_skip()";
}
return $s;
}
sub fetch_vret {
my $argument = shift;
my $arg = cpp_type($argument);
my $cast = cpp_cast($argument);
my $type = pig_type($argument);
$type =~ s/^\s*//;
$type =~ s/\s*$//;
$type =~ s/\s*([\*\&])/$1/g;
my $s = '';
my $cmp = $arg;
$cmp =~ s/\s*([\*\&])/$1/g;
if(exists $Types{$type}) {
my $t = '';
if(exists $Cast{$Types{$type}}) {
$t = "($arg)";
}
my $pre = "";
my $xtype = $Types{$type};
if($xtype =~ s/(\W).*//) {
$pre = '&' if $1 eq '&';
my $xarg = $arg;
$xarg =~ s/\&.*//;
$t = "*($xarg *)";
}
$s = "${t}pig_type_${xtype}_pop()";
# } elsif($cmp ne $type) {
# $s = "pig_type_${type}_pop()";
} else {
if($argument =~ /^(?:const\s+)?(\w+)/) {
my $class = $1;
loadmodule($class);
if($argument =~ /^const\s+(\w+)\s*\*$/) {
$s = qq'(const $1 *)pig_type_const_object_pop("$1")';
} elsif($argument =~ /^const\s+(\w+)\s*\&?$/) {
$s = qq'*(const $1 *)pig_type_const_object_ref_pop("$1")';
} elsif($argument =~ /^(\w+)\s*\*$/) {
$s = qq'($1 *)pig_type_object_pop("$1")';
} elsif($argument =~ /^(\w+)\s*\&?$/) {
$s = qq'*($1 *)pig_type_object_ref_pop("$1")';
} elsif($argument =~ /^(\w+)$/) {
$s = qq'*($1 *)pig_type_object_ref_pop("$1")';
} else {
print "NO $argument\n";
}
} else {
die "We must all die from $argument\n";
}
# print "%$argument\n";
}
return $s;
}
sub write_virtual_methods {
for my $poly (sort keys %Exclusive) {
my $proto = $Exclusive{$poly};
next unless $proto->virtual;
next if $proto->destructor;
local($proto->{'Const'}) = ""; # Beware!!!
my $decl = cpp_decl_proto($proto, 'pig', 1);
# $decl =~ s/(\w+\()/pig_virtual_$Class\::pig_virtual_$1/;
$decl =~ s/(\w+)\(([^\)])/pig_virtual_${Class}__$1(const pig_virtual *pig0, $2/;
$decl =~ s/(\w+)\(\)/pig_virtual_${Class}__$1(const pig_virtual *pig0)/;
unless($proto->everylang) {
source "$decl;\n\n";
next;
}
source "static $decl {\n";
source " PIG_VIRTUAL(PIG_$proto->{'Class'}_$proto->{'Name'});\n";
my $x = 0;
for my $arg (@{$proto->{'Arguments'}}) {
next unless $x++;
source " " . fetch_varg($arg, "pig" . ($x-1)) . ";\n";
# source " pig_push(&pig" . ($x-1) . ");\n";
}
if($proto->{'Returns'} ne 'void') {
source " pig_call_retmethod(pig0, \"$proto->{'Name'}\");\n";
source " return(" . fetch_vret($proto->{'Returns'}) . ");\n";
} else {
source " pig_call_method(pig0, \"$proto->{'Name'}\");\n";
}
source "}\n\n";
}
for my $poly (sort keys %Inclusive) {
my $proto = $Inclusive{$poly};
next unless $proto->virtual;
next if $proto->destructor;
my $decl = cpp_decl_proto($proto, 'pig', 1);
$decl =~ s/(\w+\()/pig_enhanced_$Class\::$1/;
source "$decl {\n";
source " ";
source "return " if $proto->{'Returns'} ne 'void';
source "pig_virtual_$proto->{'Method'}(" .
cpp_argname_list($proto, 'pig') . ");\n";
source "}\n\n";
}
}
sub newfirst {
my($x, $y) = ($a, $b);
for my $z ($x, $y) {
$z = "A" if $z eq "new"; # highest alpha string
$z = "AA" if $z eq "DESTROY"; # next highest alpha string
}
return $x cmp $y;
}
sub i {
my $in = '';
$in .= ("\t" x ($Indent/2));
$in .= " " if $Indent % 2;
return $in;
}
sub pig_type {
my $argument = shift;
if($argument =~ /\{\@?(.*?)\}/) {
return $1;
} else {
return cpp_type($argument);
}
}
sub cpp_cast {
my $arg = pig_type(@_);
my $targ = cpp_type(@_);
$arg =~ s/^\s*//;
$arg =~ s/\s*$//;
$arg =~ s/\s*([\*\&])/$1/g;
if(exists $Cast{$arg}) {
my $cast = $Cast{$arg};
$cast =~ s/^\(*//;
$cast =~ s/\)*$//;
return $cast;
}
# return (exists $Cast{$arg}) ? $Cast{$arg} : $targ;
return $targ;
}
sub fetch_ret {
my $argument = shift;
my $arg = cpp_type($argument);
my $cast = cpp_cast($argument);
my $type = pig_type($argument);
$type =~ s/^\s*//;
$type =~ s/\s*$//;
$type =~ s/\s*([\*\&])/$1/g;
my $s = '';
my $cmp = $arg;
$cmp =~ s/\s*([\*\&])/$1/g;
my $ex = "";
if($argument =~ /\{\s*(\w+)\s*\((.*)\)\}/) {
my $list = $2;
my @args;
for my $x (split /,\s*/, $list) {
$x =~ s/\$[(\d)]/pig$1/g;
$x =~ s/\$this/pig0/g;
push @args, $x;
}
$ex = ", " . join(", ", @args) if @args;
}
if(exists $Types{$type}) {
my $c = '';
if(exists $Cast{$Types{$type}} &&
$Cast{$Types{$type}} =~ /\(.*\)/) {
$c = $Cast{$Types{$type}};
}
# $c = "($Cast{$Types{$type}})" if exists $Cast{$Types{$type}};
# $c =~ s/\(+/(/g;
# $c =~ s/\)+/)/g;
my $pre = "";
my $xtype = $Types{$type};
if($xtype =~ s/(\W).*//) {
$pre = '&' if $1 eq '&';
}
$s = "pig_type_${xtype}_return(${pre}${c}pigr$ex)";
# $s =~ s/\$type/$arg/g;
} elsif($cmp ne $type) {
# print "?$type\n";
my $pre = "";
if($type =~ s/(\W).*//) {
$pre = '&' if $1 eq '&';
}
$s = "pig_type_${type}_return(${pre}pigr$ex)";
} else {
if($argument =~ /^(?:const\s+)?(\w+)/) {
my $class = $1;
# print "Loading $class\n";
loadmodule($class);
if($Info{$class}->copy) {
return "new $class" if shift; # include headers for new $class()
if($argument =~ /^(?:const\s+)?(\w+)\s*\*$/) {
$s = qq{pig_type_new_object_return(pigr ? new $1(*pigr) : (void *)pigr, "$1")};
} elsif($argument =~ /^(?:const\s+)?(\w+)\s*\&?$/) {
$s = qq{pig_type_new_object_return(new $1(pigr), "$1")};
} else {
print "NO $argument\n";
}
} else {
if($argument =~ /^const\s+(\w+)\s*\*$/) {
$s = qq{pig_type_const_object_return(pigr, "$1")};
} elsif($argument =~ /^const\s+(\w+)\s*\&$/) {
$s = qq{pig_type_const_object_return(&pigr, "$1")};
} elsif($argument =~ /^(\w+)\s*\*$/) {
$s = qq{pig_type_object_return(pigr, "$1")};
} elsif($argument =~ /^(\w+)\s*\&?$/) {
$s = qq{pig_type_object_return(&pigr, "$1")};
} else {
print "NO $argument\n";
}
}
} else {
die "We must all die from $argument\n";
}
# print "%$argument\n";
}
return $s;
}
sub fetch_arg {
my $argument = shift;
my $idx = shift;
my $prefix = shift || 'pig_type_';
my $arg = cpp_type($argument);
my $def = cpp_deftype($argument);
my $cast = cpp_cast($argument);
my $defarg = defined($def) ? "($cast)($def)" : "";
my $type = pig_type($argument);
$type =~ s/^\s*//;
$type =~ s/\s*$//;
$type =~ s/\s*([\*\&])/$1/g;
my $s = '';
my $cmp = $arg;
$cmp =~ s/\s*([\*\&])/$1/g;
# warn "$type\n";
if(exists $Types{$type}) {
my $c = '';
my $t = '';
if(exists $Cast{$Types{$type}}) {
if($Cast{$Types{$type}} =~ /\(.*\)/) {
$c = "$Cast{$Types{$type}}";
$t = "($arg)";
}
elsif($defarg) {
$defarg = $def;
}
}
my $pre = "";
my $xtype = $Types{$type};
if($xtype =~ s/(\W).*//) {
$pre = '&' if $1 eq '&';
my $xarg = $arg;
$xarg =~ s/\s*\&//g;
$t = "*($xarg *)"
}
if($defarg) {
$s .= "$t$prefix${xtype}_defargument(${pre}${c}$defarg)";
} else {
$s .= "$t$prefix${xtype}_argument()";
}
} elsif($cmp ne $type) {
if($type =~ /^(\w+)\s*\*$/) {
$s = "*($arg *)$prefix${1}_argument($defarg)";
} else {
my $xarg = "";
my $commaxarg = "";
if($type =~ /\((.+)\)/) {
$xarg = $1;
$commaxarg = ", $xarg";
}
$type =~ s/\W.*//;
if($arg =~ /\&\s*$/) {
if($defarg) {
$s = "$prefix${type}_defargument($defarg$commaxarg)";
} else {
$s = "$prefix${type}_argument($xarg)";
}
} else {
if($defarg) {
$s = "($arg)$prefix${type}_defargument($defarg$commaxarg)";
} else {
$s = "($arg)$prefix${type}_argument($xarg)";
}
# $s = "($arg)$prefix${type}_argument($defarg)";
}
}
} elsif($cast =~ /^(?:const\s+)?(\w+)/) {
my $class = $1;
loadmodule($class);
if($cast =~ /^const\s+(\w+)\s*\*$/) {
if(defined($def)) {
$s .= qq'(const $1 *)${prefix}const_object_defargument($def, "$1")';
} else {
$s .= qq'(const $1 *)${prefix}const_object_argument("$1")';
}
} elsif($cast =~ /^const\s+(\w+)\s*\&$/) {
if(defined($def)) {
$s .= qq'*(const $1 *)${prefix}const_object_ref_defargument(&pig_$idx, "$1")';
} else {
$s .= qq'*(const $1 *)${prefix}const_object_ref_argument("$1")';
}
} elsif($cast =~ /^(\w+)\s*\*$/) {
if(defined($def)) {
$s .= qq'($1 *)${prefix}object_defargument($def, "$1")';
} else {
$s .= qq'($1 *)${prefix}object_argument("$1")';
}
} elsif($cast =~ /^(\w+)\s*\&?$/) {
if(defined($def)) {
$s .= qq'*($1 *)${prefix}object_ref_defargument(&pig_$idx, "$1")';
} else {
$s .= qq'*($1 *)${prefix}object_ref_argument("$1")';
}
} else {
print "NO $argument\n";
}
} else {
print "-$argument\n";
$s = "($arg)pig_argument_skip()";
}
return $s;
}
sub write_proto_method {
my $proto = shift;
my $x = 0;
return if $proto->{'Name'} eq 'newcopy'; # broken for now
if($proto->destructor) {
source i."$Class * pig0 = ($Class *)pig_type_object_destructor_argument(\"$Class\");\n";
} else {
for my $argument (@{$proto->{'Arguments'}}) {
my $arg = cpp_type($argument);
if(cpp_deftype($argument) && $arg =~ /\&/) {
source i."$arg pig_$x = ".cpp_deftype($argument).";\n";
}
source i.$arg;
source " pig$x";
source " = ";
if($x == 0 && !$proto->static && !$proto->constructor) {
source fetch_arg($argument, $x, 'pig_type_this_');
} else {
source fetch_arg($argument, $x);
}
source ";\n";
$x++;
}
}
source i."PIG_END_ARGUMENTS;\n\n";
# source "\n" if @{$proto->{'Arguments'}};
if($proto->abstract) {
source i."pig_call_abstract(\"$Class\::$proto->{Name}\");\n\n";
} elsif($proto->{'Returns'} ne 'void') {
my $arg = cpp_type($proto->{'Returns'});
source i."$arg pigr = ";
}
if($proto->{'Code'}) {
my $code = $proto->{'Code'};
$code =~ s/^\s*//;
$code =~ s/\s*//;
$code =~ s/\$class/pigclass/g;
$code =~ s/\$this/pig0/g;
$code =~ s/\$(\d+)/pig$1/g;
source "$code;\n\n";
} elsif($proto->variable) {
my $code = $proto->{'Name'};
my $set = 0;
if($code =~ /^set/) {
$set = 1;
$code =~ s/^set([A-Z])/\l$1/;
$code =~ s/^set([a-z])/\u$1/;
}
if($set) {
source "pig0->$code = pig1;\n\n";
} else {
source "pig0->$code;\n\n";
}
} elsif($proto->destructor) {
if(info->virtual) {
source "if(pig_object_can_delete()) delete ((pig_enhanced_$Class *)pig0);\n\n";
} else {
source "if(pig_object_can_delete()) delete pig0;\n\n";
}
source i."pig_return_nothing();\n";
return;
} elsif($proto->constructor) {
if(info->virtual) {
source "new pig_enhanced_";
} else {
source "new ";
}
} elsif($proto->static) {
if($proto->protected) {
source "pig_alias_$Class\::pig_alias_";
} else {
source "$Class\::";
}
} else {
if($proto->abstract) {
} elsif($proto->protected) {
source "((pig_alias_$Class *)pig0)->pig_alias_";
} elsif($proto->virtual) {
source "pig0->$Class\::";
} else {
source "pig0->";
}
}
unless($proto->{'Code'} || $proto->variable || $proto->abstract) {
source "$proto->{'Method'}(";
source cpp_argname_list($proto, 'pig');
source ");\n\n";
}
if($proto->abstract) {
} elsif($proto->{'Name'} eq 'new') {
source i.qq'pig_type_new_castobject_return(pigr, "$Class", pigclass);\n';
} elsif($proto->{'Returns'} ne 'void') {
source i.fetch_ret($proto->{'Returns'}).";\n";
} else {
source i."pig_return_nothing();\n";
}
}
sub group_of_type {
my $item = shift;
my $arg = cpp_type($item);
my $type = pig_type($item);
my $cmp = $arg;
$cmp =~ s/\s*([\*\&])/$1/g;
$cmp =~ s/\s*\*.*//;
# $type = $Types{$type} if exists $Types{$type} && $Types{$type} ne $cmp;
$type =~ s/^\s*//;
$type =~ s/\s*$//;
$type =~ s/\s*([\*\&])/$1/g;
$type =~ s/\s*\*.*//;
if($type =~ /^(?:int|long|uint|short|enum)$/) {
return 'int';
} elsif($type =~ /^bool$/) {
return 'bool';
} elsif($type =~ /^(?:float|double)$/) {
return 'float';
} elsif($arg =~ /^(?:const\s+)?char\s*\*\s*$/) {
return 'string';
} elsif($cmp ne $type) {
return group_of_type($arg);
} elsif($arg =~ /^(?:const\s+)?([\w:]+)/ and ismod $1) {
return 'class';
} else {
$arg =~ s/\s+/ /g;
$arg =~ s/\s*([\*\&])/$1/g;
# print "okay, $arg => $Types{$arg}\n";
if(exists $Types{$arg} && $Types{$arg} ne $arg) {
# print "Getting $Types{$arg} from $arg\n";
return group_of_type($Types{$arg});
}
# print "Okay, casting $arg to $Cast{$arg}\n";
if(exists $Cast{$arg} && $Cast{$arg} ne $arg) {
return group_of_type($Cast{$arg});
}
# print "UNKNOWN '$type' '$arg' '$cmp'\n";
# if(exists $Types{$arg}
return 'unknown';
}
}
sub branched_filter {
my $info = shift;
my $list = shift;
my $ninfo = {};
$ninfo->{'undef'} = [ map { $$list{$_} ? ($_) : () } @{$info->{'undef'}} ];
$ninfo->{'string'} = [ map { $$list{$_} ? ($_) : () } @{$info->{'string'}} ];
$ninfo->{'mystery'} = [ map { $$list{$_} ? ($_) : () } @{$info->{'mystery'}} ];
for my $key (keys %{$info->{'number'}}) {
$ninfo->{'number'}{$key} = [ map { $$list{$_} ? ($_) : () }
@{$info->{'number'}{$key}} ];
}
for my $key (keys %{$info->{'class'}}) {
$ninfo->{'class'}{$key} = [ map { $$list{$_} ? ($_) : () }
@{$info->{'class'}{$key}} ];
}
return $ninfo;
}
sub branch_condition {
my $pm = shift;
my $idx = shift;
my $list = shift;
my %list;
if($Method eq 'new') {
return 0 unless $idx < @$pm;
} else {
return 0 unless $idx < $#$pm;
}
for my $item (@$list) { $list{$item}++ }
source "{\n";
$Indent++;
branching_conditional($pm, $idx + 1, \%list); # mutual recursion
$Indent--;
source i."}\n";
return 1;
}
sub byinheritance {
my(@asuper, @bsuper);
supernames($a, \@asuper);
supernames($b, \@bsuper);
if(grep($a, @bsuper)) {
return 1;
} elsif(grep($b, @asuper)) {
return 0;
} else {
return $a cmp $b;
}
}
sub branching_conditional {
my $pm = shift;
my $idx = shift;
my $list = shift;
my $info = branched_filter(($Method eq 'new') ? $pm->[$idx-1] : $pm->[$idx], $list);
my $else = 0;
source i."unsigned int pigi$idx = pig_argument_info($idx);\n";
if(scalar @{$info->{'string'}} &&
scalar @{$info->{'string'}} != scalar @{$info->{'undef'}}) {
source i;
source "else " if $else++;
source "if(pig_is_string($idx)) ";
if(scalar @{$info->{'string'}} == 1) {
source "pigs = $info->{'string'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'string'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
if(scalar keys %{$info->{'number'}}) {
my $c = scalar keys %{$info->{'number'}};
if($c == 1) {
my($key) = keys(%{$info->{'number'}});
source i;
source "else " if $else++;
source "if(pig_is_number($idx)) ";
if(scalar @{$info->{'number'}{$key}} == 1) {
source "pigs = $info->{'number'}{$key}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'number'}{$key})) {
source "pigs = 0; // AMBIGUOUS\n";
}
} elsif($c == 2) {
my($k1, $k2) = keys(%{$info->{'number'}});
if($k1 eq 'int') {
source i;
source "else " if $else++;
source "if(pig_is_int($idx)) ";
if(scalar @{$info->{'number'}{'int'}} == 1) {
source "pigs = $info->{'number'}{'int'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'number'}{'int'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
if($k2 eq 'int') {
source i;
source "else " if $else++;
source "if(pig_is_int($idx)) ";
if(scalar @{$info->{'number'}{'int'}} == 1) {
source "pigs = $info->{'number'}{'int'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'number'}{'int'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
if($k1 eq 'float') {
source i;
source "else " if $else++;
source "if(pig_is_float($idx)) ";
if(scalar @{$info->{'number'}{'float'}} == 1) {
source "pigs = $info->{'number'}{'float'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'number'}{'float'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
if($k2 eq 'float') {
source i;
source "else " if $else++;
source "if(pig_is_float($idx)) ";
if(scalar @{$info->{'number'}{'float'}} == 1) {
source "pigs = $info->{'number'}{'float'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'number'}{'float'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
if($k1 eq 'bool') {
source i;
source "else " if $else++;
source "if(pig_is_bool($idx)) ";
if(scalar @{$info->{'number'}{'bool'}} == 1) {
source "pigs = $info->{'number'}{'bool'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'number'}{'bool'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
if($k2 eq 'bool') {
source i;
source "else " if $else++;
source "if(pig_is_bool($idx)) ";
if(scalar @{$info->{'number'}{'bool'}} == 1) {
source "pigs = $info->{'number'}{'bool'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'number'}{'bool'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
}
}
if(scalar @{$info->{'undef'}}) {
if(scalar @{$info->{'string'}} == scalar @{$info->{'undef'}}) {
source i;
source "else " if $else++;
source "if(pig_is_string($idx) || pig_is_undef($idx)) ";
if(scalar @{$info->{'string'}} == 1) {
source "pigs = $info->{'string'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'string'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
} elsif(scalar(keys %{$info->{'class'}}) == 1 &&
scalar(@{$info->{'class'}{(keys %{$info->{'class'}})[0]}}) ==
(scalar(@{$info->{'undef'}}) - scalar(@{$info->{'string'}}))) {
my $key = (keys %{$info->{'class'}})[0];
source i;
source "else " if $else++;
source "if(pig_is_object($idx) || pig_is_undef($idx)) ";
if(scalar @{$info->{'class'}{$key}} == 1) {
source "pigs = $info->{'class'}{$key}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'class'}{$key})) {
source "pigs = 0; // AMBIGUOUS\n";
}
} else {
source i;
source "else " if $else++;
source "if(pig_is_undef($idx)) ";
if(scalar @{$info->{'undef'}} == 1) {
source "pigs = $info->{'undef'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'undef'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
}
if(scalar keys %{$info->{'class'}}) {
if(scalar keys %{$info->{'class'}} == 1 &&
# (scalar(@{$info->{'string'}}) != scalar(@{$info->{'undef'}})) &&
scalar(@{$info->{'class'}{(keys %{$info->{'class'}})[0]}}) !=
(scalar(@{$info->{'undef'}}) - scalar(@{$info->{'string'}}))) {
my($key) = keys(%{$info->{'class'}});
source i;
source "else " if $else++;
source "if(pig_is_object($idx)) ";
if(scalar @{$info->{'class'}{$key}} == 1) {
source "pigs = $info->{'class'}{$key}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'class'}{$key})) {
source "pigs = 0; // AMBIGUOUS\n";
}
} elsif(scalar(keys %{$info->{'class'}}) > 1) {
my(@classes) = sort byinheritance keys %{$info->{'class'}};
for my $key (@classes) {
source i;
source "else " if $else++;
source "if(pig_is_class($idx, \"$key\")) ";
if(scalar @{$info->{'class'}{$key}} == 1) {
source "pigs = $info->{'class'}{$key}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'class'}{$key})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
}
}
if(scalar @{$info->{'mystery'}}) {
source i;
source "else " if $else++;
source "if(pig_is_mystery($idx)) ";
if(scalar @{$info->{'mystery'}} == 1) {
source "pigs = $info->{'mystery'}[0];\n";
} elsif(!branch_condition($pm, $idx, $info->{'mystery'})) {
source "pigs = 0; // AMBIGUOUS\n";
}
}
if(!$else && $idx < $#$pm) {
# branching_conditional($pm, $idx + 1, $list);
}
}
sub write_whichproto {
my $protos = shift;
my $method = $protos->[0]{'Name'};
my @argcnt;
my $adj = 0;
# my $v = $protos->[0]{'Class'} eq 'QScrollBar';
$adj = 1 if $method eq 'new';
for(my $item = 0; $item < @$protos; $item++) {
my $proto = $protos->[$item];
my @arguments;
my $x = 0;
for my $arg (@{$proto->{'Arguments'}}) {
push @arguments, $arg unless $arg =~ /\{\s*\@/;
# if($v) { print "x[$item] ($arg)\n" }
}
for my $arg (@arguments) {
# if($v) { print "deftype $arg\n" if defined cpp_deftype($arg);
# }
last if defined cpp_deftype($arg);
$x++;
}
for my $i ($x .. scalar(@arguments)) {
push @{$argcnt[$i]}, $item;
}
}
source i."if(";
my($i, $bottom);
for($i = 0; $i < @argcnt; $i++) {
if(!defined($bottom) && $argcnt[$i]) {
if($i == 0) {
$bottom = 0;
next;
}
$bottom = $i;
source "pigc <= ".($i-1+$adj);
}
elsif(defined($bottom) && !$argcnt[$i]) {
source " || " if $bottom++;
source "pigc == " . ($i+$adj);
}
}
source " || " if $bottom++;
source "pigc >= " . ($i+$adj);
source ") pigs = 0;\n";
for($i = 0; $i < @argcnt; $i++) {
next unless ref $argcnt[$i];
if(scalar @{$argcnt[$i]} == 1) {
my $case = $argcnt[$i][0] + 1;
source i."else if(pigc == ".($i+$adj).") pigs = $case;\n";
} else {
my @protomatrix;
source i."else if(pigc == ".($i+$adj).") {\n";
$Indent++;
source i."// ".scalar(@{$argcnt[$i]})." possibilities\n";
for my $idx (0..($i-1)) {
$protomatrix[$idx] = {
'undef' => [],
'string' => [],
'number' => {},
'class' => {},
'mystery' => []
};
}
my %x;
for my $idx (@{$argcnt[$i]}) {
source "\n";
source i."// idx: ".($idx+1)."\n";
my $x = 0;
for my $arg (@{$protos->[$idx]{'Arguments'}}[0..($i-1)]) {
next if $arg =~ /\{\s*\@/;
my $info = $protomatrix[$x++];
my $type = group_of_type($arg);
#print "got $type of $arg\n" if $v;
source i."// $type\n";
$x{$idx+1}++;
if($type eq 'int') {
push @{$info->{'number'}{'int'}}, $idx+1;
} elsif($type eq 'float') {
push @{$info->{'number'}{'float'}}, $idx+1;
} elsif($type eq 'bool') {
push @{$info->{'number'}{'bool'}}, $idx+1;
} elsif($type eq 'string') {
push @{$info->{'undef'}}, $idx+1;
push @{$info->{'string'}}, $idx+1;
} elsif($type eq 'class') {
push @{$info->{'undef'}}, $idx+1 unless $arg =~ /\&\s*$/;
my $class = $arg;
$class =~ s/^\s*(?:const\s+)?(\w+).*$/$1/;
push @{$info->{'class'}{$class}}, $idx+1;
} elsif($type eq 'unknown') {
push @{$info->{'mystery'}}, $idx+1;
}
# } else {
# $x{$idx+1}--;
# }
}
}
for my $idx (0..$#protomatrix) {
local($") = ', ';
my $pm = $protomatrix[$idx];
source i."// \$info[$idx] = {\n";
source i."// 'undef' => [@{$pm->{'undef'}}],\n";
source i."// 'string' => [@{$pm->{'string'}}],\n";
my $x = 0;
source i."// 'number' => {";
for my $number (sort keys %{$pm->{'number'}}) {
source ", " if $x++ > 0;
source "'$number' => [@{$pm->{'number'}{$number}}]";
}
source "},\n";
$x = 0;
source i."// 'class' => {";
for my $class (sort keys %{$pm->{'class'}}) {
source ", " if $x++ > 0;
source "'$class' => [@{$pm->{'class'}{$class}}]";
}
source "},\n";
source i."// 'mystery' => [@{$pm->{'mystery'}}]\n";
source i."// };\n";
}
$Method = $protos->[0]{'Name'};
branching_conditional(\@protomatrix, ($Method eq 'new') ? 1 : 0, \%x);
$Indent--;
source i."}\n";
}
}
}
sub write_perl_methods {
my @methods;
source "static PIG_PROTO(PIG_${Class}_continue) {\n";
source " PIG_BEGIN(PIG_${Class}_continue);\n";
source " pig_object_continue();\n";
source " PIG_END;\n";
source "}\n\n";
push @methods, 'continue';
source "static PIG_PROTO(PIG_${Class}_break) {\n";
source " PIG_BEGIN(PIG_${Class}_break);\n";
source " pig_object_break();\n";
source " PIG_END;\n";
source "}\n\n";
push @methods, 'break';
for my $meth (sort newfirst keys %{$Methods{$Class}}) {
my @protos;
for my $proto (@{$Methods{$Class}{$meth}}) {
push @protos, $proto
unless #$proto->variable ||
$proto->private ||
# $proto->{'Code'} ||
# !$proto->everylang;
$proto->cpponly;
}
my $protocnt = scalar(@protos);
next if $protocnt == 0;
push @methods, $meth;
if($Methods{$Class}{$meth}[0]->destructor &&
$Methods{$Class}{$meth}[0]->public) {
source "static PIG_PROTO(PIG_${Class}_delete) {\n";
source " PIG_BEGIN(PIG_${Class}_delete);\n";
source " $Class * pig0 = ($Class *)pig_type_object_destructor_argument(\"$Class\");\n";
source " PIG_END_ARGUMENTS;\n\n";
source " delete pig0;\n\n";
source " pig_return_nothing();\n";
source " PIG_END;\n";
source "}\n\n";
push @methods, 'delete';
}
my $polymorph = ($protocnt > 1);
my $poly = 1;
source "static PIG_PROTO(PIG_${Class}_$meth) {\n";
source " PIG_BEGIN(PIG_${Class}_$meth);\n";
if($meth eq 'new') {
source " const char *pigclass = pig_type_cstring_argument();\n";
}
if($polymorph) {
source "\n";
source " int pigs = 0;\n";
source " int pigc = pig_argumentcount();\n\n";
$Indent = 1;
write_whichproto(\@protos);
source " switch(pigs) {\n";
}
$Indent = $polymorph ? 3 : 1;
for my $proto (@protos) {
if($polymorph) {
source " case $poly:\n\t{\n";
$poly++;
}
write_proto_method($proto);
if($polymorph) {
source "\t}\n";
source "\tbreak;\n";
}
}
if($polymorph) {
source " default:\n";
source qq{\tpig_ambiguous("$Class", "$protos[0]{'Name'}");\n\tbreak;\n};
source " }\n";
}
source " PIG_END;\n";
source "}\n\n";
}
export "extern pig_method PIG_${Class}_methods[];\n";
source "pig_method PIG_${Class}_methods[] = {\n";
for my $meth (sort newfirst @methods) {
source " { \"$meth\", PIG_PROTONAME(PIG_${Class}_$meth) },\n";
}
source " { 0, 0 }\n";
source "};\n\n";
}
sub write_isa {
export "extern const char *PIG_${Class}_isa[];\n";
source "const char *PIG_${Class}_isa[] = { ";
for my $super (info->inherit) { source qq{"$super", } if $Info{$super}->class }
source "0 };\n\n";
}
sub supernames {
my $class = shift;
my $array = shift;
return if exists $Info{$class}{'Class'} && !$Info{$class}{'Class'};
push @$array, $class;
return unless exists $Info{$class}{'Inherit'};
for my $super ($Info{$class}->inherit) {
supernames($super, $array);
}
}
sub write_typecast {
my $direction = shift;
export "extern void *PIG_${Class}_${direction}cast(const char *, void *);\n";
source "void *PIG_${Class}_${direction}cast(const char *pig0, void *pig1) {\n";
my @super;
supernames($Class, \@super);
push @super, "virtual" if info->virtual;
source " const char *pig_super[] = { ";
for my $super (@super) {
source qq{"$super", };
}
source "0 };\n\n";
source " if(!pig0) return pig1;\n";
source " switch(pig_find_in_array(pig0, pig_super)) {\n";
my $x = 0;
for my $super (@super) {
source "\tcase $x: return (void *)";
if($direction eq 'from') {
if($super eq 'virtual') {
source "($Class *)(pig_enhanced_$Class *)(((pig_virtual *)pig1)->pig_this);\n";
} else {
source "($Class *)($super *)pig1;\n";
}
} else {
if($super eq 'virtual') {
source "(pig_virtual *)(pig_virtual_$Class *)(pig_enhanced_$Class *)($Class *)";
} else {
source "($super *)($Class *)";
}
source "pig1;\n";
}
$x++;
}
source "\tdefault: return 0;\n";
source " }\n";
source "}\n\n";
}
sub write_constants {
# for my $constant ($Info{$Class}->export) {
# if($constant =~ /(\%|\@|\$|\&)(\w+)(.*)/) {
# my($type, $name, $rest) = ($1, $2, $3);
# my $cast = 'ulong';
# if($type eq '%') {
# $cast = $1 if $rest =~ s/^{(.*?)}//;
# export "extern pig_struct_constantdata PIG_${Class}_constant_$name\[];\n";
# source "pig_struct_constantdata PIG_${Class}_constant_$name\[] = {\n";
#
# $ConstantList{"PIG_${Class}_constant_$name"} = {
# Name => $name,
# Type => 'HASH',
# Cast => ($cast eq 'ulong') ? undef : $cast
# };
#
# for my $key (sort keys %{$Input{$Class}{$type}{$name}}) {
# source " { \"$key\", (long)($cast)$Input{$Class}{$type}{$name}{$key} },\n";
# }
# source " { 0, 0 }\n";
# source "};\n\n";
# }
# }
# }
my $type;
my $c = $Info{$Class}{'Constant'};
if(keys %$c) {
my @int;
my @object;
my %list;
for my $constant (keys %$c) {
$type = $c->{$constant}{'Type'};
if($type eq 'enum') {
push @int, $constant;
} elsif($type eq 'int') {
push @int, $constant;
} elsif($type eq 'uint') {
push @int, $constant;
} else {
push @object, $constant;
# print "No $constant $type\n";
}
}
if(@int) {
source "static struct pig_constant_int PIG_${Class}_const_int[] = {\n";
for my $constant (sort @int) {
source qq~ { "$constant", (long)$Class\::$constant },\n~;
}
source " { 0, 0 }\n";
source "};\n\n";
$list{"PIG_${Class}_const_int"} = "PIG_CONSTANT_INT";
}
if(@object) {
source "struct pig_constant_object PIG_${Class}_const_object[] = {\n";
for my $constant (sort @object) {
my $t = $c->{$constant}{'Type'};
my $n;
my $v;
if($t =~ /(.*\w)\s*\*\s*$/) {
$v = "$Class\::$constant";
$n = $1;
} else {
if($t =~ /([\w:]+)/) {
$n = $1;
} else {
$n = $t;
}
$t = "$t*";
$v = "&$Class\::$constant";
}
unless($t =~ /^const\s+/) {
$t = "const $t";
}
source qq~ { "$constant", (void *)($t)$v, "$n" },\n~;
}
source " { 0, 0, 0 }\n";
source "};\n\n";
$list{"PIG_${Class}_const_object"} = "PIG_CONSTANT_OBJECT";
}
source "struct pig_constant PIG_${Class}_const[] = {\n";
for my $clist (keys %list) {
source " { (void *)$clist, $list{$clist} },\n";
}
source " { 0, 0 }\n";
source "};\n\n";
export "extern pig_constant PIG_${Class}_const[];\n";
}
$c = $Info{$Class}{'Global'};
if(keys %$c) {
my @int;
my @object;
for my $constant (keys %$c) {
$type = exists $Types{$c->{$constant}{'Type'}} ?
$Types{$c->{$constant}{'Type'}} : $c->{$constant}{'Type'};
if($type eq 'enum') {
push @int, $constant;
} elsif($type eq 'int') {
push @int, $constant;
} elsif($type eq 'uint') {
push @int, $constant;
} else {
push @object, $constant;
# print "No $type $constant\n";
}
}
if(@int) {
source "struct pig_constant_int PIG_${Class}_global_int[] = {\n";
for my $constant (sort @int) {
source qq~ { "$constant", (long)$constant },\n~;
}
source " { 0, 0 }\n";
source "};\n\n";
export "extern pig_constant_int PIG_${Class}_global_int[];\n";
$ConstantList{"PIG_${Class}_global_int"} = "PIG_CONSTANT_INT";
}
if(@object) {
source "struct pig_constant_object PIG_${Class}_global_object[] = {\n";
for my $constant (sort @object) {
my $t = $c->{$constant}{'Type'};
my $n;
my $v;
if($t =~ /(.*\w)\s*\*\s*$/) {
$v = $constant;
$n = $1;
} else {
if($t =~ /([\w:]+)/) {
$n = $1;
} else {
$n = $t;
}
$t = "$t*";
$v = "&$constant";
}
unless($t =~ /^const\s+/) {
$t = "const $t";
}
source qq~ { "$constant", (void *)($t)$v, "$n" },\n~;
}
source " { 0, 0, 0 }\n";
source "};\n\n";
export "extern pig_constant_object PIG_${Class}_global_object[];\n";
$ConstantList{"PIG_${Class}_global_object"} = "PIG_CONSTANT_OBJECT";
}
}
}
sub write_virtual_destructor {
source "pig_enhanced_$Class\::~pig_enhanced_$Class() {\n";
source " pig_object_destroy(this, (pig_virtual *)this);\n";
source "}\n\n";
}
sub writesource {
if(info->class) {
write_isa;
write_typecast('to');
write_typecast('from');
}
write_constants;
write_perl_methods;
write_virtual_destructor if info->virtual;
write_virtual_methods if info->virtual;
}
sub findvirtual {
my $class = shift;
for my $poly (keys %{$Prototypes{$class}}) {
$Inclusive{$poly} = $Prototypes{$class}{$poly}
unless exists $Inclusive{$poly};
}
for my $super ($Info{$class}->virtual) {
next if $super eq $class;
findvirtual($super);
}
}
sub getvirtual {
%Inclusive = ();
%Exclusive = ();
for my $super (info->virtual) {
next if $super eq $Class;
findvirtual($super);
}
%Exclusive = %{$Prototypes{$Class}};
for my $poly (keys %Exclusive) {
if(exists $Inclusive{$poly}) {
delete $Exclusive{$poly};
} else {
$Inclusive{$poly} = $Exclusive{$poly};
}
}
}
sub writemodule {
my $class = shift;
verbose "Writing $class...";
getvirtual if info->virtual;
startsource $class;
writesource;
writeheader;
writevheader if info->virtual;
endsource $class;
delete $LinkList{$class};
push @ClassList, $class;
say ".";
verbose "\n";
}
#sub main {
# arguments(@ARGV);
#
#MODULE:
# for my $module (@Modules) {
# my $path = find $module;
# next MODULE unless $path;
# $Module = $module;
# $Path = $path;
#
# say "Loading $module...";
# verbose "Loading $module...";
#
## mklibdir;
#
# my $srcdir = mksrcdir $module;
# next MODULE unless $srcdir;
# $Sourcedir = $srcdir;
#
## next MODULE unless startmanifest;
## next MODULE unless startmakefile;
# next MODULE unless startmodulecode;
# startiheader;
#
# my(@classes) = list $path;
#
# verbose "\n";
#
# for my $class (@classes) {
# $Class = $class;
# readmodule $class;
# writemodule $class;
# }
# say "\n";
#
# endiheader;
# endmodulecode;
## endmanifest; endmakefile;
# }
#}
sub GenerateSource {
my(%args) = @_;
for my $typemap (@{$args{'TYPEMAPS'}}) {
readtypemap($typemap);
}
@Include = @{$args{'INCLUDE'}};
$Sourcedir = $args{'SOURCEDIR'};
$VirtualHeader = $args{'VIRTUALHEADER'};
@S = (@S, @{$args{'LINK'}}) if ref $args{'LINK'};
for my $module (@{$args{'DIR'}}) {
$Module = $module;
push @S, $module;
$Module =~ s/\W+.*//;
$Path = $module;
say "Loading $module...";
verbose "Loading $module...";
# mklibdir;
# my $srcdir = mksrcdir $module;
mkdir($Sourcedir, 0755) unless -d $Sourcedir;
# next MODULE unless $srcdir;
# $Sourcedir = "src";
# next MODULE unless startmanifest;
# next MODULE unless startmakefile;
next MODULE unless startmodulecode;
startiheader;
my(@classes) = list $Path;
verbose "\n";
for my $class (@classes) {
$Class = $class;
readmodule $class;
}
for my $class (@classes) {
$Class = $class;
writemodule $class;
}
say "\n";
for my $class (keys %LinkList) {
$Class = $class;
if(info->virtual) {
my $info = $Info{$class};
my $ifndef;
open VHEADER, ">$Sourcedir/pig_${class}_v.h";
$ifndef = uc("pig_${class}_v_h");
vheader "#ifndef $ifndef\n";
vheader "#define $ifndef\n\n";
if($info->virtual > 1) {
for my $super ($info->virtual) {
vheader qq'#include "pig_${super}_v.h"\n' if $super ne $class;
}
vheader "\n";
} else {
vheader qq'#include "$VirtualHeader"\n\n' if $info->virtual == 1;
}
getvirtual;
# writevheader;
write_virtual_methods_def;
write_virtual_class 1;
vheader "#endif $ifndef\n";
close VHEADER;
}
}
endiheader;
endmodulecode;
}
if(exists $args{'Source'} && ref $args{'Source'}) {
${$args{'Source'}} = \@sourcefiles;
}
}
1;