Mercurial > hg > xemacs-beta
annotate lib-src/make-mswin-unicode.pl @ 4539:061e030e3270
Fix some bugs in load-history construction, built-in symbol file names.
lib-src/ChangeLog addition:
2008-12-27 Aidan Kehoe <kehoea@parhasard.net>
* make-docfile.c (main): Allow more than one -d argument, followed
by a directory to change to.
(put_filename): Don't strip directory information; with previous
change, allows retrieval of Lisp function and variable origin
files from #'built-in-symbol-file relative to lisp-directory.
(scan_lisp_file): Don't add an extraneous newline after the file
name, put_filename has added the newline already.
lisp/ChangeLog addition:
2008-12-27 Aidan Kehoe <kehoea@parhasard.net>
* loadup.el (load-history):
Add the contents of current-load-list to load-history before
clearing it. Move the variable declarations earlier in the file to
a format understood by make-docfile.c.
* custom.el (custom-declare-variable): Add the variable's symbol
to the current file's load history entry correctly, don't use a
cons. Eliminate a comment that we don't need to worry about, we
don't need to check the `initialized' C variable in Lisp.
* bytecomp.el (byte-compile-output-file-form):
Merge Andreas Schwab's pre-GPLv3 GNU change of 19970831 here;
treat #'custom-declare-variable correctly, generating the
docstrings in a format understood by make-docfile.c.
* loadhist.el (symbol-file): Correct behaviour for checking
autoloaded macros and functions when supplied with a TYPE
argument. Accept fully-qualified paths from
#'built-in-symbol-file; if a path is not fully-qualified, return
it relative to lisp-directory if the filename corresponds to a
Lisp file, and relative to (concat source-directory "/src/")
otherwise.
* make-docfile.el (preloaded-file-list):
Rationalise some let bindings a little. Use the "-d" argument to
make-docfile.c to supply Lisp paths relative to lisp-directory,
not absolutely. Add in loadup.el explicitly to the list of files
to be processed by make-docfile.c--it doesn't make sense to add it
to preloaded-file-list, since that is used for purposes of
byte-compilation too.
src/ChangeLog addition:
2008-12-27 Aidan Kehoe <kehoea@parhasard.net>
* doc.c (Fbuilt_in_symbol_file):
Return a subr's filename immediately if we've found it. Check for
compiled function and compiled macro docstrings in DOC too, and
return them if they exist.
The branch of the if statement focused on functions may have
executed, but we may still want to check variable bindings; an
else clause isn't appropriate.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sat, 27 Dec 2008 14:05:50 +0000 |
parents | 23ef20edf6ba |
children | 50861fea97f6 |
rev | line source |
---|---|
771 | 1 : #-*- Perl -*- |
2 | |
3 ### make-mswin-unicode --- generate Unicode-encapsulation code for MS Windows | |
4 | |
2367 | 5 ## Copyright (C) 2001, 2002, 2004 Ben Wing. |
771 | 6 |
7 ## Author: Ben Wing <ben@xemacs.org> | |
8 ## Maintainer: Ben Wing <ben@xemacs.org> | |
9 ## Current Version: 1.0, August 24, 2001 | |
10 | |
11 ## This file is part of XEmacs. | |
12 | |
13 ## XEmacs is free software; you can redistribute it and/or modify it | |
14 ## under the terms of the GNU General Public License as published by | |
15 ## the Free Software Foundation; either version 2, or (at your option) | |
16 ## any later version. | |
17 | |
18 ## XEmacs is distributed in the hope that it will be useful, but | |
19 ## WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
21 ## General Public License for more details. | |
22 | |
23 ## You should have received a copy of the GNU General Public License | |
24 ## along with XEmacs; see the file COPYING. If not, write to the Free | |
25 ## Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
26 ## 02111-1307, USA. | |
27 | |
28 eval 'exec perl -w -S $0 ${1+"$@"}' | |
29 if 0; | |
30 | |
31 use strict; | |
32 use File::Basename; | |
33 use Getopt::Long; | |
34 | |
35 my ($myName, $myPath) = fileparse ($0); | |
36 | |
37 my $usage=" | |
38 Usage: $myName [--c-output FILE] [--h-output FILE] [--help] [FILES ...] | |
39 | |
40 The purpose of this script is to auto-generate Unicode-encapsulation | |
41 code for MS Windows library functions that come in two versions (ANSI | |
42 and Unicode). The MS Windows header files provide a way of | |
43 automatically calling the right version, but only at compile-time, | |
44 which is *NOT* sufficient for any real-world program. The solution is | |
45 run-time Unicode encapsulation, which is not conceptually difficult | |
46 but is time-consuming, and is not supported standardly only due to | |
47 evil marketing decisions made by Microsoft. See src/intl-win32.c | |
48 for more information. | |
49 | |
800 | 50 In XEmacs, this file is normally run using `nmake -f xemacs.mak |
51 unicode-encapsulate'. | |
52 | |
771 | 53 This script processes the specified files, looking for commands |
54 indicating library routines to Unicode-encapsulate, as follows: | |
55 | |
56 Portions of the files that should be processed are enclosed in lines | |
57 consisting only of the words \"begin-unicode-encapsulation-script\" | |
58 and \"end-unicode-encapsulation-script\". More than one section can | |
59 occur in a single file. Processed lines begin with a command word, | |
60 followed by one or more args (no quotes are necessary for spaces): | |
61 | |
62 file specifies a file to start reading from. | |
63 yes indicates a function to be automatically Unicode-encapsulated. | |
64 (All parameters either need no special processing or are LPTSTR or | |
65 LPCTSTR.) | |
66 soon indicates a function that should be automatically Unicode-encapsulated, | |
67 but we're not ready to process it yet. | |
68 no indicates a function we don't support (it will be #defined to cause | |
69 a compile error, with the text after the function included in the | |
70 erroneous definition to indicate why we don't support it). | |
71 skip indicates a function we support manually; only a comment about this | |
72 will be generated. | |
73 split indicates a function with a split structure (different versions | |
74 for Unicode and ANSI), but where the only difference is in pointer | |
75 types, and the actual size does not differ. The structure name | |
76 should follow the function name, and it will be automatically | |
77 Unicode-encapsulated with appropriate casts. | |
78 begin-bracket indicates a #if statement to be inserted here. | |
79 end-bracket indicates the corresponding #endif statement. | |
80 blank lines and lines beginning with // are ignored. | |
81 "; | |
82 | |
83 # ------------------ process command-line options ------------------ | |
84 | |
85 my %options; | |
86 my @SAVE_ARGV = @ARGV; | |
87 | |
88 $Getopt::Long::ignorecase = 0; | |
89 &GetOptions ( | |
90 \%options, | |
91 'c-output=s', | |
92 'h-output=s', | |
778 | 93 'includedir=s', |
771 | 94 'help', |
95 ); | |
96 | |
97 die $usage if $options{"help"}; | |
98 | |
99 my $in_script; | |
100 my $slurp; | |
101 | |
778 | 102 my ($cout, $hout, $dir) = ($options{"c-output"}, |
103 $options{"h-output"}, | |
104 $options{"includedir"}); | |
105 if (!$dir) | |
106 { | |
4467
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
107 for my $sdkroot (("WindowsSdkDir", "MSSdk", "MSVCDIR")) |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
108 { |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
109 if (defined $ENV{$sdkroot}) { |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
110 $dir = $ENV{$sdkroot}; |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
111 last; |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
112 } |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
113 } |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
114 unless (defined $dir) |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
115 { |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
116 die "Can't find the Windows SDK headers; run vcvars32.bat from your MSVC installation, or setenv.cmd from the Platform SDK installation"; |
23ef20edf6ba
Check %WindowsSdkDir%, %MSSddk% for the Windows header files too.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3728
diff
changeset
|
117 } |
778 | 118 $dir.='/include'; |
119 } | |
3728 | 120 die "Can't find MSVC include files in \"$dir\"" unless ((-f $dir.'/WINDOWS.H') || (-f $dir.'/windows.h')); |
771 | 121 |
122 open (COUT, ">$cout") or die "Can't open C output file $cout: $!"; | |
123 open (HOUT, ">$hout") or die "Can't open C output file $hout: $!"; | |
124 | |
125 select (STDOUT); $| = 1; | |
126 | |
127 print COUT "/* Automatically-generated Unicode-encapsulation file, | |
128 using the command | |
129 | |
130 $myPath$myName @SAVE_ARGV | |
131 | |
132 Do not edit. See `$myName'. | |
133 */ | |
134 | |
135 #include <config.h> | |
136 #include \"lisp.h\" | |
137 | |
138 #include \"syswindows.h\" | |
139 | |
140 "; | |
141 print HOUT "/* Automatically-generated Unicode-encapsulation header file. | |
142 Do not edit. See `$myName'. | |
143 */\n\n"; | |
144 | |
145 my %files; | |
146 my %processed; | |
147 my %bracket; | |
148 | |
149 my $current_file; | |
150 my @current_bracket; | |
151 | |
152 while (<>) | |
153 { | |
154 chomp; | |
800 | 155 # remove trailing CR. #### Should not be necessary! Perl should be |
156 # opening these in text mode by default, as the docs claim, and | |
157 # automatically remove the CR's. | |
158 tr/\r//d; | |
771 | 159 |
160 if (/^begin-unicode-encapsulation-script$/) | |
161 { | |
162 $in_script = 1; | |
163 } | |
164 elsif (/^end-unicode-encapsulation-script$/) | |
165 { | |
166 $in_script = 0; | |
167 } | |
168 elsif ($in_script) | |
169 { | |
170 next if (m!^//!); | |
171 next if (/^[ \t]*$/); | |
778 | 172 if (/(file|yes|soon|no|skip|split|begin-bracket|end-bracket)(?: (.*))?/) |
771 | 173 { |
174 my ($command, $parms) = ($1, $2); | |
778 | 175 if ($command eq "file") |
771 | 176 { |
177 $current_file = $parms; | |
178 } | |
179 elsif ($command eq "begin-bracket") | |
180 { | |
181 my $current_bracket = $current_bracket[$#current_bracket]; | |
182 if (defined ($current_bracket)) | |
183 { | |
184 $current_bracket .= "&& $parms"; | |
185 } | |
186 else | |
187 { | |
188 $current_bracket = "$parms"; | |
189 } | |
190 push @current_bracket, $current_bracket; | |
191 } | |
192 elsif ($command eq "end-bracket") | |
193 { | |
194 pop @current_bracket; | |
195 } | |
196 else | |
197 { | |
198 my ($fun, $reason) = split /\s+/, $parms, 2; | |
199 $files{$current_file}{$fun} = [$command, $reason]; | |
200 $bracket{$current_file}{$fun} = | |
201 $current_bracket[$#current_bracket]; | |
202 } | |
203 } | |
204 else | |
205 { | |
206 print "WARNING: Unknown line $_\n"; | |
207 } | |
208 } | |
209 } | |
210 | |
211 | |
212 foreach my $file (keys %files) | |
213 { | |
214 $slurp = &FileContents ($file); | |
215 print "Processing file $file\n"; | |
216 print HOUT "\n/* Processing file $file */\n\n"; | |
217 my $totalspace = 70 - length ("Processing file $file"); | |
218 $totalspace = 0 if $totalspace < 0; | |
219 my $alignspaceleft = $totalspace / 2; | |
220 my $alignspaceright = ($totalspace + 1) / 2; | |
221 print COUT " | |
222 /*----------------------------------------------------------------------*/ | |
223 /*" . (" " x $alignspaceleft) . "Processing file $file" . | |
224 (" " x $alignspaceright) . "*/ | |
225 /*----------------------------------------------------------------------*/ | |
226 | |
227 "; | |
228 | |
229 my ($ws_re, $must_ws_re, $tok_ch) = | |
230 ("\\s*", "\\s+", "\\w"); | |
231 # unfortunately there is no surefire way short of | |
232 # parsing all include files for typedefs to | |
233 # distinguish types from parameters, and prototypes | |
234 # appear in the include files both with and without | |
235 # parameters -- the latter kinds appear in a very | |
236 # different style and were obviously added later. so | |
237 # we rely on the fact that defined types are all | |
238 # upper-case, and parameters generally are not, and | |
239 # special-case the exceptions. | |
240 my $typeword_re = | |
241 # note the negative lookahead assertions: the first | |
242 # one excludes the words "X" and "Y" from type | |
243 # words, since they appear as parameter names in | |
244 # CreateWindowEx; the second prevents "void | |
245 # *Argument" from being parsed as a type "void *A" | |
246 # followed by a parameter "rgument". | |
247 "(?:(?!(?:X\\b|Y\\b))(?:unsigned|int|long|short|va_list|[A-Z_0-9]+)(?!${tok_ch}))"; | |
248 my $typetoken_re = "(?:$typeword_re$ws_re\\**$ws_re)"; | |
249 my $arg_re = "(?:($typetoken_re+)(${tok_ch}+)?(?: OPTIONAL)?)"; | |
250 my $fun_re = "(SHSTDAPI_\\(${tok_ch}+\\)|${tok_ch}" . "[A-Za-z_0-9 \t\n\r\f]*?${tok_ch})${ws_re}(${tok_ch}+)W${ws_re}\\(((${ws_re}${arg_re}${ws_re},)*${ws_re}${arg_re}${ws_re})\\);"; | |
251 | |
252 # print "regexp: $fun_re\n"; | |
253 while ($slurp =~ /$fun_re/g) | |
254 { | |
255 my ($rettype, $fun, $args) = ($1, $2, $3); | |
256 $processed{$fun} = 1; | |
257 print "Processing: $fun"; | |
258 | |
259 my ($command, $reason) = ($files{$file}{$fun}[0], $files{$file}{$fun}[1]); | |
260 if (!defined ($command)) | |
261 { | |
262 print " (no command found)\n"; | |
263 } | |
264 else | |
265 { | |
266 print "\n"; | |
267 my $bracket = $bracket{$file}{$fun}; | |
268 if (defined ($bracket)) | |
269 { | |
270 print HOUT "#if $bracket\n"; | |
271 print COUT "#if $bracket\n\n"; | |
272 } | |
273 if ($command eq "no") | |
274 { | |
275 if (!defined ($reason)) | |
276 { | |
277 print "WARNING: No reason given for `no' with function $fun\n"; | |
278 $reason = ""; | |
279 } | |
280 | |
281 print HOUT "#undef $fun\n"; | |
2367 | 282 (my $munged_reason = $reason) =~ s/[^A-Za-z0-9]/_/g; |
283 print HOUT "#define $fun error_$munged_reason\n"; | |
771 | 284 print COUT "/* Error if $fun used: $reason */\n\n"; |
285 } | |
286 elsif ($command eq "skip") | |
287 { | |
288 if (!defined ($reason)) | |
289 { | |
290 print "WARNING: No reason given for `skip' with function $fun\n"; | |
291 $reason = ""; | |
292 } | |
293 | |
294 print HOUT "/* Skipping $fun because $reason */\n"; | |
295 print COUT "/* Skipping $fun because $reason */\n\n"; | |
296 } | |
297 elsif ($command eq "soon") | |
298 { | |
299 $reason = "" if !defined ($reason); | |
300 | |
301 print HOUT "/* Not yet: $fun $reason */\n"; | |
302 print COUT "/* Not yet: $fun $reason */\n\n"; | |
303 } | |
304 else | |
305 { | |
306 my (@args, %argtype, %ansiarg, %xarg, $split_struct, | |
307 $split_rettype); | |
308 if ($command eq "split") | |
309 { | |
310 ($split_struct, $reason) = split /\s+/, $reason, 2; | |
311 } | |
312 my $argno = 0; | |
313 while ($args =~ /$arg_re/g) | |
314 { | |
315 $argno++; | |
316 my ($argtype, $argname) = ($1, $2); | |
317 $argtype =~ s/\s*$//; | |
318 next if $argtype eq "void" || $argtype eq "VOID"; | |
319 $argname = "arg$argno" if !defined ($argname); | |
320 $argtype{$argname} = $argtype; | |
321 $ansiarg{$argname} = $argtype; | |
322 $ansiarg{$argname} =~ s/\bLPWSTR\b/LPSTR/; | |
323 $ansiarg{$argname} =~ s/\bLPCWSTR\b/LPCSTR/; | |
324 $xarg{$argname} = $argtype; | |
325 $xarg{$argname} =~ s/\bLPWSTR\b/Extbyte */; | |
326 $xarg{$argname} =~ s/\bLPCWSTR\b/const Extbyte */; | |
327 if (defined ($split_struct)) | |
328 { | |
329 my $fuck_cperl1 = "\\b${split_struct}W\\b"; | |
330 my $fuck_cperl2 = "${split_struct}A"; | |
331 $ansiarg{$argname} =~ s/$fuck_cperl1/$fuck_cperl2/; | |
332 } | |
333 push @args, $argname; | |
334 } | |
335 $rettype =~ s/\bSHSTDAPI_\((.*)\)/$1/; | |
336 $rettype =~ s/\s*WIN\w*?API\s*//g; | |
337 $rettype =~ s/\bAPIENTRY\b//; | |
338 $rettype =~ s/\bSHSTDAPI\b/HRESULT/; | |
339 if ($rettype =~ /LPC?WSTR/) | |
340 { | |
341 $split_rettype = 1; | |
342 $rettype =~ s/\bLPWSTR\b/Extbyte */; | |
343 $rettype =~ s/\bLPCWSTR\b/const Extbyte */; | |
344 } | |
800 | 345 print HOUT "#ifdef ERROR_WHEN_NONINTERCEPTED_FUNS_USED\n"; |
346 print HOUT "#undef $fun\n"; | |
2367 | 347 print HOUT "#define $fun error_use_qxe${fun}_or_${fun}A_and_${fun}W\n"; |
800 | 348 print HOUT "#endif\n"; |
771 | 349 if (defined ($reason)) |
350 { | |
351 print COUT "/* NOTE: $reason */\n"; | |
352 } | |
353 print COUT "$rettype\nqxe$fun ("; | |
354 print HOUT "$rettype qxe$fun ("; | |
355 my $first = 1; | |
356 if (!@args) | |
357 { | |
358 print COUT "void"; | |
359 print HOUT "void"; | |
360 } | |
361 else | |
362 { | |
363 foreach my $x (@args) | |
364 { | |
365 print COUT ", " if !$first; | |
366 print HOUT ", " if !$first; | |
367 $first = 0; | |
368 print COUT "$xarg{$x} $x"; | |
369 print HOUT "$xarg{$x} $x"; | |
370 } | |
371 } | |
372 print HOUT ");\n"; | |
373 print COUT ")\n{\n if (XEUNICODE_P)\n "; | |
374 if ($rettype ne "void" && $rettype ne "VOID") | |
375 { | |
376 print COUT "return "; | |
377 print COUT "($rettype) " if $split_rettype; | |
378 } | |
379 print COUT "${fun}W ("; | |
380 $first = 1; | |
381 foreach my $x (@args) | |
382 { | |
383 print COUT ", " if !$first; | |
384 $first = 0; | |
385 print COUT ($argtype{$x} eq $xarg{$x} ? $x : | |
386 "($argtype{$x}) $x"); | |
387 } | |
388 print COUT ");\n else\n "; | |
389 if ($rettype ne "void" && $rettype ne "VOID") | |
390 { | |
391 print COUT "return "; | |
392 print COUT "($rettype) " if $split_rettype; | |
393 } | |
394 print COUT "${fun}A ("; | |
395 $first = 1; | |
396 foreach my $x (@args) | |
397 { | |
398 print COUT ", " if !$first; | |
399 $first = 0; | |
400 print COUT ($argtype{$x} eq $ansiarg{$x} ? $x : | |
401 "($ansiarg{$x}) $x"); | |
402 } | |
403 print COUT ");\n}\n\n"; | |
404 } | |
405 if (defined ($bracket)) | |
406 { | |
407 print HOUT "#endif /* $bracket */\n"; | |
408 print COUT "#endif /* $bracket */\n\n"; | |
409 } | |
800 | 410 print HOUT "\n"; |
771 | 411 } |
412 } | |
413 } | |
414 | |
415 foreach my $file (keys %files) | |
416 { | |
417 foreach my $fun (keys %{$files{$file}}) | |
418 { | |
419 if (!$processed{$fun} && $files{$file}{$fun}[0] =~ /^(yes|soon|split)$/) | |
420 { | |
421 print "WARNING: Can't locate prototype for $fun\n"; | |
422 } | |
423 } | |
424 } | |
425 | |
426 | |
427 sub FileContents | |
428 { | |
429 local $/ = undef; | |
778 | 430 open (FILE, "< $dir/$_[0]") or die "$dir/$_[0]: $!"; |
771 | 431 my $retval = scalar <FILE>; |
432 # must hack away CRLF junk. | |
433 $retval =~ s/\r\n/\n/g; | |
434 return $retval; | |
435 } |