epics/pcas
0
0
Fork 0
Code Issues Pull Requests Projects Wiki Activity

2009-02-08: Work with & match R3.14.10 output; rename tools.

Browse Source
This commit is contained in:
Andrew Johnson
2010-04-08 17:23:32 -05:00
parent f464b4d899
commit 68e0fba01b
7 changed files with 280 additions and 193 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/dbHost/DBD/Menu.pm
View File

@@ -41,11 +41,11 @@ sub toDeclaration {
my $this = shift;
my $name = $this->name;
my @choices = map {
"\t" . @{$_}[0] . "\t/* " . escapeCcomment(@{$_}[1]) . " */"
sprintf " %-31s /* %s */", @{$_}[0], escapeCcomment(@{$_}[1]);
} $this->choices;
return "typedef enum {\n" .
join(",\n", @choices) .
",\n\t${name}_NUM_CHOICES\n" .
",\n ${name}_NUM_CHOICES\n" .
"} $name;\n\n";
}

16
src/dbHost/DBD/Recfield.pm
View File

@@ -156,7 +156,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("signed char");
return shift->SUPER::toDeclaration("epicsInt8");
}
@@ -176,7 +176,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("unsigned char");
return shift->SUPER::toDeclaration("epicsUInt8");
}
@@ -196,7 +196,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("short");
return shift->SUPER::toDeclaration("epicsInt16");
}
@@ -216,7 +216,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("unsigned short");
return shift->SUPER::toDeclaration("epicsUInt16");
}
@@ -253,7 +253,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("unsigned long");
return shift->SUPER::toDeclaration("epicsUInt32");
}
@@ -270,7 +270,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("float");
return shift->SUPER::toDeclaration("epicsFloat32");
}
@@ -287,7 +287,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("double");
return shift->SUPER::toDeclaration("epicsFloat64");
}
@@ -417,7 +417,7 @@ sub check_valid {
sub toDeclaration {
my ($this) = @_;
my $extra = $this->attribute('extra');
my $result = sprintf " %-32s", "$extra;";
my $result = sprintf " %-31s ", "$extra;";
my $prompt = $this->attribute('prompt');
$result .= "/* $prompt */" if defined $prompt;
return $result;

30
src/dbHost/Makefile Normal file
View File

@@ -0,0 +1,30 @@
#*************************************************************************
# Copyright (c) 2009 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
TOP=../..
include $(TOP)/configure/CONFIG
PERL_MODULES += macLib.pm
PERL_MODULES += Readfile.pm
PERL_MODULES += DBD.pm
PERL_MODULES += DBD/Base.pm
PERL_MODULES += DBD/Breaktable.pm
PERL_MODULES += DBD/Device.pm
PERL_MODULES += DBD/Driver.pm
PERL_MODULES += DBD/Function.pm
PERL_MODULES += DBD/Menu.pm
PERL_MODULES += DBD/Parser.pm
PERL_MODULES += DBD/Recfield.pm
PERL_MODULES += DBD/Recordtype.pm
PERL_MODULES += DBD/Registrar.pm
PERL_MODULES += DBD/Variable.pm
PERL_SCRIPTS += dbdToMenuH.pl
PERL_SCRIPTS += dbdToRecordtypeH.pl
PERL_SCRIPTS += dbExpand.pl
include $(TOP)/configure/RULES

5
src/dbHost/dbExpand → src/dbHost/dbExpand.pl
View File

@@ -4,7 +4,10 @@
# duplicate definitions, unlike the dbStaticLib version. It does do the
# include file expansion and macro substitution though.
use Getopts;
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use EPICS::Getopts;
use Readfile;
use macLib;

177
src/dbHost/dbToRecordtypeH
View File

@@ -1,177 +0,0 @@
#!/usr/bin/perl
use DBD;
use DBD::Parser;
use Getopts;
use macLib;
use Readfile;
my $tool = 'dbToRecordtypeH';
getopts('DI@o:') or
die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n";
my @path = map { split /[:;]/ } @opt_I;
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $outfile;
if ($opt_o) {
$outfile = $opt_o;
} elsif (@ARGV) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
$outfile =~ s/dbCommonRecord/dbCommon/;
}
# Derive a name for the include guard
my $guard_name = "INC_$outfile";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
my $rtypes = $dbd->recordtypes;
die "$tool: Input file must contain a single recordtype definition.\n"
unless (1 == keys %{$rtypes});
if ($opt_D) { # Output dependencies only, to stdout
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outfile generated from $infile */\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
my ($rn, $rtyp) = each %{$rtypes};
print OUTFILE $rtyp->toCdefs;
my @menu_fields = grep {
$_->dbf_type eq 'DBF_MENU'
} $rtyp->fields;
my %menu_used;
grep {
!$menu_used{$_}++
} map {
$_->attribute('menu')
} @menu_fields;
my $menus_defined = $dbd->menus;
while (($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDeclaration;
if ($menu_used{$name}) {
delete $menu_used{$name}
} else {
warn "Menu '$name' defined but not used\n";
}
}
my @menus_external = keys %menu_used;
print OUTFILE $rtyp->toDeclaration;
unless ($rn eq 'dbCommon') {
my $n=0;
print OUTFILE "typedef enum {\n",
join(",\n", map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names),
"\n} ${rn}FieldIndex;\n\n";
print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n";
print OUTFILE (map {
"extern const dbMenu ${_}MenuMetaData;\n"
} @menus_external), "\n";
while (($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDefinition;
}
print OUTFILE (map {
"static const char ${rn}FieldName$_\[] = \"$_\";\n" }
$rtyp->field_names), "\n";
$n=0;
print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n",
"static dbFldDes ${rn}FieldMetaData[] = {\n",
join(",\n", map {
my $fn = $_->name;
" { ${rn}FieldName$fn," .
$_->dbf_type . ',"' .
$_->attribute('initial') . '",' .
($_->attribute('special') || '0') . ',' .
($_->attribute('pp') || 'FALSE') . ',' .
($_->attribute('interest') || '0') . ',' .
($_->attribute('asl') || 'ASL0') . ',' .
$n++ . ",\n\t\&${rn}RecordMetaData," .
"GEOMETRY_DATA(${rn}Record," . lc($fn) . ') }';
} $rtyp->fields),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFields[] = {\n",
join(",\n", map {
" ${rn}Record" . $_->name;
} grep {
$_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/;
} $rtyp->fields),
"\n};\n\n";
my @sorted_names = sort $rtyp->field_names;
print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n",
join(",\n", map {
" ${rn}FieldName$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndex[] = {\n",
join(",\n", map {
" ${rn}Record$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "extern rset ${rn}RSET;\n\n",
"static const dbRecordData ${rn}RecordMetaData = {\n",
" \"$rn\",\n",
" sizeof(${rn}Record),\n",
" NELEMENTS(${rn}FieldMetaData),\n",
" ${rn}FieldMetaData,\n",
" ${rn}RecordVAL,\n",
" \&${rn}FieldMetaData[${rn}RecordVAL],\n",
" NELEMENTS(${rn}RecordLinkFields),\n",
" ${rn}RecordLinkFields,\n",
" ${rn}RecordSortedFieldNames,\n",
" ${rn}RecordSortedFieldIndex,\n",
" \&${rn}RSET\n",
"};\n\n",
"#ifdef __cplusplus\n",
"extern \"C\" {\n",
"#endif\n\n";
print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n",
"{\n",
" dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n";
print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n";
while (($name, $menu) = each %{$menus_defined}) {
print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n";
}
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.pmenu = \n".
" \&" .
$_->attribute('menu') .
"MenuMetaData;\n";
} @menu_fields;
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.base = CT_HEX;\n";
} grep {
$_->attribute('base') eq 'HEX';
} $rtyp->fields;
print OUTFILE " dbRegisterRecordtype(pbase, prt);\n";
print OUTFILE " return prt;\n}\n\n",
"#ifdef __cplusplus\n",
"} /* extern \"C\" */\n",
"#endif\n\n",
"#endif /* GEN_SIZE_OFFSET */\n";
}
print OUTFILE "\n",
"#endif /* $guard_name */\n";
close OUTFILE;
}

19
src/dbHost/dbToMenuH → src/dbHost/dbdToMenuH.pl
View File

@@ -1,12 +1,19 @@
#!/usr/bin/perl
# $Id$
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use EPICS::Getopts;
use File::Basename;
use DBD;
use DBD::Parser;
use Getopts;
use macLib;
use Readfile;
my $tool = 'dbToMenuH';
my $tool = 'dbdToMenuH.pl';
use vars qw($opt_D @opt_I $opt_o $opt_s);
getopts('DI@o:') or
die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n";
@@ -16,6 +23,7 @@ my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $inbase = basename($infile);
my $outfile;
if ($opt_o) {
@@ -26,9 +34,10 @@ if ($opt_o) {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
}
my $outbase = basename($outfile);
# Derive a name for the include guard
my $guard_name = "INC_$outfile";
my $guard_name = "INC_$outbase";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
@@ -41,11 +50,11 @@ if ($opt_D) {
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outfile generated from $infile */\n\n",
print OUTFILE "/* $outbase generated from $inbase */\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
my $menus = $dbd->menus;
while (($name, $menu) = each %{$menus}) {
while (my ($name, $menu) = each %{$menus}) {
print OUTFILE $menu->toDeclaration;
}
# FIXME: Where to put metadata for widely used menus?

222
src/dbHost/dbdToRecordtypeH.pl Executable file
View File

@@ -0,0 +1,222 @@
#!/usr/bin/perl
# $Id$
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use EPICS::Getopts;
use File::Basename;
use DBD;
use DBD::Parser;
use macLib;
use Readfile;
my $tool = 'dbdToRecordtypeH.pl';
use vars qw($opt_D @opt_I $opt_o $opt_s);
getopts('DI@o:s') or
die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n";
my @path = map { split /[:;]/ } @opt_I;
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $inbase = basename($infile);
my $outfile;
if ($opt_o) {
$outfile = $opt_o;
} elsif (@ARGV) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
$outfile =~ s/dbCommonRecord/dbCommon/;
}
my $outbase = basename($outfile);
# Derive a name for the include guard
my $guard_name = "INC_$outbase";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
my $rtypes = $dbd->recordtypes;
die "$tool: Input file must contain a single recordtype definition.\n"
unless (1 == keys %{$rtypes});
if ($opt_D) { # Output dependencies only, to stdout
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outbase generated from $inbase */\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
our ($rn, $rtyp) = each %{$rtypes};
print OUTFILE $rtyp->toCdefs;
my @menu_fields = grep {
$_->dbf_type eq 'DBF_MENU'
} $rtyp->fields;
my %menu_used;
grep {
!$menu_used{$_}++
} map {
$_->attribute('menu')
} @menu_fields;
our $menus_defined = $dbd->menus;
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDeclaration;
if ($menu_used{$name}) {
delete $menu_used{$name}
} else {
warn "Menu '$name' defined but not used\n";
}
}
our @menus_external = keys %menu_used;
print OUTFILE $rtyp->toDeclaration;
unless ($rn eq 'dbCommon') {
my $n = 0;
print OUTFILE "typedef enum {\n",
join(",\n",
map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names),
"\n} ${rn}FieldIndex;\n\n";
print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n";
if ($opt_s) {
&newtables;
} else {
&oldtables;
}
print OUTFILE "#endif /* GEN_SIZE_OFFSET */\n";
}
print OUTFILE "\n",
"#endif /* $guard_name */\n";
close OUTFILE;
}
sub oldtables {
# Output compatible with R3.14.x
print OUTFILE "#ifdef __cplusplus\n" .
"extern \"C\" {\n" .
"#endif\n" .
"#include <epicsExport.h>\n" .
"static int ${rn}RecordSizeOffset(dbRecordType *prt)\n" .
"{\n" .
" ${rn}Record *prec = 0;\n" .
join("\n", map {
" prt->papFldDes[${rn}Record$_]->size = " .
"sizeof(prec->" . lc($_) . ");"
} $rtyp->field_names) . "\n" .
join("\n", map {
" prt->papFldDes[${rn}Record$_]->offset = " .
"(char *)&prec->" . lc($_) . " - (char *)prec;"
} $rtyp->field_names) . "\n" .
" prt->rec_size = sizeof(*prec);\n" .
" return 0;\n" .
"}\n" .
"epicsExportRegistrar(${rn}RecordSizeOffset);\n\n" .
"#ifdef __cplusplus\n" .
"}\n" .
"#endif\n";
}
sub newtables {
# Output for an eventual DBD-less IOC
print OUTFILE (map {
"extern const dbMenu ${_}MenuMetaData;\n"
} @menus_external), "\n";
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDefinition;
}
print OUTFILE (map {
"static const char ${rn}FieldName$_\[] = \"$_\";\n" }
$rtyp->field_names), "\n";
my $n = 0;
print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n",
"static dbFldDes ${rn}FieldMetaData[] = {\n",
join(",\n", map {
my $fn = $_->name;
" { ${rn}FieldName${fn}," .
$_->dbf_type . ',"' .
$_->attribute('initial') . '",' .
($_->attribute('special') || '0') . ',' .
($_->attribute('pp') || 'FALSE') . ',' .
($_->attribute('interest') || '0') . ',' .
($_->attribute('asl') || 'ASL0') . ',' .
$n++ . ",\n\t\&${rn}RecordMetaData," .
"GEOMETRY_DATA(${rn}Record," . lc($fn) . ') }';
} $rtyp->fields),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFieldIndices[] = {\n",
join(",\n", map {
" ${rn}Record" . $_->name;
} grep {
$_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/;
} $rtyp->fields),
"\n};\n\n";
my @sorted_names = sort $rtyp->field_names;
print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n",
join(",\n", map {
" ${rn}FieldName$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndices[] = {\n",
join(",\n", map {
" ${rn}Record$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "extern rset ${rn}RSET;\n\n",
"static const dbRecordData ${rn}RecordMetaData = {\n",
" \"$rn\",\n",
" sizeof(${rn}Record),\n",
" NELEMENTS(${rn}FieldMetaData),\n",
" ${rn}FieldMetaData,\n",
" ${rn}RecordVAL,\n",
" \&${rn}FieldMetaData[${rn}RecordVAL],\n",
" NELEMENTS(${rn}RecordLinkFieldIndices),\n",
" ${rn}RecordLinkFieldIndices,\n",
" ${rn}RecordSortedFieldNames,\n",
" ${rn}RecordSortedFieldIndices,\n",
" \&${rn}RSET\n",
"};\n\n",
"#ifdef __cplusplus\n",
"extern \"C\" {\n",
"#endif\n\n";
print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n",
"{\n",
" dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n";
print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n";
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n";
}
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.pmenu = \n".
" \&" .
$_->attribute('menu') .
"MenuMetaData;\n";
} @menu_fields;
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.base = CT_HEX;\n";
} grep {
$_->attribute('base') eq 'HEX';
} $rtyp->fields;
print OUTFILE " dbRegisterRecordtype(pbase, prt);\n";
print OUTFILE " return prt;\n}\n\n",
"#ifdef __cplusplus\n",
"} /* extern \"C\" */\n",
"#endif\n\n";
}