Subversion Repositories openrisc_2011-10-31

#! /usr/bin/env perl

#-----------------------------------------------------------------------------

#-                                                                          --

#-                         GNAT COMPILER COMPONENTS                         --

#-                                                                          --

#-                             G N A T H T M L                              --

#-                                                                          --

#-          Copyright (C) 1998-2009, Free Software Foundation, Inc.         --

#-                                                                          --

#- GNAT is free software;  you can  redistribute it  and/or modify it under --

#- terms of the  GNU General Public License as published  by the Free Soft- --

#- ware  Foundation;  either version 3,  or (at your option) any later ver- --

#- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

#- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

#- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

#- for  more details.  You should have  received  a copy of the GNU General --

#- Public License  distributed  with GNAT;  see file  COPYING3.  If not see --

#- <http://www.gnu.org/licenses/>.                                          --

#-                                                                          --

#- GNAT was originally developed  by the GNAT team at  New York University. --

#- Extensive contributions were provided by Ada Core Technologies Inc.      --

#-                                                                          --

#-----------------------------------------------------------------------------

## This script converts an Ada file (and its dependency files) to Html.

## Keywords, comments and strings are color-hilighted. If the cross-referencing

## information provided by Gnat (when not using the -gnatx switch) is found,

## the html files will also have some cross-referencing features, i.e. if you

## click on a type, its declaration will be displayed.

##

## To find more about the switches provided by this script, please use the

## following command :

##     perl gnathtml.pl -h

## You may also change the first line of this script to indicates where Perl is

## installed on your machine, so that you can just type

##     gnathtml.pl -h

##

## Unless you supply another directory with the -odir switch, the html files

## will be saved saved in a html subdirectory

use Cwd 'abs_path';

use File::Basename;

### Print help if necessary

sub print_usage

{

  print "Usage is:\n";

  print "  $0 [switches] main_file[.adb] main_file2[.adb] ...\n";

  print "     -83       : Use Ada83 keywords only (default is Ada95)\n";

  print "     -cc color : Choose the color for comments\n";

  print "     -d        : Convert also the files which main_file depends on\n";

  print "     -D        : same as -d, also looks for files in the standard library\n";

  print "     -f        : Include cross-references for local entities too\n";

  print "     -absolute : Display absolute filenames in the headers\n";

  print "     -h        : Print this help page\n";

  print "     -lnb      : Display line numbers every nb lines\n";

  print "     -Idir     : Specify library/object files search path\n";

  print "     -odir     : Name of the directory where the html files will be\n";

  print "                 saved. Default is 'html/'\n";

  print "     -pfile    : Use file as a project file (.adp file)\n";

  print "     -sc color : Choose the color for symbol definitions\n";

  print "     -Tfile    : Read the name of the files from file rather than the\n";

  print "                 command line\n";

  print "     -ext ext  : Choose the generated file names extension (default\n";

  print "                 is htm)\n";

  print "This program attempts to generate an html file from an Ada file\n";

  exit;

}

### Parse the command line

local ($ada83_mode)    = 0;

local ($prjfile)       = "";

local (@list_files)    = ();

local ($line_numbers)  = 0;

local ($dependencies)  = 0;

local ($standard_library) = 0;

local ($output_dir)    = "html";

local ($xref_variable) = 0;

local (@search_dir)    = ('.');

local ($tab_size)      = 8;

local ($comment_color) = "green";

local ($symbol_color)  = "red";

local ($absolute)      = 0;

local ($fileext)       = "htm";

while ($_ = shift @ARGV)

