This commit was manufactured by cvs2svn to create branch 'XEmacs-21_4'.
[chise/xemacs-chise.git.1] / src / src-headers
1 : #-*- Perl -*-
2 # Copyright (C) 1998 Free Software Foundation, Inc.
3
4 # This file is part of XEmacs.
5 #
6 # XEmacs is free software; you can redistribute it and/or modify it
7 # under the terms of the GNU General Public License as published by the
8 # Free Software Foundation; either version 2, or (at your option) any
9 # later version.
10 #
11 # XEmacs is distributed in the hope that it will be useful, but WITHOUT
12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
14 # for more details.
15 #
16 # You should have received a copy of the GNU General Public License
17 # along with XEmacs; see the file COPYING.  If not, write to
18 # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 # Boston, MA 02111-1307, USA.
20
21 # Author: Martin Buchholz
22 eval 'exec perl -w -S $0 ${1+"$@"}'
23   if 0;
24
25 use strict;
26 my ($myName, $srcdir);
27
28 ($myName = $0) =~ s@.*/@@; my $usage ="
29 Usage: $myName
30
31 Generates header file fragments from the Emacs sources
32 and writes them to stdout.\n";
33
34 die $usage if @ARGV;
35
36 ($srcdir = $0) =~ s@[^/]+$@@;
37 chdir $srcdir or die "$srcdir: $!";
38
39 # Find include dependencies
40 my (%exists, %uses);
41 opendir SRCDIR, "." or die "$srcdir: $!";
42 for (grep (/\.[ch]$/, readdir (SRCDIR))) { $exists{$_} = 1; }
43 closedir SRCDIR;
44 {
45   my %generated_header;
46   for (qw (config.h sheap-adjust.h paths.h Emacs.ad.h)) {
47     $generated_header{$_} = 1;
48   }
49
50   for my $file (keys %exists) {
51     open (FILE, $file) or die "$file: $!";
52     undef $/; $_ = <FILE>;
53     RemoveComments ($_);
54     s/[ \t]+//g;
55     for (/^\#include([^\n]+)/gmo) {
56       if (m@^\"([A-Za-z0-9_-]+\.h)\"@) {
57         $uses{$file}{$1} = 1 if exists $exists{$1};
58       } elsif (m@<([A-Za-z0-9_-]+\.h)>@) {
59         $uses{$file}{$1} = 1 if exists $generated_header{$1};
60       } elsif (m@\"../lwlib/([A-Za-z0-9_-]+\.h)\"@) {
61         $uses{$file}{"\$(LWLIB_SRCDIR)/lwlib.h"} = 1;
62       }
63     }
64   }
65
66   # Make transitive closure of %uses
67   while (1) {
68     my $changedP = 0;
69     for my $x (keys %uses) {
70       for my $y (keys %{$uses{$x}}) {
71         for my $z (keys %{$uses{$y}}) {
72           if (! exists $uses{$x}{$z}) {
73             $uses{$x}{$z} = 1;
74             $changedP = 1;
75           }
76         }
77       }
78     }
79     last if !$changedP;
80   }
81 } # End of finding include dependencies
82
83 my (%used, %maxargs);
84 my $minargs = '(?:[0-8])';
85 my $maxargs = '(?:[0-8]|MANY|UNEVALLED)';
86 my $doc = "(?:0|STR)";
87 my $fun = '(?:\\bF[a-z0-9_]+X?\\b)';
88 my $defun = "^DEFUN\\s*\\(\\s+STR\\s+($fun)\\s+$minargs\\s+($maxargs)\\s+$doc\\s+\\(";
89 my $var = '(?:\\b(?:Q[KS]?[a-z0-9_]+D?|V(?:[a-z0-9_]+)|Q_TT[A-Z]+)\\b)';
90 my $pat = "(?:$var|$fun)";
91 my %automagic;
92 my (%decl_file, %defn_file);
93
94 for my $file (keys %exists) {
95   open (FILE, $file) or die "$file: $!";
96   undef $/; $_ = <FILE>;
97   RemoveComments($_);
98   RemoveStrings ($_);
99   s/,/ /gmo;
100   s/^\s*EXFUN[^\n]+//gmo;
101
102   # Now search for DECLARE_LRECORD to find types for predicates
103   for my $sym (/^DECLARE_LRECORD\s*\(\s*([a-z_]+)\s+struct /gmo) {
104     $automagic{"Q${sym}p"} = 1;
105   }
106
107   if ($file =~ /\.c$/) {
108     my @match = (/$defun/gmo);
109     while (my $fun = shift @match) {
110       $defn_file{$fun} = $file;
111       $maxargs{$fun} = shift @match;
112     }
113
114     # Now do Lisp_Object variables
115     for my $defs (/^\s*Lisp_Object\s+((?:$var\s*)+)\s*;/gmo) {
116       for my $var (split (' ',$defs)) {
117         $defn_file{$var} = $file;
118       }
119     }
120   }
121
122   # Remove declarations of Lisp_Objects
123   s/^extern\s+Lisp_Object\s+(?:$var\s*)+\s*;//gmo;
124
125   # Remove declarations of functions
126   s/^Lisp_Object $fun//;
127
128   # Find all uses of symbols
129   for (/($pat)/gmo) { $used{$_}{$file} = 1; }
130 }
131
132 my %candidates;
133 for my $file (keys %exists) {
134   @{$candidates{$file}} = ();
135   my $header1 = $file;    $header1 =~ s/\.c$/.h/;
136   my $header2 = $header1; $header2 =~ s/-\w+\././;
137   push @{$candidates{$file}}, $header1 if exists $exists{$header1};
138   push @{$candidates{$file}}, $header2 if exists $exists{$header2} &&
139     $header1 ne $header2;
140 }
141
142 SYM: for my $sym (keys %used) {
143   next SYM unless my $defn_file = $defn_file{$sym};
144   my @users = keys %{$used{$sym}};
145   if (@users == 1) {
146     die "$sym\n" unless $defn_file eq $users[0];
147     next SYM;
148   }
149   for my $candidate (@{$candidates{$defn_file}}) {
150     if (!grep (!exists $uses{$_}{$candidate}, @users)) {
151       $decl_file{$sym} = $candidate;
152       next SYM;
153     }
154   }
155   $decl_file{$sym} = 'lisp.h';
156 }
157
158 # Print global Lisp_Objects
159 {
160   my $line;
161   sub flushvars {
162     if (defined $line) {
163       print "extern Lisp_Object $line;\n";
164       undef $line;
165     }
166   }
167
168   sub printvar {
169     my $var = shift;
170     if (!defined $line) { $line = $var; return; }
171     if ($var =~ /^Vcharset_/) {
172       flushvars ();
173       $line = $var;
174       flushvars ();
175       return;
176     }
177     if (length "$line, $var" > 59) {
178       flushvars (); $line = $var; return;
179     }
180     $line = "$line, $var";
181   }
182   END { flushvars (); }
183 }
184
185 delete @decl_file{ keys %automagic, qw(Qzero Qnull_pointer)};
186
187 # Print Lisp_Object var declarations
188 for my $file (keys %exists) {
189
190   # Print EXFUNs
191   if (my @funs = grep ($decl_file{$_} eq $file && exists $maxargs{$_},
192                        keys %decl_file)) {
193     print "\n\n$file:\n\n";
194     for $fun (sort @funs) {
195       print "EXFUN ($fun, $maxargs{$fun});\n";
196     }
197     print "\n";
198   }
199
200   if (my @vars = grep ($decl_file{$_} eq $file && /^[QV]/, keys %decl_file)) {
201     print "\n\n$file:\n\n";
202     for $var (sort @vars) {
203       printvar ($var);
204     }
205     flushvars ();
206     print "\n\n";
207   }
208 }
209
210 #for my $var (sort grep (keys %{$used{$_}} > 1 , keys %defn_file)) {
211 #  printvar ($var);
212 #}
213
214 sub RemoveComments {
215   $_[0] =~
216     s{ (
217         [^\"\'/]+ |
218         (?:\"[^\"\\]*(?:\\.[^\"\\]*)*\" [^\"\'/]*)+ |
219         (?:\'[^\'\\]*(?:\\.[^\'\\]*)*\' [^\"\'/]*)+
220        )
221        | / (?:
222             \*[^*]*\*+(?:[^/*][^*]*\*+)*/
223             |
224             /[^\n]*
225            )
226      }{defined $1 ? $1 : ""}gsxeo;
227 }
228
229 sub RemoveStrings {
230   $_[0] =~
231     s{ (
232         (?:\"[^\"\\]*(?:\\.[^\"\\]*)*\") |
233         (?:\'[^\'\\]*(?:\\.[^\'\\]*)*\')
234        )
235      }{ STR }gxo;
236 }