1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
#!/usr/local/bin/perl -w
require 5.003;
use Text::Tabs;
# Copyright (C) 1997 National Center for Supercomputing Applications.
# All rights reserved.
#
# Robb Matzke, matzke@llnl.gov
# 30 Aug 1997
#
# Purpose: This script will read standard input which should be a
# function prologue followed by a C function and will emit
# on standard output the same source code with the function
# prologue containing documentation for the various errors
# that occur in the function.
#
# Errors are raised by calling HGOTO_ERROR() or
# HRETURN_ERROR(). The reason for the error message is a
# comment which appears immediately after the error macro
# call and is contained entirely on one line:
#
# HRETURN_ERROR (...); /*entry not found*/
#
# If such a comment doesn't exist, then the previous comment
# is used, subject to the constraint that raising an error
# clears the previous comment.
#
# /* Entry not found */
# HGOTO_ERROR (...);
#
# Emacs users can use this script interactively with the
# c-mark-function and shell-command-on-region functions which
# are normally bound to M-C-h and M-|.
# Split STDIN into the prolog and the function body. Preserve leading
# white space.
$_ = join "", <STDIN>;
my ($head, $prolog, $body) = (/^(\s*)(\/\*(.*?)\*\/)?(.*)/s)[0,2,3];
$prolog = "" unless $prolog;
# Find each error and the comment that goes with it.
for ($_=$body,$comment=""; /\/\*|H(RETURN|GOTO)_ERROR/s;) {
$_ = $&.$';
if (/^H(RETURN|GOTO)_ERROR\s*\(\s*H5E_(\w+)\s*,\s*H5E_(\w+)\s*,/s) {
($major, $minor, $_) = ($2, $3, $');
$comment=$1 if /^.*?\)\s*;\s*\/\*\s*(.*?)\s*\*\//;
$comment =~ s/^\s*\*+\s*/ /mg; # leading asterisks.
$comment =~ s/^\s+//s; # leading white space.
$comment =~ s/\s+$//s; # trailing white space.
$comment =~ s/(\w)$/$1./s; # punctuation.
$comment ||= "***NO COMMENT***";
$errors{"$major\000$minor\000\u$comment"} = 1;
$comment = "";
} else {
($comment) = /^\/\*\s*(.*?)\s*\*\//s;
$_ = $';
}
}
# Format an error so it isn't too wide.
sub fmt_error ($) {
local ($_) = @_;
my ($prefix,$space,$err) = /^((.*?)([A-Z_0-9]+\s+[A-Z_0-9]+\s+))/;
$_ = $';
tr/\n / /s;
my $w = 70 - length expand $prefix;
s/(.{$w}\S+)\s+(\S)/$1."\n".$space.' 'x(length $err).$2/eg;
return $prefix . $_."\n";
}
# Sort the errors by major, then minor, then comment. Duplicate
# triplets have already been removed.
sub by_triplet {
my ($a_maj, $a_min, $a_com) = split /\000/, $a;
my ($b_maj, $b_min, $b_com) = split /\000/, $b;
$a_maj cmp $b_maj || $a_min cmp $b_min || $a_com cmp $b_com;
}
@errors = map {sprintf "%-9s %-13s %s\n", split /\000/}
sort by_triplet keys %errors;
# Add the list of errors to the prologue depending on the type of
# prolog.
if (($front, $back) = $prolog=~/^(.*?Errors:\s*?(?=\n)).*?\n\s*\*\s*\n(.*)/s) {
#| * Errors: |#
#| * __list_of_error_messages__ (zero or more lines) |#
#| * |#
print $head, "/*", $front, "\n";
map {print fmt_error " *\t\t".$_} @errors;
print " *\n", $back, "*/", $body;
} elsif (($front,$back) = $prolog =~
/(.*?\n\s*ERRORS:?\s*?(?=\n)).*?\n\s*\n(.*)/s) {
#| ERRORS |#
#| __list_of_error_messages__ (zero or more lines) |#
#| |#
print $head, "/*", $front, "\n";
map {print fmt_error " ".$_} @errors;
print "\n", $back, "*/", $body;
} elsif ($prolog eq "") {
# No prolog present.
print $head;
print " \n/*", "-"x73, "\n * Function:\t\n *\n * Purpose:\t\n *\n";
print " * Errors:\n";
map {print fmt_error " *\t\t".$_} @errors;
print " *\n * Return:\tSuccess:\t\n *\n *\t\tFailure:\t\n *\n";
print " * Programmer:\t\n *\n * Modifications:\n *\n *", '-'x73, "\n";
print " */\n", $body;
} else {
# Prolog format not recognized.
print $head, "/*", $prolog, "*/\n\n";
print "/*\n * Errors returned by this function...\n";
map {print fmt_error " *\t".$_} @errors;
print " */\n", $body;
}
|