{

  /^-83$/  &&   do { $ada83_mode = 1; };

  /^-d$/   &&   do { $dependencies = 1; };

  /^-D$/   &&   do { $dependencies = 1;

                     $standard_library = 1; };

  /^-f$/   &&   do { $xref_variable = 1; };

  /^-absolute$/ && do {$absolute = 1; };

  /^-h$/   &&   do { &print_usage; };

  /^[^-]/  &&   do { $_ .= ".adb" if (! /\.ad[bs]$/);

                     push (@list_files, $_); };

  if (/^-o\s*(.*)$/)

  {

    $output_dir = ($1 eq "") ? shift @ARGV : $1;

    chop $output_dir if ($output_dir =~ /\/$/);

    &print_usage if ($output_dir =~ /^-/ || $output_dir eq "");

  }

  if (/^-T\s*(.*)$/)

  {

      my ($source_file) = ($1 eq "") ? shift @ARGV : $1;

      local (*SOURCE);

      open (SOURCE, "$source_file") || die "file not found: $source_file";

      while (<SOURCE>) {

          @files = split;

          foreach (@files) {

              $_ .= ".adb" if (! /\.ad[bs]$/);

              push (@list_files, $_);

          }

      }

  }

  if (/^-cc\s*(.*)$/)

  {

      $comment_color = ($1 eq "") ? shift @ARGV : $1;

      &print_usage if ($comment_color =~ /^-/ || $comment_color eq "");

  }

  if (/^-sc\s*(.*)$/)

  {

      $symbol_color = ($1 eq "") ? shift @ARGV : $1;

      &print_usage if ($symbol_color =~ /^-/ || $symbol_color eq "");

  }

  if (/^-I\s*(.*)$/)

  {

    push (@search_dir, ($1 eq "") ? scalar (shift @ARGV) : $1);

  }

  if (/^-p\s*(.*)$/)

  {

    $prjfile = ($1 eq "") ? shift @ARGV : $1;

    &print_usage if ($prjfile =~ /^-/ || $prjfile eq "");

  }

  if (/^-l\s*(.*)$/)

  {

    $line_numbers = ($1 eq "") ? shift @ARGV : $1;

    &print_usage if ($line_numbers =~ /^-/ || $line_numbers eq "");

  }

  if (/^-ext\s*(.*)$/)

  {

    $fileext = ($1 eq "") ? shift @ARGV : $1;

    &print_usage if ($fileext =~ /^-/ || $fileext eq "");

  }

}

