gcc/ada/gnathtml.pl

   1 #! /usr/bin/env perl
   2
   3 #-----------------------------------------------------------------------------
   4 #-                                                                          --
   5 #-                         GNAT COMPILER COMPONENTS                         --
   6 #-                                                                          --
   7 #-                             G N A T H T M L                              --
   8 #-                                                                          --
   9 #-          Copyright (C) 1998-2009, Free Software Foundation, Inc.         --
  10 #-                                                                          --
  11 #- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 #- terms of the  GNU General Public License as published  by the Free Soft- --
  13 #- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 #- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 #- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 #- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 #- for  more details.  You should have  received  a copy of the GNU General --
  18 #- Public License  distributed  with GNAT;  see file  COPYING3.  If not see --
  19 #- <http://www.gnu.org/licenses/>.                                          --
  20 #-                                                                          --
  21 #- GNAT was originally developed  by the GNAT team at  New York University. --
  22 #- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 #-                                                                          --
  24 #-----------------------------------------------------------------------------
  25
  26 ## This script converts an Ada file (and its dependency files) to Html.
  27 ## Keywords, comments and strings are color-hilighted. If the cross-referencing
  28 ## information provided by Gnat (when not using the -gnatx switch) is found,
  29 ## the html files will also have some cross-referencing features, i.e. if you
  30 ## click on a type, its declaration will be displayed.
  31 ##
  32 ## To find more about the switches provided by this script, please use the
  33 ## following command :
  34 ##     perl gnathtml.pl -h
  35 ## You may also change the first line of this script to indicates where Perl is
  36 ## installed on your machine, so that you can just type
  37 ##     gnathtml.pl -h
  38 ##
  39 ## Unless you supply another directory with the -odir switch, the html files
  40 ## will be saved saved in a html subdirectory
  41
  42 use Cwd 'abs_path';
  43 use File::Basename;
  44
  45 ### Print help if necessary
  46 sub print_usage
  47 {
  48   print "Usage is:\n";
  49   print "  $0 [switches] main_file[.adb] main_file2[.adb] ...\n";
  50   print "     -83       : Use Ada83 keywords only (default is Ada95)\n";
  51   print "     -cc color : Choose the color for comments\n";
  52   print "     -d        : Convert also the files which main_file depends on\n";
  53   print "     -D        : same as -d, also looks for files in the standard library\n";
  54   print "     -f        : Include cross-references for local entities too\n";
  55   print "     -absolute : Display absolute filenames in the headers\n";
  56   print "     -h        : Print this help page\n";
  57   print "     -lnb      : Display line numbers every nb lines\n";
  58   print "     -Idir     : Specify library/object files search path\n";
  59   print "     -odir     : Name of the directory where the html files will be\n";
  60   print "                 saved. Default is 'html/'\n";
  61   print "     -pfile    : Use file as a project file (.adp file)\n";
  62   print "     -sc color : Choose the color for symbol definitions\n";
  63   print "     -Tfile    : Read the name of the files from file rather than the\n";
  64   print "                 command line\n";
  65   print "     -ext ext  : Choose the generated file names extension (default\n";
  66   print "                 is htm)\n";
  67   print "This program attempts to generate an html file from an Ada file\n";
  68   exit;
  69 }
  70
  71 ### Parse the command line
  72 local ($ada83_mode)    = 0;
  73 local ($prjfile)       = "";
  74 local (@list_files)    = ();
  75 local ($line_numbers)  = 0;
  76 local ($dependencies)  = 0;
  77 local ($standard_library) = 0;
  78 local ($output_dir)    = "html";
  79 local ($xref_variable) = 0;
  80 local (@search_dir)    = ('.');
  81 local ($tab_size)      = 8;
  82 local ($comment_color) = "green";
  83 local ($symbol_color)  = "red";
  84 local ($absolute)      = 0;
  85 local ($fileext)       = "htm";
  86
  87 while ($_ = shift @ARGV)
  88 {
  89   /^-83$/  &&   do { $ada83_mode = 1; };
  90   /^-d$/   &&   do { $dependencies = 1; };
  91   /^-D$/   &&   do { $dependencies = 1;
  92                      $standard_library = 1; };
  93   /^-f$/   &&   do { $xref_variable = 1; };
  94   /^-absolute$/ && do {$absolute = 1; };
  95   /^-h$/   &&   do { &print_usage; };
  96   /^[^-]/  &&   do { $_ .= ".adb" if (! /\.ad[bs]$/);
  97                      push (@list_files, $_); };
  98
  99   if (/^-o\s*(.*)$/)
 100   {
 101     $output_dir = ($1 eq "") ? shift @ARGV : $1;
 102     chop $output_dir if ($output_dir =~ /\/$/);
 103     &print_usage if ($output_dir =~ /^-/ || $output_dir eq "");
 104   }
 105
 106   if (/^-T\s*(.*)$/)
 107   {
 108       my ($source_file) = ($1 eq "") ? shift @ARGV : $1;
 109       local (*SOURCE);
 110       open (SOURCE, "$source_file") || die "file not found: $source_file";
 111       while (<SOURCE>) {
 112           @files = split;
 113           foreach (@files) {
 114               $_ .= ".adb" if (! /\.ad[bs]$/);
 115               push (@list_files, $_);
 116           }
 117       }
 118   }
 119
 120   if (/^-cc\s*(.*)$/)
 121   {
 122       $comment_color = ($1 eq "") ? shift @ARGV : $1;
 123       &print_usage if ($comment_color =~ /^-/ || $comment_color eq "");
 124   }
 125
 126   if (/^-sc\s*(.*)$/)
 127   {
 128       $symbol_color = ($1 eq "") ? shift @ARGV : $1;
 129       &print_usage if ($symbol_color =~ /^-/ || $symbol_color eq "");
 130   }
 131
 132   if (/^-I\s*(.*)$/)
 133   {
 134     push (@search_dir, ($1 eq "") ? scalar (shift @ARGV) : $1);
 135   }
 136
 137   if (/^-p\s*(.*)$/)
 138   {
 139     $prjfile = ($1 eq "") ? shift @ARGV : $1;
 140     &print_usage if ($prjfile =~ /^-/ || $prjfile eq "");
 141   }
 142
 143   if (/^-l\s*(.*)$/)
 144   {
 145     $line_numbers = ($1 eq "") ? shift @ARGV : $1;
 146     &print_usage if ($line_numbers =~ /^-/ || $line_numbers eq "");
 147   }
 148
 149   if (/^-ext\s*(.*)$/)
 150   {
 151     $fileext = ($1 eq "") ? shift @ARGV : $1;
 152     &print_usage if ($fileext =~ /^-/ || $fileext eq "");
 153   }
 154 }
 155
 156 &print_usage if ($#list_files == -1);
 157 local (@original_list) = @list_files;
 158
 159 ## This regexp should match all the files from the standard library (and only them)
 160 ## Note that at this stage the '.' in the file names has been replaced with __
 161 $standard_file_regexp="^([agis]-|ada__|gnat__|system__|interface__).*\$";
 162
 163 local (@src_dir) = ();
 164 local (@obj_dir) = ();
 165
 166 if ($standard_library) {
 167     open (PIPE, "gnatls -v | ");
 168     local ($mode) = "";
 169     while (defined ($_ = <PIPE>)) {
 170         chop;
 171         s/^\s+//;
 172         $_ = './' if (/<Current_Directory>/);
 173         next if (/^$/);
 174
 175         if (/Source Search Path:/) {
 176             $mode = 's';
 177         }
 178         elsif (/Object Search Path:/) {
 179             $mode = 'o';
 180         }
 181         elsif ($mode eq 's') {
 182             push (@src_dir, $_);
 183         }
 184         elsif ($mode eq 'o') {
 185             push (@obj_dir, $_);
 186         }
 187     }
 188     close (PIPE);
 189 }
 190 else
 191 {
 192     push (@src_dir, "./");
 193     push (@obj_dir, "./");
 194 }
 195
 196 foreach (@list_files) {
 197   local ($dir) = $_;
 198   $dir =~ s/\/([^\/]+)$//;
 199   push (@src_dir, $dir. '/');
 200   push (@obj_dir, $dir. '/');
 201 }
 202
 203 ### Defines and compiles the Ada key words :
 204 local (@Ada_keywords) = ('abort', 'abs', 'accept', 'access', 'all', 'and',
 205                          'array', 'at', 'begin', 'body', 'case', 'constant',
 206                          'declare', 'delay', 'delta', 'digits', 'do', 'else',
 207                          'elsif', 'end', 'entry', 'exception', 'exit', 'for',
 208                          'function', 'generic', 'goto', 'if', 'in', 'is',
 209                          'limited', 'loop', 'mod', 'new', 'not', 'null', 'of',
 210                          'or', 'others', 'out', 'package', 'pragma', 'private',
 211                          'procedure', 'raise', 'range', 'record', 'rem',
 212                          'renames', 'return', 'reverse', 'select', 'separate',
 213                          'subtype', 'task', 'terminate', 'then', 'type',
 214                          'until', 'use', 'when', 'while', 'with', 'xor');
 215 local (@Ada95_keywords) = ('abstract', 'aliased', 'protected', 'requeue',
 216                         'tagged');
 217
 218 local (%keywords) = ();
 219 grep (++ $keywords{$_}, @Ada_keywords);
 220 grep (++ $keywords{$_}, @Ada95_keywords) unless ($ada83_mode);
 221
 222 ### Symbols declarations for the current file
 223 ### format is   (line_column => 1, ...)
 224 local (%symbols);
 225
 226 ### Symbols usage for the current file
 227 ### format is  ($adafile#$line_$column => $htmlfile#$linedecl_$columndecl, ...)
 228 local (%symbols_used);
 229
 230 ### the global index of all symbols
 231 ### format is  ($name => [[file, line, column], [file, line, column], ...])
 232 local (%global_index);
 233
 234 #########
 235 ##  This function create the header of every html file.
 236 ##  These header is returned as a string
 237 ##  Params:  - Name of the Ada file associated with this html file
 238 #########
 239 sub create_header
 240 {
 241   local ($adafile) = shift;
 242   local ($string) = "<HEAD><TITLE>$adafile</TITLE></HEAD>
 243 <BODY>\n";
 244
 245   if ($adafile ne "")
 246   {
 247     $string .= "<HR><DIV ALIGN=\"center\"><H1> File : $adafile "
 248         . "</H1></DIV><HR>\n<PRE>";
 249   }
 250   return $string;
 251 }
 252
 253 #########
 254 ##  Protect a string (or character) from the Html parser
 255 ##  Params: - the string to protect
 256 ##  Out:    - the protected string
 257 #########
 258 sub protect_string
 259 {
 260     local ($string) = shift;
 261     $string =~ s/&/&amp;/g;
 262     $string =~ s/</&lt;/g;
 263     $string =~ s/>/&gt;/g;
 264     return $string;
 265 }
 266
 267 #########
 268 ##  This function creates the footer of the html file
 269 ##  The footer is returned as a string
 270 ##  Params :  - Name of the Ada file associated with this html file
 271 #########
 272 sub create_footer
 273 {
 274   local ($adafile) = shift;
 275   local ($string) = "";
 276   $string = "</PRE>" if ($adafile ne "");
 277   return $string . "</BODY></HTML>\n";
 278 }
 279
 280 #########
 281 ##  This function creates the string to use for comment output
 282 ##  Params :  - the comment itself
 283 #########
 284 sub output_comment
 285 {
 286   local ($comment) = &protect_string (shift);
 287   return "<FONT COLOR=$comment_color><EM>--$comment</EM></FONT>";
 288 }
 289
 290 ########
 291 ##  This function creates the string to use for symbols output
 292 ##  Params :  - the symbol to output
 293 ##            - the current line
 294 ##            - the current column
 295 ########
 296 sub output_symbol
 297 {
 298   local ($symbol) = &protect_string (shift);
 299   local ($lineno) = shift;
 300   local ($column) = shift;
 301   return "<FONT COLOR=$symbol_color><A NAME=\"$lineno\_$column\">$symbol</A></FONT>";
 302 }
 303
 304 ########
 305 ##  This function creates the string to use for keyword output
 306 ##  Params :  - the keyword to output
 307 ########
 308 sub output_keyword
 309 {
 310   local ($keyw) = shift;
 311   return "<b>$keyw</b>";
 312 }
 313
 314 ########
 315 ##  This function outputs a line number
 316 ##  Params :  - the line number to generate
 317 ########
 318 sub output_line_number
 319 {
 320   local ($no) = shift;
 321   if ($no != -1)
 322   {
 323     return "<EM><FONT SIZE=-1>" . sprintf ("%4d ", $no) . "</FONT></EM>";
 324   }
 325   else
 326   {
 327     return "<FONT SIZE=-1>     </FONT>";
 328   }
 329 }
 330
 331 ########
 332 ##  Converts a character into the corresponding Ada type
 333 ##  This is based on the ali format (see lib-xref.adb) in the GNAT sources
 334 ##  Note: 'f' or 'K' should be returned in case a link from the body to the
 335 ##        spec needs to be generated.
 336 ##  Params : - the character to convert
 337 ########
 338 sub to_type
 339 {
 340   local ($char) = shift;
 341   $char =~ tr/a-z/A-Z/;
 342
 343   return 'array'                              if ($char eq 'A');
 344   return 'boolean'                            if ($char eq 'B');
 345   return 'class'                              if ($char eq 'C');
 346   return 'decimal'                            if ($char eq 'D');
 347   return 'enumeration'                        if ($char eq 'E');
 348   return 'floating point'                     if ($char eq 'F');
 349   return 'signed integer'                     if ($char eq 'I');
 350   # return 'generic package'                    if ($char eq 'K');
 351   return 'block'                              if ($char eq 'L');
 352   return 'modular integer'                    if ($char eq 'M');
 353   return 'enumeration literal'                if ($char eq 'N');
 354   return 'ordinary fixed point'               if ($char eq 'O');
 355   return 'access'                             if ($char eq 'P');
 356   return 'label'                              if ($char eq 'Q');
 357   return 'record'                             if ($char eq 'R');
 358   return 'string'                             if ($char eq 'S');
 359   return 'task'                               if ($char eq 'T');
 360   return 'f'                                  if ($char eq 'U');
 361   return 'f'                                  if ($char eq 'V');
 362   return 'exception'                          if ($char eq 'X');
 363   return 'entry'                              if ($char eq 'Y');
 364   return "$char";
 365 }
 366
 367 ########
 368 ##  Changes a file name to be http compatible
 369 ########
 370 sub http_string
 371 {
 372   local ($str) = shift;
 373   $str =~ s/\//__/g;
 374   $str =~ s/\\/__/g;
 375   $str =~ s/:/__/g;
 376   $str =~ s/\./__/g;
 377   return $str;
 378 }
 379
 380 ########
 381 ##  Creates the complete file-name, with directory
 382 ##  use the variables read in the .prj file
 383 ##  Params : - file name
 384 ##  RETURNS : the relative path_name to the file
 385 ########
 386 sub get_real_file_name
 387 {
 388   local ($filename) = shift;
 389   local ($path) = $filename;
 390
 391   foreach (@src_dir)
 392   {
 393       if ( -r "$_$filename")
 394       {
 395           $path = "$_$filename";
 396           last;
 397       }
 398   }
 399
 400   $path =~ s/^\.\///;
 401   return $path if (substr ($path, 0, 1) ne '/');
 402
 403   ## We want to return relative paths only, so that the name of the HTML files
 404   ## can easily be generated
 405   local ($pwd) = `pwd`;
 406   chop ($pwd);
 407   local (@pwd) = split (/\//, $pwd);
 408   local (@path) = split (/\//, $path);
 409
 410   while (@pwd)
 411   {
 412     if ($pwd [0] ne $path [0])
 413     {
 414       return '../' x ($#pwd + 1) . join ("/", @path);
 415     }
 416     shift @pwd;
 417     shift @path;
 418   }
 419   return join ('/', @path);
 420 }
 421
 422 ########
 423 ##  Reads and parses .adp files
 424 ##  Params : - adp file name
 425 ########
 426 sub parse_prj_file
 427 {
 428   local ($filename) = shift;
 429   local (@src) = ();
 430   local (@obj) = ();
 431
 432   print "Parsing project file : $filename\n";
 433
 434   open (PRJ, $filename) || do { print " ... sorry, file not found\n";
 435                                 return;
 436                               };
 437   while (<PRJ>)
 438   {
 439     chop;
 440     s/\/$//;
 441     push (@src, $1 . "/") if (/^src_dir=(.*)/);
 442     push (@obj, $1 . "/") if (/^obj_dir=(.*)/);
 443   }
 444   unshift (@src_dir, @src);
 445   unshift (@obj_dir, @obj);
 446   close (PRJ);
 447 }
 448
 449 ########
 450 ##  Finds a file in the search path
 451 ##  Params  : - the name of the file
 452 ##  RETURNS : - the directory/file_name
 453 ########
 454 sub find_file
 455 {
 456   local ($filename) = shift;
 457
 458   foreach (@search_dir) {
 459     if (-f "$_/$filename") {
 460       return "$_/$filename";
 461     }
 462   }
 463   return $filename;
 464 }
 465
 466 ########
 467 ##  Inserts a new reference in the list of references
 468 ##  Params: - Ref as it appears in the .ali file ($line$type$column)
 469 ##          - Current file for the reference
 470 ##          - Current offset to be added from the line (handling of
 471 ##            pragma Source_Reference)
 472 ##          - Current entity reference
 473 ##  Modifies: - %symbols_used
 474 ########
 475 sub create_new_reference
 476 {
 477     local ($ref) = shift;
 478     local ($lastfile) = shift;
 479     local ($offset) = shift;
 480     local ($currentref) = shift;
 481     local ($refline, $type, $refcol);
 482
 483     ## Do not generate references to the standard library files if we
 484     ## do not generate the corresponding html files
 485     return if (! $standard_library && $lastfile =~ /$standard_file_regexp/);
 486
 487     ($refline, $type, $extern, $refcol) = /(\d+)(.)(<[^>]+>)?(\d+)/;
 488     $refline += $offset;
 489
 490     ## If we have a body, then we only generate the cross-reference from
 491     ## the spec to the body if we have a subprogram (or a package)
 492
 493
 494     if ($type eq "b")
 495 #       && ($symbols {$currentref} eq 'f' || $symbols {$currentref} eq 'K'))
 496     {
 497         local ($cref_file, $cref) = ($currentref =~ /([^\#]+).$fileext\#(.+)/);
 498
 499         $symbols_used {"$cref_file#$cref"} = "$lastfile.$fileext#$refline\_$refcol";
 500         $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref;
 501         $symbols {"$lastfile.$fileext#$refline\_$refcol"} = "body";
 502     }
 503
 504     ## Do not generate cross-references for "e" and "t", since these point to the
 505     ## semicolon that terminates the block -- irrelevant for gnathtml
 506     ## "p" is also removed, since it is used for primitive subprograms
 507     ## "d" is also removed, since it is used for discriminants
 508     ## "i" is removed since it is used for implicit references
 509     ## "z" is used for generic formals
 510     ## "k" is for references to parent package
 511     ## "=", "<", ">", "^" is for subprogram parameters
 512
 513     elsif ($type !~ /[eztpid=<>^k]/)
 514     {
 515         $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref;
 516     }
 517 }
 518
 519 ########
 520 ##  Parses the ali file associated with the current Ada file
 521 ##  Params :  - the complete ali file name
 522 ########
 523 sub parse_ali
 524 {
 525   local ($filename) = shift;
 526   local ($currentfile);
 527   local ($currentref);
 528   local ($lastfile);
 529
 530   # A    file | line type column      reference
 531   local ($reference) = "(?:(?:\\d+\\|)?\\d+.\\d+|\\w+)";
 532
 533   # The following variable is used to represent the possible xref information
 534   # output by GNAT when -gnatdM is used. It includes renaming references, and
 535   # references to the parent type, as well as references to the generic parent
 536
 537   local ($typeref) = "(?:=$reference|<$reference>|\\{$reference\\}|\\($reference\\)|\\[$reference\\])?";
 538
 539   # The beginning of an entity declaration line in the ALI file
 540   local ($decl_line) = "^(\\d+)(.)(\\d+)[ *]([\\w\\d.-]+|\"..?\")$typeref\\s+(\\S.*)?\$";
 541
 542   # Contains entries of the form  [ filename source_reference_offset]
 543   # Offset needs to be added to the lines read in the cross-references, and are
 544   # used when the source comes from a gnatchop-ed file. See lib-write.ads, lines
 545   # with ^D in the ALI file.
 546   local (@reffiles) = ();
 547
 548   open (ALI, &find_file ($filename)) || do {
 549     print "no ", &find_file ($filename), " file...\n";
 550     return;
 551   };
 552   local (@ali) = <ALI>;
 553   close (ALI);
 554
 555   undef %symbols;
 556   undef %symbols_used;
 557
 558   foreach (@ali)
 559   {
 560     ## The format of D lines is
 561     ## D source-name time-stamp checksum [subunit-name] line:file-name
 562
 563     if (/^D\s+([\w\d.-]+)\s+\S+ \S+(\s+\D[^: ]+)?( (\d+):(.*))?/)
 564     {
 565         # The offset will be added to each cross-reference line. If it is
 566         # greater than 1, this means that we have a pragma Source_Reference,
 567         # and this must not be counted in the xref information.
 568         my ($file, $offset) = ($1, (defined $4) ? 2 - $4 : 0);
 569
 570         if ($dependencies)
 571         {
 572             push (@list_files, $1) unless (grep (/$file/, @list_files));
 573         }
 574         push (@reffiles, [&http_string (&get_real_file_name ($file)), $offset]);
 575     }
 576
 577     elsif (/^X\s+(\d+)/)
 578     {
 579         $currentfile = $lastfile = $1 - 1;
 580     }
 581
 582     elsif (defined $currentfile && /$decl_line/)
 583     {
 584       my ($line) = $1 + $reffiles[$currentfile][1];
 585       next if (! $standard_library
 586                && $reffiles[$currentfile][0] =~ /$standard_file_regexp/);
 587       if ($xref_variable || $2 eq &uppercases ($2))
 588       {
 589         $currentref = $reffiles[$currentfile][0] . ".$fileext#$line\_$3";
 590         $symbols {$currentref} = &to_type ($2);
 591         $lastfile = $currentfile;
 592
 593         local ($endofline) = $5;
 594
 595         foreach (split (" ", $endofline))
 596         {
 597             (s/^(\d+)\|//) && do { $lastfile = $1 - 1; };
 598             &create_new_reference
 599                 ($_, $reffiles[$lastfile][0],
 600                  $reffiles[$lastfile][1], $currentref);
 601         }
 602       }
 603       else
 604       {
 605         $currentref = "";
 606       }
 607     }
 608     elsif (/^\.\s(.*)/ && $reffiles[$currentfile][0] ne "" && $currentref ne "")
 609     {
 610       next if (! $standard_library
 611                && $reffiles[$currentfile][0] =~ /$standard_file_regexp/);
 612       foreach (split (" ", $1))
 613       {
 614           (s/^(\d+)\|//) && do { $lastfile = $1 - 1; };
 615           &create_new_reference
 616               ($_, $reffiles[$lastfile][0], $reffiles[$lastfile][1],
 617                $currentref);
 618       }
 619     }
 620   }
 621 }
 622
 623 #########
 624 ##  Return the name of the ALI file to use for a given source
 625 ##  Params:  - Name of the source file
 626 ##  return:  Name and location of the ALI file
 627 #########
 628
 629 sub ali_file_name {
 630     local ($source) = shift;
 631     local ($alifilename, $unitname);
 632     local ($in_separate) = 0;
 633
 634     $source =~ s/\.ad[sb]$//;
 635     $alifilename = $source;
 636     $unitname = $alifilename;
 637     $unitname =~ s/-/./g;
 638
 639     ## There are two reasons why we might not find the ALI file: either the
 640     ## user did not generate them at all, or we are working on a separate unit.
 641     ## Thus, we search in the parent's ALI file.
 642
 643     while ($alifilename ne "") {
 644
 645       ## Search in the object path
 646       foreach (@obj_dir) {
 647
 648         ## Check if the ALI file does apply to the source file
 649         ## We check the ^D lines, which have the following format:
 650         ## D source-name time-stamp checksum [subunit-name] line:file-name
 651
 652         if (-r "$_$alifilename.ali") {
 653           if ($in_separate) {
 654             open (FILE, "$_$alifilename.ali");
 655
 656             if (grep (/^D \S+\s+\S+\s+\S+ $unitname/, <FILE>)) {
 657               close FILE;
 658               return "$_$alifilename.ali";
 659
 660             } else {
 661               ## If the ALI file doesn't apply to the source file, we can
 662               ## return now, since there won't be a parent ALI file above
 663               ## anyway
 664               close FILE;
 665               return "$source.ali";
 666             }
 667           } else {
 668             return "$_$alifilename.ali";
 669           }
 670         }
 671       }
 672
 673       ## Get the parent's ALI file name
 674
 675       if (! ($alifilename =~ s/-[^-]+$//)) {
 676         $alifilename = "";
 677       }
 678       $in_separate = 1;
 679     }
 680
 681     return "$source.ali";
 682 }
 683
 684 #########
 685 ## Convert a path to an absolute path
 686 #########
 687
 688 sub to_absolute
 689 {
 690   local ($path) = shift;
 691   local ($name, $suffix, $separator);
 692   ($name,$path,$suffix) = fileparse ($path, ());
 693   $path = &abs_path ($path);
 694   $separator = substr ($path, 0, 1);
 695   return $path . $separator . $name;
 696 }
 697
 698 #########
 699 ##  This function outputs the html version of the file FILE
 700 ##  The output is send to FILE.htm.
 701 ##  Params :  - Name of the file to convert (ends with .ads or .adb)
 702 #########
 703 sub output_file
 704 {
 705   local ($filename_param) = shift;
 706   local ($lineno)   = 1;
 707   local ($column);
 708   local ($found);
 709
 710   local ($alifilename) = &ali_file_name ($filename_param);
 711
 712   $filename = &get_real_file_name ($filename_param);
 713   $found = &find_file ($filename);
 714
 715   ## Read the whole file
 716   open (FILE, $found) || do {
 717     print $found, " not found ... skipping.\n";
 718     return 0;
 719   };
 720   local (@file) = <FILE>;
 721   close (FILE);
 722
 723   ## Parse the .ali file to find the cross-references
 724   print "converting ", $filename, "\n";
 725   &parse_ali ($alifilename);
 726
 727   ## Create and initialize the html file
 728   open (OUTPUT, ">$output_dir/" . &http_string ($filename) . ".$fileext")
 729       || die "Couldn't write $output_dir/" . &http_string ($filename)
 730           . ".$fileext\n";
 731
 732   if ($absolute) {
 733      print OUTPUT &create_header (&to_absolute ($found)), "\n";
 734   } else {
 735      print OUTPUT &create_header ($filename_param), "\n";
 736   }
 737
 738   ## Print the file
 739   $filename = &http_string ($filename);
 740   foreach (@file)
 741   {
 742       local ($index);
 743       local ($line) = $_;
 744       local ($comment);
 745
 746       $column = 1;
 747       chop ($line);
 748
 749       ## Print either the line number or a space if required
 750       if ($line_numbers)
 751       {
 752           if ($lineno % $line_numbers == 0)
 753           {
 754               print OUTPUT &output_line_number ($lineno);
 755           }
 756           else
 757           {
 758               print OUTPUT &output_line_number (-1);
 759           }
 760       }
 761
 762       ## First, isolate any comment on the line
 763       undef $comment;
 764       $index = index ($line, '--');
 765       if ($index != -1) {
 766           $comment = substr ($line, $index + 2);
 767           if ($index > 1)
 768           {
 769               $line = substr ($line, 0, $index);
 770           }
 771           else
 772           {
 773               undef $line;
 774           }
 775       }
 776
 777       ## Then print the line
 778       if (defined $line)
 779       {
 780           $index = 0;
 781           while ($index < length ($line))
 782           {
 783               local ($substring) = substr ($line, $index);
 784
 785               if ($substring =~ /^\t/)
 786               {
 787                   print OUTPUT ' ' x ($tab_size - (($column - 1) % $tab_size));
 788                   $column += $tab_size - (($column - 1) % $tab_size);
 789                   $index ++;
 790               }
 791               elsif ($substring =~ /^(\w+)/
 792                      || $substring =~ /^("[^\"]*")/
 793                      || $substring =~ /^(\W)/)
 794               {
 795                   local ($word) = $1;
 796                   $index += length ($word);
 797
 798                   local ($lowercase) = $word;
 799                   $lowercase =~ tr/A-Z/a-z/;
 800
 801                   if ($keywords{$lowercase})
 802                   {
 803                       print OUTPUT &output_keyword ($word);
 804                   }
 805                   elsif ($symbols {"$filename.$fileext#$lineno\_$column"})
 806                   {
 807                       ##  A symbol can both have a link and be a reference for
 808                       ##  another link, as is the case for bodies and
 809                       ##  declarations
 810
 811                       if ($symbols_used{"$filename#$lineno\_$column"})
 812                       {
 813                           print OUTPUT "<A HREF=\"",
 814                           $symbols_used{"$filename#$lineno\_$column"},
 815                           "\">", &protect_string ($word), "</A>";
 816                           print OUTPUT &output_symbol ('', $lineno, $column);
 817                       }
 818                       else
 819                       {
 820                           print OUTPUT &output_symbol ($word, $lineno, $column);
 821                       }
 822
 823                       ## insert only functions into the global index
 824
 825                       if ($symbols {"$filename.$fileext#$lineno\_$column"} eq 'f')
 826                       {
 827                           push (@{$global_index {$word}},
 828                                 [$filename_param, $filename, $lineno, $column]);
 829                       }
 830                   }
 831                   elsif ($symbols_used{"$filename#$lineno\_$column"})
 832                   {
 833                       print OUTPUT "<A HREF=\"",
 834                       $symbols_used{"$filename#$lineno\_$column"},
 835                       "\">", &protect_string ($word), "</A>";
 836                   }
 837                   else
 838                   {
 839                       print OUTPUT &protect_string ($word);
 840                   }
 841                   $column += length ($word);
 842               }
 843               else
 844               {
 845                   $index ++;
 846                   $column ++;
 847                   print OUTPUT &protect_string (substr ($substring, 0, 1));
 848               }
 849           }
 850       }
 851
 852       ## Then output the comment
 853       print OUTPUT &output_comment ($comment) if (defined $comment);
 854       print OUTPUT "\n";
 855
 856       $lineno ++;
 857   }
 858
 859   print OUTPUT &create_footer ($filename);
 860   close (OUTPUT);
 861   return 1;
 862 }
 863
 864 #########
 865 ##  This function generates the global index
 866 #########
 867 sub create_index_file
 868 {
 869   open (INDEX, ">$output_dir/index.$fileext") || die "couldn't write $output_dir/index.$fileext";
 870
 871   print INDEX <<"EOF";
 872 <HTML>
 873 <HEAD><TITLE>Source Browser</TITLE></HEAD>
 874 <FRAMESET COLS='250,*'>
 875 <NOFRAME>
 876 EOF
 877   ;
 878
 879   local (@files) = &create_file_index;
 880   print INDEX join ("\n", @files), "\n";
 881
 882   print INDEX "<HR>\n";
 883   local (@functions) = &create_function_index;
 884   print INDEX join ("\n", @functions), "\n";
 885
 886   print INDEX <<"EOF";
 887 </NOFRAME>
 888 <FRAMESET ROWS='50%,50%'>
 889 <FRAME NAME=files SRC=files.$fileext>
 890 <FRAME NAME=funcs SRC=funcs.$fileext>
 891 </FRAMESET>
 892 <FRAME NAME=main SRC=main.$fileext>
 893 </FRAMESET>
 894 </HTML>
 895 EOF
 896   ;
 897   close (INDEX);
 898
 899   open (MAIN, ">$output_dir/main.$fileext") || die "couldn't write $output_dir/main.$fileext";
 900   print MAIN &create_header (""),
 901   "<P ALIGN=right>",
 902   "<A HREF=main.$fileext TARGET=_top>[No frame version is here]</A>",
 903   "<P>",
 904   join ("\n", @files), "\n<HR>",
 905   join ("\n", @functions), "\n";
 906
 907   if ($dependencies) {
 908       print MAIN "<HR>\n";
 909       print MAIN "You should start your browsing with one of these files:\n";
 910       print MAIN "<UL>\n";
 911       foreach (@original_list) {
 912           print MAIN "<LI><A HREF=", &http_string (&get_real_file_name ($_)),
 913              ".$fileext>$_</A>\n";
 914       }
 915   }
 916   print MAIN &create_footer ("");
 917   close (MAIN);
 918 }
 919
 920 #######
 921 ##  Convert to upper cases (did not exist in Perl 4)
 922 #######
 923
 924 sub uppercases {
 925   local ($tmp) = shift;
 926   $tmp =~ tr/a-z/A-Z/;
 927   return $tmp;
 928 }
 929
 930 #######
 931 ##  This function generates the file_index
 932 ##  RETURN : - table with the html lines to be printed
 933 #######
 934 sub create_file_index
 935 {
 936   local (@output) = ("<H2 ALIGN=CENTER>Files</H2>");
 937
 938
 939   open (FILES, ">$output_dir/files.$fileext") || die "couldn't write $output_dir/files.$fileext";
 940   print FILES &create_header (""), join ("\n", @output), "\n";
 941
 942
 943   if ($#list_files > 20)
 944   {
 945     local ($last_letter) = '';
 946     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files)
 947     {
 948       next if ($_ eq "");
 949       if (&uppercases (substr ($_, 0, 1)) ne $last_letter)
 950       {
 951         if ($last_letter ne '')
 952         {
 953           print INDEX_FILE "</UL></BODY></HTML>\n";
 954           close (INDEX_FILE);
 955         }
 956         $last_letter = &uppercases (substr ($_, 0, 1));
 957         open (INDEX_FILE, ">$output_dir/files/$last_letter.$fileext")
 958         || die "couldn't write $output_dir/files/$last_letter.$fileext";
 959         print INDEX_FILE <<"EOF";
 960 <HTML><HEAD><TITLE>$last_letter</TITLE></HEAD>
 961 <BODY>
 962 <H2>Files - $last_letter</H2>
 963 <A HREF=../files.$fileext TARGET=_self>[index]</A>
 964 <UL COMPACT TYPE=DISC>
 965 EOF
 966         ;
 967         local ($str) = "<A HREF=files/$last_letter.$fileext>[$last_letter]</A>";
 968         push (@output, $str);
 969         print FILES "$str\n";
 970       }
 971       print INDEX_FILE "<LI><A HREF=../",
 972       &http_string (&get_real_file_name ($_)),
 973       ".$fileext TARGET=main>$_</A>\n";   ## Problem with TARGET when in no_frame mode!
 974     }
 975
 976     print INDEX_FILE "</UL></BODY></HTML>\n";
 977     close INDEX_FILE;
 978   }
 979   else
 980   {
 981     push (@output, "<UL COMPACT TYPE=DISC>");
 982     print FILES "<UL COMPACT TYPE=DISC>";
 983     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files)
 984     {
 985       next if ($_ eq "");
 986       local ($ref) = &http_string (&get_real_file_name ($_));
 987       push (@output, "<LI><A HREF=$ref.$fileext>$_</A>");
 988       print FILES "<LI><A HREF=$ref.$fileext TARGET=main>$_</A>\n";
 989     }
 990   }
 991
 992   print FILES &create_footer ("");
 993   close (FILES);
 994
 995   push (@output, "</UL>");
 996   return @output;
 997 }
 998
 999 #######
1000 ##  This function generates the function_index
1001 ##  RETURN : - table with the html lines to be printed
1002 #######
1003 sub create_function_index
1004 {
1005   local (@output) = ("<H2 ALIGN=CENTER>Functions/Procedures</H2>");
1006   local ($initial) = "";
1007
1008   open (FUNCS, ">$output_dir/funcs.$fileext") || die "couldn't write $output_dir/funcs.$fileext";
1009   print FUNCS &create_header (""), join ("\n", @output), "\n";
1010
1011   ## If there are more than 20 entries, we just want to create some
1012   ## submenus
1013   if (scalar (keys %global_index) > 20)
1014   {
1015     local ($last_letter) = '';
1016     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index)
1017     {
1018       if (&uppercases (substr ($_, 0, 1)) ne $last_letter)
1019       {
1020         if ($last_letter ne '')
1021         {
1022           print INDEX_FILE "</UL></BODY></HTML>\n";
1023           close (INDEX_FILE);
1024         }
1025
1026         $last_letter = &uppercases (substr ($_, 0, 1));
1027         $initial = $last_letter;
1028         if ($initial eq '"')
1029         {
1030             $initial = "operators";
1031         }
1032         if ($initial ne '.')
1033         {
1034             open (INDEX_FILE, ">$output_dir/funcs/$initial.$fileext")
1035                 || die "couldn't write $output_dir/funcs/$initial.$fileext";
1036             print INDEX_FILE <<"EOF";
1037 <HTML><HEAD><TITLE>$initial</TITLE></HEAD>
1038 <BODY>
1039 <H2>Functions - $initial</H2>
1040 <A HREF=../funcs.$fileext TARGET=_self>[index]</A>
1041 <UL COMPACT TYPE=DISC>
1042 EOF
1043                                     ;
1044             local ($str) = "<A HREF=funcs/$initial.$fileext>[$initial]</A>";
1045             push (@output, $str);
1046             print FUNCS "$str\n";
1047         }
1048       }
1049       local ($ref);
1050       local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0);
1051       foreach $ref (@{$global_index {$_}})
1052       {
1053           ($file, $full_file, $lineno, $column) = @{$ref};
1054           local ($symbol) = ($is_overloaded ? "$_ -  $file:$lineno" : $_);
1055           print INDEX_FILE "<LI><A HREF=../$full_file.$fileext#$lineno\_$column TARGET=main>$symbol</A>";
1056       }
1057     }
1058
1059     print INDEX_FILE "</UL></BODY></HTML>\n";
1060     close INDEX_FILE;
1061   }
1062   else
1063   {
1064     push (@output, "<UL COMPACT TYPE=DISC>");
1065     print FUNCS "<UL COMPACT TYPE=DISC>";
1066     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index)
1067     {
1068       local ($ref);
1069       local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0);
1070       foreach $ref (@{$global_index {$_}})
1071       {
1072           ($file, $full_file, $lineno, $column) = @{$ref};
1073           local ($symbol) = ($is_overloaded ? "$_ -  $file:$lineno" : $_);
1074           push (@output, "<LI><A HREF=$full_file.$fileext#$lineno\_$column>$symbol</A>");
1075           print FUNCS "<LI><A HREF=$full_file.$fileext#$lineno\_$column TARGET=main>$symbol</A>";
1076       }
1077     }
1078   }
1079
1080   print FUNCS &create_footer ("");
1081   close (FUNCS);
1082
1083   push (@output, "</UL>");
1084   return (@output);
1085 }
1086
1087 ######
1088 ##  Main function
1089 ######
1090
1091 local ($index_file) = 0;
1092
1093 mkdir ($output_dir, 0755)          if (! -d $output_dir);
1094 mkdir ($output_dir."/files", 0755) if (! -d $output_dir."/files");
1095 mkdir ($output_dir."/funcs", 0755) if (! -d $output_dir."/funcs");
1096
1097 &parse_prj_file ($prjfile) if ($prjfile);
1098
1099 while ($index_file <= $#list_files)
1100 {
1101   local ($file) = $list_files [$index_file];
1102
1103   if (&output_file ($file) == 0)
1104     {
1105       $list_files [$index_file] = "";
1106     }
1107   $index_file ++;
1108 }
1109 &create_index_file;
1110
1111 $indexfile = "$output_dir/index.$fileext";
1112 $indexfile =~ s!//!/!g;
1113 print "You can now download the $indexfile file to see the ",
1114   "created pages\n";