sys/kern/makeobjops.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Copyright (c) 1992, 1993
   4 #        The Regents of the University of California.  All rights reserved.
   5 #
   6 # Redistribution and use in source and binary forms, with or without
   7 # modification, are permitted provided that the following conditions
   8 # are met:
   9 # 1. Redistributions of source code must retain the above copyright
  10 #    notice, this list of conditions and the following disclaimer.
  11 # 2. Redistributions in binary form must reproduce the above copyright
  12 #    notice, this list of conditions and the following disclaimer in the
  13 #    documentation and/or other materials provided with the distribution.
  14 # 3. All advertising materials mentioning features or use of this software
  15 #    must display the following acknowledgement:
  16 #        This product includes software developed by the University of
  17 #        California, Berkeley and its contributors.
  18 # 4. Neither the name of the University nor the names of its contributors
  19 #    may be used to endorse or promote products derived from this software
  20 #    without specific prior written permission.
  21 #
  22 # THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  23 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  24 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  25 # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  26 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  27 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  28 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  29 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  30 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  31 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  32 # SUCH DAMAGE.
  33 #
  34 # From @(#)vnode_if.sh        8.1 (Berkeley) 6/10/93
  35 # From @(#)makedevops.sh 1.1 1998/06/14 13:53:12 dfr Exp $
  36 # From @(#)makedevops.sh ?.? 1998/10/05
  37 # From src/sys/kern/makedevops.pl,v 1.12 1999/11/22 14:40:04 n_hibma Exp
  38 #
  39 # $FreeBSD$
  40
  41 #
  42 # Script to produce kobj front-end sugar.
  43 #
  44
  45 use strict;
  46 use Getopt::Std;
  47 use vars qw($opt_c $opt_d $opt_h $opt_l $opt_p);
  48
  49 my $line_width = 80;
  50
  51 my $gerror = 0;
  52 my @filenames;
  53 my $tmpdir;
  54
  55 my $intname;
  56
  57 # Process the command line
  58 #
  59 getopts('cdhl:p')
  60     or usage();
  61
  62 warn "Will produce files in original not in current directory"
  63     if $opt_d && $opt_p;
  64
  65 if (defined($opt_l)) {
  66     die("Invalid line width '$opt_l'\n")
  67         unless ($opt_l =~ m/^\d*$/ && $opt_l > 0);
  68     $line_width = $opt_l;
  69     warn "Line width set to $line_width"
  70         if $opt_d;
  71 }
  72
  73 foreach my $arg (@ARGV) {
  74     die("Invalid input filename '$arg'\n")
  75         unless ($arg =~ m/\.m$/);
  76     warn "Filename: $arg"
  77         if $opt_d;
  78     push @filenames, $arg;
  79 }
  80
  81
  82 # Validate the command line parameters
  83 #
  84 &usage()
  85     unless ($opt_c or $opt_h)
  86            and $#filenames != -1;
  87
  88 # FIXME should be able to do this more easily
  89 #
  90 $tmpdir = $ENV{'TMPDIR'};           # environment variables
  91 $tmpdir = $ENV{'TMP'}
  92     if !$tmpdir;
  93 $tmpdir = $ENV{'TEMP'}
  94     if !$tmpdir;
  95 $tmpdir = '/tmp'                    # look for a physical directory
  96     if !$tmpdir and -d '/tmp';
  97 $tmpdir = '/usr/tmp'
  98     if !$tmpdir and -d '/usr/tmp';
  99 $tmpdir = '/var/tmp'
 100     if !$tmpdir and -d '/var/tmp';
 101 $tmpdir = '.'                       # give up and use current dir
 102     if !$tmpdir;
 103
 104 foreach my $src (@filenames) {
 105     # Names of the created files
 106     my $ctmpname = "$tmpdir/ctmp.$$";
 107     my $htmpname = "$tmpdir/htmp.$$";
 108
 109     my ($name, $path, $suffix) = &fileparse($src, '.m');
 110     $path = '.'
 111         unless $opt_p;
 112
 113     my $cfilename="$path/$name.c";
 114     my $hfilename="$path/$name.h";
 115
 116     warn "Processing from $src to $cfilename / $hfilename via $ctmpname / $htmpname"
 117         if $opt_d;
 118
 119     die "Could not open $src for reading, $!"
 120         if !open SRC, "$src";
 121     die "Could not open $ctmpname for writing, $!"
 122         if $opt_c and !open CFILE, ">$ctmpname";
 123     die "Could not open $htmpname for writing, $!"
 124         if $opt_h and !open HFILE, ">$htmpname";
 125
 126     if ($opt_c) {
 127         # Produce the header of the C file
 128         #
 129         print CFILE "/*\n";
 130         print CFILE " * This file is produced automatically.\n";
 131         print CFILE " * Do not modify anything in here by hand.\n";
 132         print CFILE " *\n";
 133         print CFILE " * Created from source file\n";
 134         print CFILE " *   $src\n";
 135         print CFILE " * with\n";
 136         print CFILE " *   $0\n";
 137         print CFILE " *\n";
 138         print CFILE " * See the source file for legal information\n";
 139         print CFILE " */\n";
 140         print CFILE "\n";
 141         print CFILE "#include <sys/param.h>\n";
 142         print CFILE "#include <sys/queue.h>\n";
 143         print CFILE "#include <sys/kernel.h>\n";
 144         print CFILE "#include <sys/kobj.h>\n";
 145     }
 146
 147     if ($opt_h) {
 148         # Produce the header of the H file
 149         #
 150         print HFILE "/*\n";
 151         print HFILE " * This file is produced automatically.\n";
 152         print HFILE " * Do not modify anything in here by hand.\n";
 153         print HFILE " *\n";
 154         print HFILE " * Created from source file\n";
 155         print HFILE " *   $src\n";
 156         print HFILE " * with\n";
 157         print HFILE " *   $0\n";
 158         print HFILE " *\n";
 159         print HFILE " * See the source file for legal information\n";
 160         print HFILE " */\n";
 161         print HFILE "\n";
 162     }
 163
 164     my %methods = ();    # clear list of methods
 165     my @mnames = ();
 166     my @defaultmethods = ();
 167     my $lineno = 0;
 168     my $error = 0;       # to signal clean up and gerror setting
 169
 170     LINE: while (my $line = <SRC>) {
 171         $lineno++;
 172
 173         # take special notice of include directives.
 174         #
 175         if ($line =~ m/^#\s*include\s+(["<])([^">]+)([">]).*/i) {
 176             warn "Included file: $1$2" . ($1 eq '<'? '>':'"')
 177                 if $opt_d;
 178             print CFILE "#include $1$2" . ($1 eq '<'? '>':'"') . "\n"
 179                 if $opt_c;
 180         }
 181
 182         $line =~ s/#.*//;              # remove comments
 183         $line =~ s/^\s+//;             # remove leading ...
 184         $line =~ s/\s+$//;             # remove trailing whitespace
 185
 186         if ($line =~ m/^$/) {          # skip empty lines
 187             # nop
 188         } elsif ($line =~ m/^INTERFACE\s*([^\s;]*)(\s*;?)/i) {
 189             $intname = $1;
 190             my $semicolon = $2;
 191             unless ($intname =~ m/^[a-z_][a-z0-9_]*$/) {
 192                 warn $line
 193                     if $opt_d;
 194                 warn "$src:$lineno: Invalid interface name '$intname', use [a-z_][a-z0-9_]*";
 195                 $error = 1;
 196                 last LINE;
 197             }
 198
 199             warn "$src:$lineno: semicolon missing at end of line, no problem"
 200                 if $semicolon !~ s/;$//;
 201
 202             warn "Interface $intname"
 203                 if $opt_d;
 204
 205             print HFILE '#ifndef _'.$intname."_if_h_\n"
 206                 if $opt_h;
 207             print HFILE '#define _'.$intname."_if_h_\n\n"
 208                 if $opt_h;
 209             print CFILE '#include "'.$intname.'_if.h"'."\n\n"
 210                 if $opt_c;
 211         } elsif ($line =~ m/^CODE\s*{$/i) {
 212             my $code = "";
 213             my $line = <SRC>;
 214             $line =~ m/^(\s*)/;
 215             my $indent = $1;           # find the indent used
 216             while ($line !~ m/^}/) {
 217                 $line =~ s/^$indent//g; # remove the indent
 218                 $code .= $line;
 219                 $line = <SRC>;
 220                 $lineno++
 221             }
 222             print CFILE "\n".$code."\n"
 223                 if $opt_c;
 224         } elsif ($line =~ m/^HEADER\s*{$/i) {
 225             my $header = "";
 226             my $line = <SRC>;
 227             $line =~ m/^(\s*)/;
 228             my $indent = $1;              # find the indent used
 229             while ($line !~ m/^}/) {
 230                 $line =~ s/^$indent//g; # remove the indent
 231                 $header .= $line;
 232                 $line = <SRC>;
 233                 $lineno++
 234             }
 235             print HFILE $header
 236                     if $opt_h;
 237         } elsif ($line =~ m/^(STATIC|)METHOD/i) {
 238             my $default;
 239
 240             # Get the return type function name and delete that from
 241             # the line. What is left is the possibly first function argument
 242             # if it is on the same line.
 243             #
 244             if (!$intname) {
 245                 warn "$src:$lineno: No interface name defined";
 246                 $error = 1;
 247                 last LINE;
 248             }
 249             $line =~ s/^(STATIC|)METHOD\s+([^\{]+?)\s*\{\s*//i;
 250             my $static = $1;
 251             my @ret = split m/\s+/, $2;
 252             $name = pop @ret;          # last element is name of method
 253             my $ret = join(" ", @ret);    # return type
 254
 255             warn "Method: name=$name return type=$ret"
 256                 if $opt_d;
 257
 258             if (!$name or !$ret) {
 259                 warn $line
 260                     if $opt_d;
 261                 warn "$src:$lineno: Invalid method specification";
 262                 $error = 1;
 263                 last LINE;
 264             }
 265
 266             unless ($name =~ m/^[a-z_][a-z_0-9]*$/) {
 267                 warn $line
 268                     if $opt_d;
 269                 warn "$src:$lineno: Invalid method name '$name', use [a-z_][a-z0-9_]*";
 270                 $error = 1;
 271                 last LINE;
 272             }
 273
 274             if (defined($methods{$name})) {
 275                 warn "$src:$lineno: Duplicate method name";
 276                 $error = 1;
 277                 last LINE;
 278             }
 279
 280             $methods{$name} = $name;
 281             push @mnames, $name;
 282
 283             while ($line !~ m/}/ and $line .= <SRC>) {
 284                 $lineno++
 285             }
 286
 287             $default = "";
 288             if ($line !~ s/};?(.*)//) { # remove first '}' and trailing garbage
 289                 # The '}' was not there (the rest is optional), so complain
 290                 warn "$src:$lineno: Premature end of file";
 291                 $error = 1;
 292                 last LINE;
 293             }
 294             my $extra = $1;
 295             if ($extra =~ /\s*DEFAULT\s*([a-zA-Z_][a-zA-Z_0-9]*)\s*;/) {
 296                 $default = $1;
 297             } else {
 298                 warn "$src:$lineno: Ignored '$1'"  # warn about garbage at end of line
 299                     if $opt_d and $1;
 300             }
 301
 302             # Create a list of variables without the types prepended
 303             #
 304             $line =~ s/^\s+//;            # remove leading ...
 305             $line =~ s/\s+$//;            # ... and trailing whitespace
 306             $line =~ s/\s+/ /g;           # remove double spaces
 307
 308             my @arguments = split m/\s*;\s*/, $line;
 309             my @varnames = ();               # list of varnames
 310             foreach my $argument (@arguments) {
 311                 next                      # skip argument if argument is empty
 312                     if !$argument;
 313
 314                 my @ar = split m/[*\s]+/, $argument;
 315                 if ($#ar == 0) {          # only 1 word in argument?
 316                     warn "$src:$lineno: no type for '$argument'";
 317                     $error = 1;
 318                     last LINE;
 319                 }
 320
 321                 push @varnames, $ar[-1];  # last element is name of variable
 322             };
 323
 324             warn 'Arguments: ' . join(', ', @arguments) . "\n"
 325                . 'Varnames: ' . join(', ', @varnames)
 326                 if $opt_d;
 327
 328             my $mname = $intname.'_'.$name;  # method name
 329             my $umname = uc($mname);         # uppercase method name
 330
 331             my $arguments = join(", ", @arguments);
 332             my $firstvar = $varnames[0];
 333             my $varnames = join(", ", @varnames);
 334
 335             $default = "0" if $default eq "";
 336             push @defaultmethods, $default;
 337
 338             if ($opt_h) {
 339                 # the method description
 340                 print HFILE "extern struct kobjop_desc $mname\_desc;\n";
 341                 # the method typedef
 342                 my $prototype = "typedef $ret $mname\_t(";
 343                 print HFILE &format_line("$prototype$arguments);",
 344                                          $line_width, ', ',
 345                                          ',',' ' x length($prototype))
 346                           . "\n";
 347             }
 348
 349             if ($opt_c) {
 350                 # Print out the method desc
 351                 print CFILE "struct kobjop_desc $mname\_desc = {\n";
 352                 print CFILE "\t0, (kobjop_t) $default\n";
 353                 print CFILE "};\n\n";
 354             }
 355
 356             if ($opt_h) {
 357                 # Print out the method itself
 358                 if (0) {                 # haven't chosen the format yet
 359                     print HFILE "static __inline $ret $umname($varnames)\n";
 360                     print HFILE "\t".join(";\n\t", @arguments).";\n";
 361                 } else {
 362                     my $prototype = "static __inline $ret $umname(";
 363                     print HFILE &format_line("$prototype$arguments)",
 364                                              $line_width, ', ',
 365                                              ',', ' ' x length($prototype)) . "\n";
 366                 }
 367                 print HFILE "{\n";
 368                 print HFILE "\tkobjop_t _m;\n";
 369                 if ($static) {
 370                     print HFILE "\tKOBJOPLOOKUP($firstvar->ops,$mname);\n";
 371                 } else {
 372                     print HFILE "\tKOBJOPLOOKUP(((kobj_t)$firstvar)->ops,$mname);\n";
 373                 }
 374                 print HFILE "\t";
 375                 if ($ret ne 'void') {
 376                     print HFILE "return ";
 377                 }
 378                 print HFILE "(($mname\_t *) _m)($varnames);\n";
 379                 print HFILE "}\n\n";
 380             }
 381         } else {
 382             warn $line
 383                 if $opt_d;
 384             warn "$src:$lineno: Invalid line encountered";
 385             $error = 1;
 386             last LINE;
 387         }
 388     } # end LINE
 389
 390     # print the final '#endif' in the header file
 391     #
 392     print HFILE "#endif /* _".$intname."_if_h_ */\n"
 393         if $opt_h;
 394
 395     close SRC;
 396     close CFILE
 397         if $opt_c;
 398     close HFILE
 399         if $opt_h;
 400
 401     my $rc;
 402     if (!$error) {
 403         if ($opt_c) {
 404             ($rc = system("mv $ctmpname $cfilename"))
 405                 and warn "mv $ctmpname $cfilename failed, $rc";
 406         }
 407
 408         if ($opt_h) {
 409             ($rc = system("mv $htmpname $hfilename"))
 410                 and warn "mv $htmpname $hfilename failed, $rc";
 411         }
 412     } else {
 413         warn 'Output skipped';
 414         ($rc = system("rm -f $htmpname $ctmpname"))
 415             and warn "rm -f $htmpname $ctmpname failed, $rc";
 416         $gerror = 1;
 417     }
 418 }
 419
 420 exit $gerror;
 421
 422
 423 sub usage {
 424     die join("\n", @_,
 425         "usage: $0 [-d] [-p] [-l <nr>] [-c|-h] srcfile",
 426         "where -c   produce only .c files",
 427         "      -h   produce only .h files",
 428         "      -p   use the path component in the source file for destination dir",
 429         "      -l   set line width for output files [80]",
 430         "      -d   switch on debugging")
 431         . "\n";
 432 }
 433
 434 sub format_line {
 435     my ($line, $maxlength, $break, $new_end, $new_start) = @_;
 436     my $rline = "";
 437     my $i;
 438
 439     while (length($line) > $maxlength
 440             and ($i = rindex $line, $break, $maxlength-length($new_end)) != -1) {
 441         $rline .= substr($line, 0, $i) . $new_end . "\n";
 442         $line = $new_start . substr($line, $i+length($break));
 443     }
 444
 445     return $rline . $line;
 446 }
 447
 448 # This routine is a crude replacement for one in File::Basename. We
 449 # cannot use any library code because it fouls up the Perl bootstrap
 450 # when we update a perl version. MarkM
 451
 452 sub fileparse {
 453     my ($filename, @suffix) = @_;
 454     my ($dir, $name, $type, $i);
 455
 456     $type = '';
 457     foreach $i (@suffix) {
 458         if ($filename =~ m|$i$|) {
 459             $filename =~ s|$i$||;
 460             $type = $i;
 461         }
 462     }
 463     if ($filename =~ m|/|) {
 464         $filename =~ m|([^/]*)$|;
 465         $name = $1;
 466         $dir = $filename;
 467         $dir =~ s|$name$||;
 468     } else {
 469         $dir = '';
 470         $name = $filename;
 471     }
 472     ($name, $dir, $type);
 473 }