Commit f3877bef authored by Manish Singh's avatar Manish Singh

Checkpoint.

-Yosh
parent aae3eaf0
# The GIMP -- an image manipulation program
# Copyright (C) 1998 Manish Singh <yosh@gimp.org>
# Copyright (C) 1998-1999 Manish Singh <yosh@gimp.org>
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
......@@ -25,81 +25,123 @@ $destdir = "$main::destdir/app";
*arg_vname = \&Gimp::CodeGen::pdb::arg_vname;
*write_file = \&Gimp::CodeGen::util::write_file;
*FILE_EXT = \$Gimp::CodeGen::util::FILE_EXT;
%testmap = (
'<' => '>',
'>' => '<',
'<=' => '>=',
'>=' => '<='
);
sub declare_args {
my $proc = shift;
my $out = shift;
my $result = "";
foreach (@_) {
my @args = @{$proc->{$_}} if exists $proc->{$_};
foreach (@args) {
my $arg = $arg_types{(&arg_parse($_->{type}))[0]};
if (not exists $_->{no_declare}) {
if ($arg->{array} && (not exists $_->{array})) {
warn "Array without number of elements param in $proc->{name}";
}
unless (exists $_->{no_declare}) {
$result .= ' ' x 2;
$result .= $arg->{type} . &arg_vname($_) . ";\n";
if (exists $arg->{id_headers}) {
foreach (@{$arg->{id_headers}}) {
$out->{headers}->{$_}++;
}
}
if (exists $_->{get}) {
$result .= ' ' x 2;
$result .= $arg_types{$_->{get}->{type}}->{type};
$result .= &arg_vname($_->{get}) . ";\n";
}
}
}
}
$result;
}
sub make_args {
my $proc = shift;
my $result = "";
my $once;
foreach (@_) {
my @args = @{$proc->{$_}} if exists $proc->{$_};
if (scalar @args) {
$result .= "\nstatic ProcArg $proc->{name}_${_}[] =";
$result .= "\n{\n";
foreach my $arg (@{$proc->{$_}}) {
my ($type) = &arg_parse($arg->{type});
$result .= ' ' x 2 . "{\n";
$result .= ' ' x 4;
$result .= 'PDB_' . $arg_types{$type}->{name} . ",\n";
$result .= ' ' x 4;
$result .= qq/"$arg->{name}",\n/;
$result .= ' ' x 4;
$result .= qq/"$arg->{desc}"\n/;
$result .= ' ' x 2 . "},\n";
$result .= <<CODE;
{
PDB_$arg_types{$type}->{name},
"$arg->{name}",
"$arg->{desc}"
},
CODE
}
$result =~ s/,\n$/\n/;
$result .= "};\n";
}
}
$result;
}
sub marshal_inargs {
my $proc = shift;
my $result = "";
my %decls;
my $argc = 0;
my @inargs = @{$proc->{inargs}} if exists $proc->{inargs};
foreach (@inargs) {
my($pdbtype, @typeinfo) = &arg_parse($_->{type});
my $arg = $arg_types{$pdbtype};
my $type = &arg_ptype($arg);
my $var = &arg_vname($_);
$result .= ' ' x 2;
$result .= "if (success)\n" . ' ' x 4 if $success;
if (exists $arg->{id_func}) {
$decls{$type}++;
$result .= "{\n" . ' ' x 6 if $success;
$result .= "${type}_value = args[$argc].value.pdb_$type;\n";
$result .= ' ' x 4 if $success;
$result .= ' ' x 2;
$result .= "if (($var = ";
$result .= "$arg->{id_func} (${type}_value)) == NULL)\n";
$result .= ' ' x 4 unless $success;
$result .= "\t" if $success;
$result .= "success = FALSE;\n";
$result .= ' ' x 4 . "}\n" if $success;
my $code = "";
$code .= <<CODE;
if (($var = $arg->{id_func} (args[$argc].value.pdb_$type)) == NULL)
success = FALSE;
CODE
$code .= <<CODE if exists $_->{get};
else
@{[ &arg_vname($_->{get}) ]} = @{[ eval qq/"$arg->{$_->{get}->{type}}"/ ]};
CODE
if ($success) {
$code =~ s/^/' ' x 4/meg;
$code =~ s/^ {8}/\t/mg;
$result .= "{\n" . $code . ' ' x 4 . "}\n";
}
else {
$result .= $code;
}
$success = 1;
}
else {
......@@ -107,65 +149,82 @@ sub marshal_inargs {
# FIXME: implement this
}
elsif ($pdbtype eq 'boolean') {
$result .= "$var = ";
$result .= "(args[$argc].value.pdb_$type) ? TRUE : FALSE;\n";
}
elsif (defined $typeinfo[0] || defined $typeinfo[2]) {
my $tests = 0;
$result .= "success = (";
if (defined $typeinfo[0]) {
$result .= "$var $typeinfo[1] $typeinfo[0]";
$tests++;
}
if (defined $typeinfo[2]) {
$result .= '|| ' if $tests;
$result .= "$var $typeinfo[2] $typeinfo[3]";
}
$result .= ");\n";
$result .= ' ' x 2 . "$var = ";
$result .= "args[$argc].value.pdb_$type ? TRUE : FALSE;\n";
}
else {
my $cast = "";
$cast = " ($arg->{type})" if $type eq "pointer";
$cast = " ($arg->{type})" if $arg->{type} =~ /int(16|8)$/;
$result .= "$var =$cast args[$argc].value.pdb_$type;\n";
$result .= ' ' x 2 . "$var =";
$result .= "$cast args[$argc].value.pdb_$type;\n";
if ($pdbtype eq 'string') {
$result .= ' ' x 2 . "success = $var != NULL;\n";
$success = 1;
}
elsif (defined $typeinfo[0] || defined $typeinfo[2]) {
my $tests = 0;
$result .= ' ' x 2 . "success = ";
if (defined $typeinfo[0]) {
$result .= "$var $testmap{$typeinfo[1]} $typeinfo[0]";
$tests++;
}
if (defined $typeinfo[2]) {
$result .= '|| ' if $tests;
$result .= "$var $testmap{$typeinfo[2]} $typeinfo[3]";
}
$result .= ";\n";
$success = 1;
}
}
}
$argc++; $result .= "\n";
}
chomp $result if !$success && $argc == 1;
my $decls;
foreach (keys %decls) { $decls .= ' ' x 2 . "$_ ${_}_value;\n" }
$result = $decls . "\n" . $result if $decls;
$result and $result = "\n" . $result unless $decls;
$result = "\n" . $result if $result;
$result;
}
sub marshal_outargs {
my $proc = shift;
my $result = <<CODE;
return_args = procedural_db_return_args (\&$proc->{name}_proc, success);
CODE
my $argc = 0;
my @outargs = @{$proc->{outargs}} if exists $proc->{outargs};
if (scalar @outargs) {
my $outargs = "";
foreach (@{$proc->{outargs}}) {
my ($pdbtype) = &arg_parse($_->{type});
my $arg = $arg_types{$pdbtype};
my $type = &arg_ptype($arg);
my $var = &arg_vname($_);
$argc++; $outargs .= ' ' x 2;
if (exists $arg->{id_ret_func}) {
$outargs .= "return_args[$argc].value.pdb_$type = ";
$outargs .= eval qq/"$arg->{id_ret_func}"/;
$outargs .= ";\n";
}
else {
$outargs .= "return_args[$argc].value.pdb_$type = $var;\n";
$var = eval qq/"$arg->{id_ret_func}"/;
}
$outargs .= "return_args[$argc].value.pdb_$type = $var;\n";
}
$outargs =~ s/^/' ' x 2/meg if $success;
$outargs =~ s/^/' ' x 2/meg if $success && $argc > 1;
$result .= "\n" if $success || $argc > 1;
$result .= ' ' x 2 . "if (success)\n" if $success;
$result .= ' ' x 4 . "{\n" if $success && $argc > 1;
......@@ -176,6 +235,7 @@ CODE
else {
$result =~ s/_args =//;
}
$result =~ s/, success\);$/, TRUE);/m unless $success;
$result;
}
......@@ -227,8 +287,10 @@ CODE
$invoker .= "\n" if $invoker && $invoker !~ /\n\n/s;
my $code = $proc->{invoke}->{code};
chomp $code;
$code =~ s/\t/' ' x 8/eg;
if ($code =~ /^\s*\{\s*\n.*\n\s*\}\s*$/s && !$success) {
$code =~ s/^\s*\{\s*\n//s;
$code =~ s/\n\s*}\s*$//s;
......@@ -242,7 +304,11 @@ CODE
$code = ' ' x 2 . "if (success)\n" . $code if $success;
$success = ($code =~ /success =/) unless $success;
$out->{code} .= ' ' x 2 . "int success = TRUE;\n" if $success;
if ($success) {
$out->{code} .= ' ' x 2;
$out->{code} .= "int success = $proc->{invoke}->{success};\n";
}
$out->{code} .= $invoker . $code . "\n";
$out->{code} .= "\n" if $code =~ /\n/s || $invoker;
$out->{code} .= &marshal_outargs($proc) . "}\n";
......@@ -290,7 +356,7 @@ CODE
GPL
my $internal = "$destdir/internal_procs.h.tmp.$$";
my $internal = "$destdir/internal_procs.h$FILE_EXT";
open INTERNAL, "> $internal" or die "Can't open $cmdfile: $!\n";
print INTERNAL $gpl;
my $guard = "__INTERNAL_PROCS_H__";
......@@ -310,7 +376,7 @@ HEADER
foreach $group (@main::groups) {
my $out = $out{$group};
my $cfile = "$destdir/${group}_cmds.c.tmp.$$";
my $cfile = "$destdir/${group}_cmds.c$FILE_EXT";
open CFILE, "> $cfile" or die "Can't open $cmdfile: $!\n";
print CFILE $gpl;
foreach my $header (sort keys %{$out->{headers}}) {
......@@ -341,7 +407,7 @@ HEADER
$pcount += $out->{pcount};
}
$internal = "$destdir/internal_procs.c.tmp.$$";
$internal = "$destdir/internal_procs.c$FILE_EXT";
open INTERNAL, "> $internal" or die "Can't open $cmdfile: $!\n";
print INTERNAL $gpl;
print INTERNAL qq/#include "app_procs.h"\n\n/;
......
......@@ -16,5 +16,5 @@
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Modify this list for the groups to parse in the pdb directory
@groups = qw(gdisplay edit floating_sel undo palette gradients convert
channel_ops);
@groups = qw(gdisplay edit floating_sel undo palette gradient
convert channel_ops);
......@@ -24,11 +24,18 @@ $destdir = "$main::destdir/libgimp";
*arg_parse = \&Gimp::CodeGen::pdb::arg_parse;
*write_file = \&Gimp::CodeGen::util::write_file;
*FILE_EXT = \$Gimp::CodeGen::util::FILE_EXT;
sub generate {
my @procs = @{(shift)};
my %out;
sub libtype {
my ($arg, $type) = @_;
$type =~ s/\d+// unless exists $arg->{keep_size};
$type;
}
foreach my $name (@procs) {
my $proc = $main::pdb{$name};
my $out = \%{$out{$proc->{group}}};
......@@ -45,7 +52,11 @@ sub generate {
# explicity set
my $retarg;
foreach (@outargs) { $retarg = $_, last if exists $_->{retval} }
scalar @outargs and $retarg = $outargs[0] unless $retarg;
unless ($retarg) {
if (scalar @outargs) {
$retarg = exists $outargs[0]->{num} ? $outargs[1] : $outargs[0];
}
}
my $rettype; my $retcol = 0;
if ($retarg) {
......@@ -53,8 +64,8 @@ sub generate {
if ($type ne 'color') {
my $arg = $arg_types{$type};
$rettype = do {
if (exists $arg->{id_func}) { 'gint32 ' }
else { $arg->{type} }
if (exists $arg->{id_func}) { 'gint32 ' }
else { &libtype($_, $arg->{type}) }
};
chop $rettype unless $rettype =~ /\*$/;
}
......@@ -62,6 +73,8 @@ sub generate {
# Color returns three components in pointers passed in
$rettype = 'void'; $retcol = 1;
}
$retarg->{retval} = 1;
}
else {
# No return values
......@@ -74,21 +87,28 @@ sub generate {
my ($type) = &arg_parse($_->{type});
my $arg = $arg_types{$type};
my $id = exists $arg->{id_func};
if ($type ne 'color') {
$arglist .= do {
if ($id) { 'gint32 ' }
else { $arg->{type} }
if ($id) { 'gint32 ' }
else { &libtype($_, $arg->{type}) }
};
$arglist .= $_->{name};
$arglist .= '_ID' if $id;
$arglist .= ', ';
}
else {
# A color needs to stick the components into a 3-element array
$color = "\n" . ' ' x 2 . "guchar $_->{name}\[3];\n\n";
$color .= ' ' x 2 . "$_->{name}\[0] = red;\n";
$color .= ' ' x 2 . "$_->{name}\[1] = green;\n";
$color .= ' ' x 2 . "$_->{name}\[2] = blue;";
chop ($color = <<CODE);
guchar $_->{name}\[3];
$_->{name}\[0] = red;
$_->{name}\[1] = green;
$_->{name}\[2] = blue;
CODE
$arglist .= "guchar red, guchar green, guchar blue, ";
}
......@@ -101,24 +121,33 @@ sub generate {
# This marshals the return value(s)
my $return_args = "";
my $return_marshal;
$return_marshal = "gimp_destroy_params (return_vals, nreturn_vals);";
my $return_marshal = "gimp_destroy_params (return_vals, nreturn_vals);";
# We only need to bother with this if we have to return a value
if ($rettype ne 'void' || $retcol) {
my $argc = 1; my $once = 0;
my $once = 0;
my $firstvar;
my @arraynums;
foreach (@outargs) {
my ($type) = &arg_parse($_->{type});
my $arg = $arg_types{$type};
my $id = $arg->{id_ret_func};
my $var;
$return_marshal = "" unless $once++;
if ($type ne 'color') {
if (exists $_->{num}) {
if (not exists $_->{no_lib}) {
$arglist .= "gint \*$_->{name}, ";
push @arraynums, $_;
}
}
elsif ($type ne 'color') {
$return_args .= "\n" . ' ' x 2;
$return_args .= do {
if ($id) { 'gint32 ' }
else { $arg->{type} }
if ($id) { 'gint32 ' }
else { &libtype($_, $arg->{type}) }
};
# The return value variable
......@@ -131,21 +160,73 @@ sub generate {
# Initialize all IDs to -1
$return_args .= " = -1" if $id;
# Initialize pointers to NULL
$return_args .= " = NULL" if !$id && ($arg->{type} =~ /\*/);
$return_args .= ";";
if (exists $_->{array} && exists $_->{array}->{no_lib}) {
$return_args .= "\n" . ' ' x 2 . "gint num_$var;";
}
}
$return_marshal .= <<CODE;
}
foreach (@arraynums) { $return_marshal .= "\*$_->{name} = 0;\n "; }
$return_marshal =~ s/\n $/\n\n /s if scalar(@arraynums);
$return_marshal .= <<CODE;
if (return_vals[0].data.d_status == STATUS_SUCCESS)
CODE
if ($type ne 'color') {
$return_marshal .= ' ' x 4 . "$var = ";
$return_marshal .= 'g_strdup (' if $type eq 'string';
$return_marshal .= "return_vals[$argc].data.d_$type";
$return_marshal .= ')' if $type eq 'string';
$return_marshal .= ";\n";
$return_marshal .= ' ' x 4 . "{\n" if $#outargs;
my $argc = 1; my ($numpos, $numtype);
foreach (@outargs) {
my ($type) = &arg_parse($_->{type});
my $arg = $arg_types{$type};
my $id = $arg->{id_ret_func};
my $var;
my $head = ""; my $foot = "";
if ($type =~ /^string(array)?/) {
$head = 'g_strdup (';
$foot = ')';
}
if (exists $_->{num}) {
$numpos = $argc;
$numtype = $type;
}
elsif (exists $_->{array}) {
my $datatype = $arg->{type};
chop $datatype;
$datatype =~ s/ *$//;
$return_args .= "\n" . ' ' x 2 . "gint i;";
my $numvar = '*' . $_->{array}->{name};
$numvar = "num_$_->{name}" if exists $_->{array}->{no_lib};
$return_marshal .= <<CODE;
$numvar = return_vals[$numpos].data.d_$numtype;
$_->{name} = g_new ($datatype, $numvar);
for (i = 0; i < $numvar; i++)
$_->{name}\[i] = ${head}return_vals[$argc].data.d_$type\[i]${foot};
CODE
}
elsif ($type ne 'color') {
# The return value variable
$var = $_->{name};
$var .= '_ID' if $id;
$return_marshal .= <<CODE
$var = ${head}return_vals[$argc].data.d_$type${foot};
CODE
}
else {
# Colors are returned in parts using pointers
$arglist .= "guchar \*red, guchar \*green, guchar \*blue";
$arglist .= "guchar \*red, guchar \*green, guchar \*blue, ";
$return_marshal .= <<CODE
{
\*red = return_vals[$argc].data.d_color.red;
......@@ -154,8 +235,12 @@ CODE
}
CODE
}
$argc++;
}
$return_marshal .= ' ' x 4 . "}\n" if $#outargs;
$return_marshal .= <<'CODE';
gimp_destroy_params (return_vals, nreturn_vals);
......@@ -169,6 +254,9 @@ CODE
# We don't need the last comma in the declaration
$arglist =~ s/, $//;
}
else {
$arglist = "void";
}
# Our function prototype for the headers
push @{$out->{proto}}, "$rettype gimp_$name ($arglist);\n";
......@@ -179,7 +267,7 @@ $rettype
gimp_$name ($arglist)
{
GParam *return_vals;
int nreturn_vals;$return_args$color
gint nreturn_vals;$return_args$color
return_vals = gimp_run_procedure ("gimp_$name",
\&nreturn_vals,$argpass
......@@ -215,8 +303,8 @@ LGPL
# We generate two files, a .h file with prototypes for all the functions
# we make, and a .c file for the actual implementation
while (my($group, $out) = each %out) {
my $hfile = "$destdir/gimp${group}.h.tmp.$$";
my $cfile = "$destdir/gimp${group}.c.tmp.$$";
my $hfile = "$destdir/gimp${group}.h$FILE_EXT";
my $cfile = "$destdir/gimp${group}.c$FILE_EXT";
my $protos;
foreach (@{$out->{proto}}) { $protos .= $_ }
......
......@@ -25,11 +25,11 @@ package Gimp::CodeGen::pdb;
float => { name => 'FLOAT' , type => 'gdouble ' },
string => { name => 'STRING', type => 'gchar *' },
int32array => { name => 'INT32ARRAY' , type => 'gint32 *' },
int16array => { name => 'INT16ARRAY' , type => 'gint16 *' },
int8array => { name => 'INT8ARRAY' , type => 'gint8 *' },
floatarray => { name => 'FLOATARRAY' , type => 'gdouble *' },
stringarray => { name => 'STRINGARRAY', type => 'gchar **' },
int32array => { name => 'INT32ARRAY' , type => 'gint32 *' , array => 1 },
int16array => { name => 'INT16ARRAY' , type => 'gint16 *' , array => 1 },
int8array => { name => 'INT8ARRAY' , type => 'gint8 *' , array => 1 },
floatarray => { name => 'FLOATARRAY' , type => 'gdouble *', array => 1 },
stringarray => { name => 'STRINGARRAY', type => 'gchar **' , array => 1 },
color => { name => 'COLOR' , type => 'guchar *' },
......@@ -67,7 +67,7 @@ package Gimp::CodeGen::pdb;
id_func => 'gimp_drawable_get_ID',
id_ret_func => 'drawable_ID (GIMP_DRAWABLE ($var))',
id_headers => [ qw("drawable.h") ],
gimage => 'drawable_gimage (GIMP_DRAWABLE ($var))'
image => 'drawable_gimage (GIMP_DRAWABLE ($var))'
},
selection => {
name => 'SELECTION',
......@@ -114,3 +114,5 @@ sub arg_ptype {
# Return the alias if defined, otherwise the name
sub arg_vname { exists $_[0]->{alias} ? $_[0]->{alias} : $_[0]->{name} }
sub arg_numtype () { 'gint32 ' }
......@@ -35,7 +35,7 @@ HELP
@inargs = (
{ name => 'drawable', type => 'drawable',
desc => 'The drawable to offset', gimage => 1 },
desc => 'The drawable to offset', get => &std_image_arg },
{ name => 'wrap_around', type => 'boolean',
desc => 'wrap image around or fill vacated regions' },
{ name => 'fill_type', type => 'enum GimpOffsetType',
......
......@@ -36,7 +36,7 @@ HELP
@outargs = (
{ name => 'display', type => 'display',
desc => 'The new display' }
desc => 'The new display', alias => 'gdisp' }
);
%invoke = (
......@@ -47,7 +47,7 @@ HELP
if (gimage->layers == NULL)
success = FALSE;
else
success = ((display = gdisplay_new (gimage, scale)) != NULL);
success = ((gdisp = gdisplay_new (gimage, scale)) != NULL);
}
CODE
);
......@@ -65,12 +65,12 @@ HELP
@inargs = (
{ name => 'display', type => 'display',
desc => 'The display to delete' }
desc => 'The display to delete', alias => 'gdisp' }
);
%invoke = (
headers => [ qw("gdisplay.h") ],
code => 'gtk_widget_destroy (display->shell);'
code => 'gtk_widget_destroy (gdisp->shell);'
);
}
......
......@@ -17,12 +17,12 @@
# "Perlized" from C source by Manish Singh <yosh@gimp.org>
# Common arguments for image and drawable
# Common arguments
sub inargs {
@inargs = (
&std_image_arg,
{ name => 'drawable', type => 'drawable',
desc => "The drawable to @{[shift]}" }
desc => "The drawable to @{[shift]}",
get => &std_image_arg }
);
}
......@@ -30,14 +30,7 @@ sub inargs {
sub invoke {
%invoke = (
headers => [ qw("global_edit.h") ],
code => <<CODE
{
if (gimage != drawable_gimage (drawable))
success = FALSE;
else
success = @{[shift]};
}
CODE
code => "success = @{[shift]};"
);
}
......@@ -57,7 +50,7 @@ HELP
&std_pdb_misc;
&inargs('cut from');
&invoke('(edit_cut (gimage, drawable) != NULL)');
&invoke('edit_cut (gimage, drawable) != NULL');
}
sub edit_copy {
......@@ -74,7 +67,7 @@ HELP
&std_pdb_misc;
&inargs('copy from');
&invoke('(edit_copy (gimage, drawable) != NULL)');
&invoke('edit_copy (gimage, drawable) != NULL');
}
sub edit_paste {
......@@ -107,10 +100,9 @@ HELP
desc => 'The new floating selection', alias => 'layer' }
);
&invoke('(layer != NULL)');
&invoke('layer != NULL');
$cmd = "layer = edit_paste (gimage, drawable, global_buf, paste_into);\n";
$invoke{code} =~ s/(else\n)/$1 . ' ' x 4 . "{\n" . ' ' x 6 . $cmd/se;
$invoke{code} =~ s/(success = \(.*?\n)/' ' x 2 . $1 . ' ' x 4 . "}\n"/se;
$invoke{code} = "{\n" . ' ' x 2 . $cmd . ' ' x 2 . $invoke{code} . "\n}\n";
}
sub edit_clear {
......
......@@ -36,7 +36,7 @@ HELP
@outargs = (
{ name => 'display', type => 'display',
desc => 'The new display' }
desc => 'The new display', alias => 'gdisp' }
);
%invoke = (
......@@ -47,7 +47,7 @@ HELP
if (gimage->layers == NULL)
success = FALSE;
else
success = ((display = gdisplay_new (gimage, scale)) != NULL);
success = ((gdisp = gdisplay_new (gimage, scale)) != NULL);
}
CODE
);
......@@ -65,12 +65,12 @@ HELP
@inargs = (
{ name => 'display', type => 'display',
desc => 'The display to delete' }
desc => 'The display to delete', alias => 'gdisp' }
);