&print_usage if ($#list_files == -1);

local (@original_list) = @list_files;

## This regexp should match all the files from the standard library (and only them)

## Note that at this stage the '.' in the file names has been replaced with __

$standard_file_regexp="^([agis]-|ada__|gnat__|system__|interface__).*\$";

local (@src_dir) = ();

local (@obj_dir) = ();

if ($standard_library) {

    open (PIPE, "gnatls -v | ");

    local ($mode) = "";

    while (defined ($_ = <PIPE>)) {

        chop;

        s/^\s+//;

        $_ = './' if (/<Current_Directory>/);

        next if (/^$/);

        if (/Source Search Path:/) {

            $mode = 's';

        }

        elsif (/Object Search Path:/) {

            $mode = 'o';

        }

        elsif ($mode eq 's') {

            push (@src_dir, $_);

        }

        elsif ($mode eq 'o') {

            push (@obj_dir, $_);

        }

    }

    close (PIPE);

}

else

{

    push (@src_dir, "./");

    push (@obj_dir, "./");

}

foreach (@list_files) {

  local ($dir) = $_;

  $dir =~ s/\/([^\/]+)$//;

  push (@src_dir, $dir. '/');

  push (@obj_dir, $dir. '/');

}

### Defines and compiles the Ada key words :

local (@Ada_keywords) = ('abort', 'abs', 'accept', 'access', 'all', 'and',

                         'array', 'at', 'begin', 'body', 'case', 'constant',

                         'declare', 'delay', 'delta', 'digits', 'do', 'else',

                         'elsif', 'end', 'entry', 'exception', 'exit', 'for',

                         'function', 'generic', 'goto', 'if', 'in', 'is',

                         'limited', 'loop', 'mod', 'new', 'not', 'null', 'of',

                         'or', 'others', 'out', 'package', 'pragma', 'private',

                         'procedure', 'raise', 'range', 'record', 'rem',

                         'renames', 'return', 'reverse', 'select', 'separate',

                         'subtype', 'task', 'terminate', 'then', 'type',

                         'until', 'use', 'when', 'while', 'with', 'xor');

local (@Ada95_keywords) = ('abstract', 'aliased', 'protected', 'requeue',

                        'tagged');

local (%keywords) = ();

grep (++ $keywords{$_}, @Ada_keywords);

grep (++ $keywords{$_}, @Ada95_keywords) unless ($ada83_mode);

### Symbols declarations for the current file

### format is   (line_column => 1, ...)

local (%symbols);

### Symbols usage for the current file

### format is  ($adafile#$line_$column => $htmlfile#$linedecl_$columndecl, ...)

local (%symbols_used);

### the global index of all symbols

### format is  ($name => [[file, line, column], [file, line, column], ...])

local (%global_index);

#########

##  This function create the header of every html file.

##  These header is returned as a string

##  Params:  - Name of the Ada file associated with this html file

#########

sub create_header

{

  local ($adafile) = shift;

  local ($string) = "<HEAD><TITLE>$adafile</TITLE></HEAD>

<BODY>\n";

  if ($adafile ne "")

  {

    $string .= "<HR><DIV ALIGN=\"center\"><H1> File : $adafile "

        . "</H1></DIV><HR>\n<PRE>";

  }

  return $string;

}

#########

##  Protect a string (or character) from the Html parser

##  Params: - the string to protect

##  Out:    - the protected string

#########

sub protect_string

{

    local ($string) = shift;

    $string =~ s/&/&/g;

    $string =~ s/</&lt;/g;

    $string =~ s/>/>/g;

    return $string;

}

#########

##  This function creates the footer of the html file

##  The footer is returned as a string

##  Params :  - Name of the Ada file associated with this html file

#########

sub create_footer

{

  local ($adafile) = shift;

  local ($string) = "";

  $string = "</PRE>" if ($adafile ne "");

  return $string . "</BODY></HTML>\n";

}

#########

##  This function creates the string to use for comment output

##  Params :  - the comment itself

#########

sub output_comment

{

  local ($comment) = &protect_string (shift);

  return "<FONT COLOR=$comment_color><EM>--$comment</EM></FONT>";

}

########

##  This function creates the string to use for symbols output

##  Params :  - the symbol to output

##            - the current line

##            - the current column

########

sub output_symbol

{

  local ($symbol) = &protect_string (shift);

  local ($lineno) = shift;

  local ($column) = shift;

  return "<FONT COLOR=$symbol_color><A NAME=\"$lineno\_$column\">$symbol</A></FONT>";

}

########

##  This function creates the string to use for keyword output

##  Params :  - the keyword to output

########

sub output_keyword

{

  local ($keyw) = shift;

  return "<b>$keyw</b>";

}

########

##  This function outputs a line number

##  Params :  - the line number to generate

########

sub output_line_number

{

  local ($no) = shift;

  if ($no != -1)

  {

    return "<EM><FONT SIZE=-1>" . sprintf ("%4d ", $no) . "</FONT></EM>";

  }

  else

  {

    return "<FONT SIZE=-1>     </FONT>";

  }

}

########

##  Converts a character into the corresponding Ada type

##  This is based on the ali format (see lib-xref.adb) in the GNAT sources

##  Note: 'f' or 'K' should be returned in case a link from the body to the

##        spec needs to be generated.

##  Params : - the character to convert

########

sub to_type

{

  local ($char) = shift;

  $char =~ tr/a-z/A-Z/;

  return 'array'                              if ($char eq 'A');

  return 'boolean'                            if ($char eq 'B');

  return 'class'                              if ($char eq 'C');

  return 'decimal'                            if ($char eq 'D');

  return 'enumeration'                        if ($char eq 'E');

  return 'floating point'                     if ($char eq 'F');

  return 'signed integer'                     if ($char eq 'I');

  # return 'generic package'                    if ($char eq 'K');

  return 'block'                              if ($char eq 'L');

  return 'modular integer'                    if ($char eq 'M');

  return 'enumeration literal'                if ($char eq 'N');

  return 'ordinary fixed point'               if ($char eq 'O');

  return 'access'                             if ($char eq 'P');

  return 'label'                              if ($char eq 'Q');

  return 'record'                             if ($char eq 'R');

  return 'string'                             if ($char eq 'S');

  return 'task'                               if ($char eq 'T');

  return 'f'                                  if ($char eq 'U');

  return 'f'                                  if ($char eq 'V');

  return 'exception'                          if ($char eq 'X');

  return 'entry'                              if ($char eq 'Y');

  return "$char";

}

########

##  Changes a file name to be http compatible

########

sub http_string

{

  local ($str) = shift;

  $str =~ s/\//__/g;

  $str =~ s/\\/__/g;

  $str =~ s/:/__/g;

  $str =~ s/\./__/g;

  return $str;

}

########

##  Creates the complete file-name, with directory

##  use the variables read in the .prj file

##  Params : - file name

##  RETURNS : the relative path_name to the file

########

sub get_real_file_name

{

  local ($filename) = shift;

  local ($path) = $filename;

  foreach (@src_dir)

  {

      if ( -r "$_$filename")

      {

          $path = "$_$filename";

          last;

      }

  }

  $path =~ s/^\.\///;

  return $path if (substr ($path, 0, 1) ne '/');

  ## We want to return relative paths only, so that the name of the HTML files

  ## can easily be generated

  local ($pwd) = `pwd`;

  chop ($pwd);

  local (@pwd) = split (/\//, $pwd);

  local (@path) = split (/\//, $path);

  while (@pwd)

  {

    if ($pwd [0] ne $path [0])

    {

      return '../' x ($#pwd + 1) . join ("/", @path);

    }

    shift @pwd;

    shift @path;

  }

  return join ('/', @path);

}

########

##  Reads and parses .adp files

##  Params : - adp file name

########

sub parse_prj_file

{

  local ($filename) = shift;

  local (@src) = ();

  local (@obj) = ();

  print "Parsing project file : $filename\n";

  open (PRJ, $filename) || do { print " ... sorry, file not found\n";

                                return;

                              };

  while (<PRJ>)

  {

    chop;

    s/\/$//;

    push (@src, $1 . "/") if (/^src_dir=(.*)/);

    push (@obj, $1 . "/") if (/^obj_dir=(.*)/);

  }

  unshift (@src_dir, @src);

  unshift (@obj_dir, @obj);

  close (PRJ);

}

########

##  Finds a file in the search path

##  Params  : - the name of the file

##  RETURNS : - the directory/file_name

########

sub find_file

{

  local ($filename) = shift;

  foreach (@search_dir) {

    if (-f "$_/$filename") {

      return "$_/$filename";

    }

  }

  return $filename;

}

########

##  Inserts a new reference in the list of references

##  Params: - Ref as it appears in the .ali file ($line$type$column)

##          - Current file for the reference

##          - Current offset to be added from the line (handling of

##            pragma Source_Reference)

##          - Current entity reference

##  Modifies: - %symbols_used

########

sub create_new_reference

{

    local ($ref) = shift;

    local ($lastfile) = shift;

    local ($offset) = shift;

    local ($currentref) = shift;

    local ($refline, $type, $refcol);

    ## Do not generate references to the standard library files if we

    ## do not generate the corresponding html files

    return if (! $standard_library && $lastfile =~ /$standard_file_regexp/);

    ($refline, $type, $extern, $refcol) = /(\d+)(.)(<[^>]+>)?(\d+)/;

    $refline += $offset;

    ## If we have a body, then we only generate the cross-reference from

    ## the spec to the body if we have a subprogram (or a package)

    if ($type eq "b")

#       && ($symbols {$currentref} eq 'f' || $symbols {$currentref} eq 'K'))

    {

        local ($cref_file, $cref) = ($currentref =~ /([^\#]+).$fileext\#(.+)/);

        $symbols_used {"$cref_file#$cref"} = "$lastfile.$fileext#$refline\_$refcol";

        $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref;

        $symbols {"$lastfile.$fileext#$refline\_$refcol"} = "body";

    }

    ## Do not generate cross-references for "e" and "t", since these point to the

    ## semicolon that terminates the block -- irrelevant for gnathtml

    ## "p" is also removed, since it is used for primitive subprograms

    ## "d" is also removed, since it is used for discriminants

    ## "i" is removed since it is used for implicit references

    ## "z" is used for generic formals

    ## "k" is for references to parent package

    ## "=", "<", ">", "^" is for subprogram parameters

    elsif ($type !~ /[eztpid=<>^k]/)

    {

        $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref;

    }

}

########

##  Parses the ali file associated with the current Ada file

##  Params :  - the complete ali file name

########

sub parse_ali

{

  local ($filename) = shift;

  local ($currentfile);

  local ($currentref);

  local ($lastfile);

  # A    file | line type column      reference

  local ($reference) = "(?:(?:\\d+\\|)?\\d+.\\d+|\\w+)";

  # The following variable is used to represent the possible xref information

  # output by GNAT when -gnatdM is used. It includes renaming references, and

  # references to the parent type, as well as references to the generic parent

  local ($typeref) = "(?:=$reference|<$reference>|\\{$reference\\}|\\($reference\\)|\\[$reference\\])?";

  # The beginning of an entity declaration line in the ALI file

  local ($decl_line) = "^(\\d+)(.)(\\d+)[ *]([\\w\\d.-]+|\"..?\")$typeref\\s+(\\S.*)?\$";

  # Contains entries of the form  [ filename source_reference_offset]

  # Offset needs to be added to the lines read in the cross-references, and are

  # used when the source comes from a gnatchop-ed file. See lib-write.ads, lines

  # with ^D in the ALI file.

  local (@reffiles) = ();

  open (ALI, &find_file ($filename)) || do {

    print "no ", &find_file ($filename), " file...\n";

    return;

  };

  local (@ali) = <ALI>;

  close (ALI);

  undef %symbols;

  undef %symbols_used;

  foreach (@ali)

  {

    ## The format of D lines is

    ## D source-name time-stamp checksum [subunit-name] line:file-name

    if (/^D\s+([\w\d.-]+)\s+\S+ \S+(\s+\D[^: ]+)?( (\d+):(.*))?/)

    {

        # The offset will be added to each cross-reference line. If it is

        # greater than 1, this means that we have a pragma Source_Reference,

        # and this must not be counted in the xref information.

        my ($file, $offset) = ($1, (defined $4) ? 2 - $4 : 0);

        if ($dependencies)

        {

            push (@list_files, $1) unless (grep (/$file/, @list_files));

        }

        push (@reffiles, [&http_string (&get_real_file_name ($file)), $offset]);

    }

    elsif (/^X\s+(\d+)/)

    {

        $currentfile = $lastfile = $1 - 1;

    }

    elsif (defined $currentfile && /$decl_line/)

    {

      my ($line) = $1 + $reffiles[$currentfile][1];

      next if (! $standard_library

               && $reffiles[$currentfile][0] =~ /$standard_file_regexp/);

      if ($xref_variable || $2 eq &uppercases ($2))

      {

        $currentref = $reffiles[$currentfile][0] . ".$fileext#$line\_$3";

        $symbols {$currentref} = &to_type ($2);

        $lastfile = $currentfile;

        local ($endofline) = $5;

        foreach (split (" ", $endofline))

        {

            (s/^(\d+)\|//) && do { $lastfile = $1 - 1; };