1#!/usr/bin/env perl
2
3#
4#//===----------------------------------------------------------------------===//
5#//
6#// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
7#// See https://llvm.org/LICENSE.txt for license information.
8#// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
9#//
10#//===----------------------------------------------------------------------===//
11#
12
13# Some pragmas.
14use strict;          # Restrict unsafe constructs.
15use warnings;        # Enable all warnings.
16
17use FindBin;
18use lib "$FindBin::Bin/lib";
19
20use tools;
21
22our $VERSION = "0.004";
23
24#
25# Subroutines.
26#
27
28sub parse_input($\%) {
29
30    my ( $input, $defs ) = @_;
31    my @bulk = read_file( $input );
32    my %entries;
33    my %ordinals;
34    my @dirs;
35    my $value = 1;
36
37    my $error =
38        sub {
39            my ( $msg, $l, $line ) = @_;
40            runtime_error(
41                "Error parsing file \"$input\" line $l:\n" .
42                "    $line" .
43                ( $msg ? $msg . "\n" : () )
44            );
45        }; # sub
46
47    my $n = 0;    # Line number.
48    foreach my $line ( @bulk ) {
49        ++ $n;
50        if ( 0 ) {
51        } elsif ( $line =~ m{^\s*(?:#|\n)} ) {
52            # Empty line or comment. Skip it.
53        } elsif ( $line =~ m{^\s*%} ) {
54            # A directive.
55            if ( 0  ) {
56            } elsif ( $line =~ m{^\s*%\s*if(n)?def\s+([A-Za-z0-9_]+)\s*(?:#|\n)} ) {
57                my ( $negation, $name ) = ( $1, $2 );
58                my $dir = { n => $n, line => $line, name => $name, value => $value };
59                push( @dirs, $dir );
60                $value = ( $value and ( $negation xor $defs->{ $name } ) );
61            } elsif ( $line =~ m{^\s*%\s*endif\s*(?:#|\n)} ) {
62                if ( not @dirs ) {
63                    $error->( "Orphan %endif directive.", $n, $line );
64                }; # if
65                my $dir = pop( @dirs );
66                $value = $dir->{ value };
67            } else {
68                $error->( "Bad directive.", $n, $line );
69            }; # if
70        } elsif ( $line =~ m{^\s*(-)?\s*([A-Za-z0-9_]+)(?:\s+(\d+|DATA))?\s*(?:#|\n)} ) {
71            my ( $obsolete, $entry, $ordinal ) = ( $1, $2, $3 );
72            if ( $value ) {
73                if ( exists( $entries{ $entry } ) ) {
74                    $error->( "Entry \"$entry\" has already been specified.", $n, $line );
75                }; # if
76                $entries{ $entry } = { ordinal => $ordinal, obsolete => defined( $obsolete ) };
77                if ( defined( $ordinal ) and $ordinal ne "DATA" ) {
78                    if ( $ordinal >= 1000 and $entry =~ m{\A[ok]mp_} ) {
79                        $error->( "Ordinal of user-callable entry must be < 1000", $n, $line );
80                    }; # if
81                    if ( $ordinal >= 1000 and $ordinal < 2000 ) {
82                        $error->( "Ordinals between 1000 and 1999 are reserved.", $n, $line );
83                    }; # if
84                    if ( exists( $ordinals{ $ordinal } ) ) {
85                        $error->( "Ordinal $ordinal has already been used.", $n, $line );
86                    }; # if
87                    $ordinals{ $ordinal } = $entry;
88                }; # if
89            }; # if
90        } else {
91            $error->( "", $n, $line );
92        }; # if
93    }; # foreach
94
95    if ( @dirs ) {
96        my $dir = pop( @dirs );
97        $error->( "Unterminated %if directive.", $dir->{ n }, $dir->{ line } );
98    }; # while
99
100    return %entries;
101
102}; # sub parse_input
103
104sub process(\%) {
105
106    my ( $entries ) = @_;
107
108    foreach my $entry ( keys( %$entries ) ) {
109        if ( not $entries->{ $entry }->{ obsolete } ) {
110            my $ordinal = $entries->{ $entry }->{ ordinal };
111            # omp_alloc and omp_free are C/C++ only functions, skip "1000+ordinal" for them
112            if ( $entry =~ m{\A[ok]mp_} and $entry ne "omp_alloc" and $entry ne "omp_free" and
113                $entry ne "omp_calloc" and $entry ne "omp_realloc" and
114                $entry ne "omp_aligned_alloc" and $entry ne "omp_aligned_calloc" ) {
115                if ( not defined( $ordinal ) ) {
116                    runtime_error(
117                        "Bad entry \"$entry\": ordinal number is not specified."
118                    );
119                }; # if
120                if ( $ordinal ne "DATA" ) {
121                    $entries->{ uc( $entry ) } = { ordinal => 1000 + $ordinal };
122                }
123            }; # if
124        }; # if
125    }; # foreach
126
127    return %$entries;
128
129}; # sub process
130
131sub generate_output(\%$) {
132
133    my ( $entries, $output ) = @_;
134    my $bulk;
135
136    $bulk = "EXPORTS\n";
137    foreach my $entry ( sort( keys( %$entries ) ) ) {
138        if ( not $entries->{ $entry }->{ obsolete } ) {
139            $bulk .= sprintf( "    %-40s ", $entry );
140            my $ordinal = $entries->{ $entry }->{ ordinal };
141            if ( defined( $ordinal ) ) {
142                if ( $ordinal eq "DATA" ) {
143                    $bulk .= "DATA";
144                } else {
145                    $bulk .= "\@" . $ordinal;
146                }; # if
147            }; # if
148            $bulk .= "\n";
149        }; # if
150    }; # foreach
151    if ( defined( $output ) ) {
152        write_file( $output, \$bulk );
153    } else {
154        print( $bulk );
155    }; # if
156
157}; # sub generate_output
158
159#
160# Parse command line.
161#
162
163my $input;   # The name of input file.
164my $output;  # The name of output file.
165my %defs;
166
167get_options(
168    "output=s"    => \$output,
169    "D|define=s"  =>
170        sub {
171            my ( $opt_name, $opt_value ) = @_;
172            my ( $def_name, $def_value );
173            if ( $opt_value =~ m{\A(.*?)=(.*)\z} ) {
174                ( $def_name, $def_value ) = ( $1, $2 );
175            } else {
176                ( $def_name, $def_value ) = ( $opt_value, 1 );
177            }; # if
178            $defs{ $def_name } = $def_value;
179        },
180);
181
182if ( @ARGV == 0 ) {
183    cmdline_error( "Not enough arguments." );
184}; # if
185if ( @ARGV > 1 ) {
186    cmdline_error( "Too many arguments." );
187}; # if
188$input = shift( @ARGV );
189
190#
191# Work.
192#
193
194my %data = parse_input( $input, %defs );
195%data = process( %data );
196generate_output( %data, $output );
197exit( 0 );
198
199__END__
200
201#
202# Embedded documentation.
203#
204
205=pod
206
207=head1 NAME
208
209B<generate-def.pl> -- Generate def file for OpenMP RTL.
210
211=head1 SYNOPSIS
212
213B<generate-def.pl> I<OPTION>... I<file>
214
215=head1 OPTIONS
216
217=over
218
219=item B<--define=>I<name>[=I<value>]
220
221=item B<-D> I<name>[=I<value>]
222
223Define specified name. If I<value> is omitted, I<name> is defined to 1. If I<value> is 0 or empty,
224name is B<not> defined.
225
226=item B<--output=>I<file>
227
228=item B<-o> I<file>
229
230Specify output file name. If option is not present, result is printed to stdout.
231
232=item B<--doc>
233
234=item B<--manual>
235
236Print full help message and exit.
237
238=item B<--help>
239
240Print short help message and exit.
241
242=item B<--usage>
243
244Print very short usage message and exit.
245
246=item B<--verbose>
247
248Do print informational messages.
249
250=item B<--version>
251
252Print version and exit.
253
254=item B<--quiet>
255
256Work quiet, do not print informational messages.
257
258=back
259
260=head1 ARGUMENTS
261
262=over
263
264=item I<file>
265
266A name of input file.
267
268=back
269
270=head1 DESCRIPTION
271
272The script reads input file, process conditional directives, checks content for consistency, and
273generates output file suitable for linker.
274
275=head2 Input File Format
276
277=over
278
279=item Comments
280
281    # It's a comment.
282
283Comments start with C<#> symbol and continue to the end of line.
284
285=item Conditional Directives
286
287    %ifdef name
288    %ifndef name
289    %endif
290
291A part of file surrounded by C<%ifdef I<name>> and C<%endif> directives is a conditional part -- it
292has effect only if I<name> is defined in the command line by B<--define> option. C<%ifndef> is a
293negated version of C<%ifdef> -- conditional part has an effect only if I<name> is B<not> defined.
294
295Conditional parts may be nested.
296
297=item Export Definitions
298
299    symbol
300    symbol ordinal
301    symbol DATA
302
303Symbols starting with C<omp_> or C<kmp_> must have ordinal specified. They are subjects for special
304processing: each symbol generates two output lines: original one and upper case version. The ordinal
305number of the second is original ordinal increased by 1000.
306
307=item Obsolete Symbols
308
309    - symbol
310    - symbol ordinal
311    - symbol DATA
312
313Obsolete symbols look like export definitions prefixed with minus sign. Obsolete symbols do not
314affect the output, but obsolete symbols and their ordinals cannot be (re)used in export definitions.
315
316=back
317
318=head1 EXAMPLES
319
320    $ generate-def.pl -D stub -D USE_TCHECK=0 -o libguide.def dllexport
321
322=cut
323
324# end of file #
325
326