source: branches/profile/GDEHELP/pp.pl

Last change on this file was 11874, checked in by westram, 6 years ago
  • Property svn:executable set to *
File size: 8.2 KB
Line 
1#!/usr/bin/perl
2# ============================================================ #
3#                                                              #
4#   File      : pp.pl                                          #
5#   Purpose   : a simple pseudo-C-preprocessor                 #
6#   Motivation:                                                #
7#     The C-preprocessor behaves different on different        #
8#     systems (e.g. clang, suse) while creating "arb.menu".    #
9#     That resulted in various failures,                       #
10#     some detected at compile-time, others at run-time.       #
11#                                                              #
12#   Coded by Ralf Westram (coder@reallysoft.de) in June 2012   #
13#   Institute of Microbiology (Technical University Munich)    #
14#   http://www.arb-home.de/                                    #
15#                                                              #
16# ============================================================ #
17
18# Restrictions:
19# - '#if' unsupported
20# - comment parsing is error-prone
21
22use strict;
23use warnings;
24
25sub parseOneParam(\$) {
26  my ($code_r) = @_;
27
28  my $inside = '';
29  my @instack = ();
30
31  my $param = '';
32
33  while ($$code_r =~ /[()[\],\"\']/o) {
34    my ($before,$sep,$after) = ($`,$&,$');
35    my ($do_pop,$do_shift) = (0,0);
36
37    if ($before =~ /\\$/o) { $do_shift = 1; }
38    elsif ($inside eq '"' or $inside eq '\'') {
39      if ($sep eq $inside) { $do_pop = 1; }
40      else { $do_shift = 1; }
41    }
42    else {
43      if ($sep eq ',') {
44        $$code_r = $after;
45        return $param.$before;
46      }
47      if ($sep eq '\'' or $sep eq '"' or $sep eq '(' or $sep eq '[') {
48        push @instack, $inside;
49        $inside = $sep;
50        $do_shift = 1;
51      }
52      elsif ($sep eq ')') {
53        if ($inside eq '') {
54          $$code_r = $sep.$after;
55          return $param.$before;
56        }
57        if ($inside ne '(') { die "Misplaced ')' in '$$code_r'\n"; }
58        $do_pop = 1;
59      }
60      elsif ($sep eq ']') {
61        if ($inside ne '[') { die "Misplaced ']' in '$$code_r'\n"; }
62        $do_pop = 1;
63      }
64      else {
65        die "unhandled separator: param='$param'\nbefore='$before'\nsep='$sep'\nafter='$after'\ncode_r='$$code_r'";
66      }
67    }
68
69    if ($do_pop==1) {
70      $inside = pop @instack;
71      $do_shift = 1;
72    }
73    if ($do_shift==1) {
74      $param .= $before.$sep;
75      $$code_r = $after;
76    }
77  }
78
79  $param .= $$code_r;
80  $$code_r = '';
81
82  return $param;
83}
84
85sub parseMacroParams($\@) {
86  my ($code,$param_r) = @_;
87
88  if (not $code =~ /^\(/o) { die "Expected '(', seen '$code'"; }
89  $code = $';
90
91 PARAM: while (1) {
92    $code =~ s/^\s+//o;
93    if ($code =~ /^\)/o) { $code = $'; last PARAM; }
94    if ($code eq '') { die "Missing or misplaced ')'"; }
95
96    my $param = parseOneParam($code);
97    push @$param_r, $param;
98  }
99  return $code;
100}
101
102sub apply_define($\@);
103sub apply_define($\@) {
104  my ($line,$defr) = @_;
105
106  my $name = $$defr[0];
107  if ($line =~ /\b$name\b/) {
108    my ($prefix,$suffix) = ($`,$');
109    my $pcount = $$defr[1];
110    if ($pcount==0) {
111      return $prefix.$$defr[2].apply_define($suffix,@$defr);
112    }
113
114    my @param = ();
115    $suffix = parseMacroParams($suffix,@param);
116
117    my $paramCount = scalar(@param);
118    if ($paramCount ne $pcount) {
119      die "Expected $pcount arguments for macro '$name' (found $paramCount)\n";
120    }
121
122    my $expanded = $$defr[$pcount+2];
123    for (my $p=0; $p<$pcount; $p++) {
124      my $search = $$defr[$p+2];
125      my $replace = $param[$p];
126      $expanded =~ s#$search#$replace#g;
127    }
128
129    return $prefix.$expanded.apply_define($suffix,@$defr);
130  }
131  return $line;
132}
133
134my @define = (); # list of defines (applied in order). contains array refs to [ name, pcount, [ pnames...,] content ]
135my %define = (); # known defines
136
137sub apply_defines($) {
138  my ($line) = @_;
139  foreach my $defr (@define) {
140    $line = apply_define($line, @$defr);
141  }
142  return $line;
143}
144
145sub def_define {
146  my @def = @_;
147  unshift @define, \@def;
148  $define{$def[0]} = 1;
149}
150
151sub add_define($) {
152  my ($rest) = @_;
153
154  if ($rest =~ /^[A-Z0-9_]+/io) {
155    my ($name,$param) = ($&,$');
156    if ($param eq '') {
157      def_define($name, 0, '');
158    }
159    elsif ($param =~ /^\s+/o) {
160      def_define($name, 0, apply_defines($'));
161    }
162    elsif ($param =~ /^\(([a-z0-9,_]+)\)\s+/io) {
163      my ($args,$def) = ($1,$');
164      $args =~ s/\s+//oig;
165      my @args = split /,/,$args;
166      my $count = scalar(@args);
167
168      my @array = ( $name, $count );
169      foreach (@args) { push @array, $_; }
170      push @array, apply_defines($def);
171      def_define(@array);
172    }
173    else {
174      die "invalid macro parameter '$param'";
175    }
176  }
177  else {
178    die "invalid define '$rest'\n";
179  }
180 
181}
182sub rm_define($) {
183  my ($rest) = @_;
184  if ($rest =~ /^[A-Z0-9_]+/io) {
185    my $name = $&;
186    if (exists $define{$name}) {
187      @define = map {
188        my $def_r = $_;
189        if ($$def_r[0] eq $name) { ; }
190        else { $def_r; }
191      } @define;
192      delete $define{$name};
193    }
194    else {
195      die "'$name' has not been defined";
196    }
197  }
198  else {
199    die "invalid undef '$rest'\n";
200  }
201}
202sub is_defined($) {
203  my ($rest) = @_;
204  if ($rest =~ /^[A-Z0-9_]+/io) {
205    my $name = $&;
206    exists $define{$name};
207  }
208  else {
209    die "invalid ifdef '$rest'\n";
210  }
211}
212
213my $inMultiLineComment = 0;
214
215sub remove_comments($);
216sub remove_comments($) {
217  my ($line) = @_;
218  if ($inMultiLineComment) {
219    if ($line =~ /\*\//o) {
220      $inMultiLineComment--;
221      $line = $';
222    }
223    if ($inMultiLineComment) {
224      return '';
225    }
226  }
227  if ($line =~ /^[^'"]*\/\//o) {
228    return $`."\n";
229  }
230  if ($line =~ /\/\*/o) {
231    $inMultiLineComment++;
232    return remove_comments($');
233  }
234  return $line;
235}
236
237sub preprocess($);
238
239my @include = (); # list of include directories
240
241sub include_via_ipath($) {
242  my ($name) = @_;
243  foreach (@include) {
244    my $rel = $_.'/'.$name;
245    if (-f $rel) {
246      preprocess($rel);
247      return;
248    }
249  }
250  die "Could not find include file '$name'\n";
251}
252
253sub include($) {
254  my ($spec) = @_;
255  if ($spec =~ /^\"([^\"]+)\"/o) {
256    my $name = $1;
257    if (-f $name) { preprocess($name); }
258    else { include_via_ipath($name); }
259  }
260  elsif ($spec =~ /^<([^>]+)>/o) {
261    my $name = $1;
262    include_via_ipath($name);
263  }
264  else { die "no idea how to include '$spec'\n"; }
265}
266
267sub preprocess($) {
268  my ($src) = @_;
269
270  my $skip = 0;
271  my @skipstack = ();
272
273  open(my $IN,'<'.$src) || die "can't read '$src' (Reason: $!)";
274  my $line;
275  while (defined($line=<$IN>)) {
276    while ($line =~ /\\\n/o) { # concat multilines
277      my ($body) = $`;
278      my $nextLine = <$IN>;
279      if (not defined $nextLine) { die "runaway multiline"; }
280      $line = $body.$nextLine;
281    }
282
283    eval {
284      if ($line =~ /^\s*[#]\s*([^\s]*)\s+/o) {
285        my ($token,$rest) = ($1,$');
286        chomp($rest);
287        if ($token eq 'define') { add_define($rest); }
288        elsif ($token eq 'undef') { rm_define($rest); }
289        elsif ($token eq 'include') {
290          my $oline = $.;
291          eval { include($rest); };
292          $. = $oline;
293          if ($@) { die "included from here\n$@"; }
294        }
295        elsif ($token eq 'ifdef') {
296          push @skipstack, $skip;
297          $skip = is_defined($rest) ? 0 : 1;
298        }
299        elsif ($token eq 'else') {
300          if (scalar(@skipstack)==0) { die "else w/o if\n"; }
301          $skip = 1-$skip;
302        }
303        elsif ($token eq 'endif') {
304          if (scalar(@skipstack)==0) { die "endif w/o if\n"; }
305          $skip = pop @skipstack;
306        }
307        else { die "unknown preprocessor token='$token' rest='$rest'\n"; }
308      }
309      else {
310        if ($skip==0) {
311          $line = remove_comments($line);
312          print apply_defines($line);
313        }
314      }
315    };
316    if ($@) { die "$src:$.: $@\n"; }
317  }
318  if (scalar(@skipstack)!=0) { die "EOF reached while inside if\n"; }
319  close($IN);
320}
321
322sub addIncludePaths($) {
323  my ($pathlist) = @_;
324  my @paths = split /;/, $pathlist;
325  foreach (@paths) { push @include, $_; }
326}
327
328sub main() {
329  eval {
330    my $src = undef;
331    foreach (@ARGV) {
332      if ($_ =~ /^-I/) {
333        addIncludePaths($');
334      }
335      else {
336        if (defined $src) { die "Multiple sources specified ('$src' and '$_')\n"; }
337        $src = $_;
338      }
339    }
340
341    preprocess($src);
342  };
343  if ($@) { die "$@ (in pp.pl)\n"; }
344}
345main();
346
347
Note: See TracBrowser for help on using the repository browser.