blob: 3a7a719d4957a25e43bd4a39fc4d52e9b9ae4b62 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
Fix insecure use of temporary files.
Patch from upstream bzr, backported to Emacs 23.4.
https://bugs.gentoo.org/509830
CVE-2014-3422
revno: 117067
fixes bug: http://bugs.debian.org/747100
committer: Glenn Morris <rgm@gnu.org>
branch nick: emacs-24
timestamp: Mon 2014-05-05 20:53:31 -0700
message:
find-gc.el misc fixes
The whole file looks obsolete and/or broken.
* lisp/emacs-lisp/find-gc.el (find-gc-source-directory): Give it a value.
(find-gc-source-files): Update some names.
(trace-call-tree): Simplify and update. Avoid predictable temp-file names.
--- emacs-23.4-orig/lisp/emacs-lisp/find-gc.el
+++ emacs-23.4/lisp/emacs-lisp/find-gc.el
@@ -24,14 +24,15 @@
;; Produce in find-gc-unsafe-list the set of all functions that may invoke GC.
;; This expects the Emacs sources to live in find-gc-source-directory.
-;; It creates a temporary working directory /tmp/esrc.
;;; Code:
(defvar find-gc-unsafe-list nil
"The list of unsafe functions is placed here by `find-gc-unsafe'.")
-(defvar find-gc-source-directory)
+(defvar find-gc-source-directory
+ (file-name-as-directory (expand-file-name "src" source-directory))
+ "Directory containing Emacs C sources.")
(defvar find-gc-subrs-callers nil
"Alist of users of subrs, from GC testing.
@@ -60,14 +61,14 @@
"indent.c" "search.c" "regex.c" "undo.c"
"alloc.c" "data.c" "doc.c" "editfns.c"
"callint.c" "eval.c" "fns.c" "print.c" "lread.c"
- "abbrev.c" "syntax.c" "unexec.c"
+ "syntax.c" "unexec.c"
"bytecode.c" "process.c" "callproc.c" "doprnt.c"
- "x11term.c" "x11fns.c"))
+ "xterm.c" "xfns.c"))
(defun find-gc-unsafe ()
"Return a list of unsafe functions--that is, which can call GC.
-Also store it in `find-gc-unsafe'."
+Also store it in `find-gc-unsafe-list'."
(trace-call-tree nil)
(trace-use-tree)
(find-unsafe-funcs 'Fgarbage_collect)
@@ -103,47 +104,38 @@
-(defun trace-call-tree (&optional already-setup)
+(defun trace-call-tree (&optional ignored)
(message "Setting up directories...")
- (or already-setup
- (progn
- ;; Gee, wouldn't a built-in "system" function be handy here.
- (call-process "csh" nil nil nil "-c" "rm -rf /tmp/esrc")
- (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc")
- (call-process "csh" nil nil nil "-c"
- (format "ln -s %s/*.[ch] /tmp/esrc"
- find-gc-source-directory))))
- (with-current-buffer (get-buffer-create "*Trace Call Tree*")
- (setq find-gc-subrs-called nil)
- (let ((case-fold-search nil)
- (files find-gc-source-files)
- name entry)
- (while files
- (message "Compiling %s..." (car files))
- (call-process "csh" nil nil nil "-c"
- (format "gcc -dr -c /tmp/esrc/%s -o /dev/null"
- (car files)))
- (erase-buffer)
- (insert-file-contents (concat "/tmp/esrc/" (car files) ".rtl"))
- (while (re-search-forward ";; Function \\|(call_insn " nil t)
- (if (= (char-after (- (point) 3)) ?o)
- (progn
- (looking-at "[a-zA-Z0-9_]+")
- (setq name (intern (buffer-substring (match-beginning 0)
- (match-end 0))))
- (message "%s : %s" (car files) name)
- (setq entry (list name)
- find-gc-subrs-called (cons entry find-gc-subrs-called)))
- (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"")
+ (setq find-gc-subrs-called nil)
+ (let ((case-fold-search nil)
+ (default-directory find-gc-source-directory)
+ (files find-gc-source-files)
+ name entry rtlfile)
+ (dolist (file files)
+ (message "Compiling %s..." file)
+ (call-process "gcc" nil nil nil "-I" "." "-I" "../lib"
+ "-fdump-rtl-expand" "-o" null-device "-c" file)
+ (setq rtlfile
+ (file-expand-wildcards (format "%s.*.expand" file) t))
+ (if (/= 1 (length rtlfile))
+ (message "Error compiling `%s'?" file)
+ (with-temp-buffer
+ (insert-file-contents (setq rtlfile (car rtlfile)))
+ (delete-file rtlfile)
+ (while (re-search-forward ";; Function \\|(call_insn " nil t)
+ (if (= (char-after (- (point) 3)) ?o)
(progn
- (setq name (intern (buffer-substring (match-beginning 1)
- (match-end 1))))
- (or (memq name (cdr entry))
- (setcdr entry (cons name (cdr entry))))))))
- (delete-file (concat "/tmp/esrc/" (car files) ".rtl"))
- (setq files (cdr files)))))
-)
-
+ (looking-at "[a-zA-Z0-9_]+")
+ (setq name (intern (match-string 0)))
+ (message "%s : %s" (car files) name)
+ (setq entry (list name)
+ find-gc-subrs-called
+ (cons entry find-gc-subrs-called)))
+ (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"")
+ (progn
+ (setq name (intern (match-string 1)))
+ (or (memq name (cdr entry))
+ (setcdr entry (cons name (cdr entry)))))))))))))
(defun trace-use-tree ()
(setq find-gc-subrs-callers (mapcar 'list (mapcar 'car find-gc-subrs-called)))
|
GitWeb