428
+ − 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 }