1 new commit in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/e9c3fe82127d/
changeset: e9c3fe82127d
user: kehoea
date: 2012-05-05 21:48:24
summary: Co-operate with the byte-optimizer in the bytecomp.el labels implementation.
lisp/ChangeLog addition:
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Co-operate with the byte-optimizer in the bytecomp.el labels
implementation, don't work against it.
* byte-optimize.el:
* byte-optimize.el (byte-compile-inline-expand):
Call #'byte-compile-unfold-lambda explicitly here, don't assume
that the byte-optimizer will do it.
* byte-optimize.el (byte-compile-unfold-lambda):
Call #'byte-optimize-body on the body, don't just mapcar
#'byte-optimize-form along it.
* byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
form.
* byte-optimize.el (byte-optimize-form-code-walker):
Descend lambda expressions, defun, and defmacro, relevant for
lexically-oriented operators like #'labels.
* byte-optimize.el (byte-optimize-body): Only return a non-eq
object if we've actually optimized something
* bytecomp.el (byte-compile-initial-macro-environment):
In the labels implementation, work with the byte optimizer, not
against it; warn when labels are defined but not used,
automatically inline labels that are used only once.
* bytecomp.el (byte-recompile-directory):
No need to wrap #'byte-compile-report-error in a lambda with
#'call-with-condition-handler here.
* bytecomp.el (byte-compile-form):
Don't inline compiled-function objects, they're probably labels.
* bytecomp.el (byte-compile-funcall):
No longer inline lambdas, trust the byte optimizer to have done it
properly, even for labels.
* cl-extra.el (cl-macroexpand-all):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* cl-macs.el (cl-do-proclaim):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* gui.el (make-gui-button):
When referring to the #'gui-button-action label, quote it using
function, otherwise there's a warning from the byte compiler.
affected #: 6 files
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r
e9c3fe82127d71edcf53529e7227785809922ff9 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,44 @@
+2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Co-operate with the byte-optimizer in the bytecomp.el labels
+ implementation, don't work against it.
+
+ * byte-optimize.el:
+ * byte-optimize.el (byte-compile-inline-expand):
+ Call #'byte-compile-unfold-lambda explicitly here, don't assume
+ that the byte-optimizer will do it.
+ * byte-optimize.el (byte-compile-unfold-lambda):
+ Call #'byte-optimize-body on the body, don't just mapcar
+ #'byte-optimize-form along it.
+ * byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
+ form.
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ Descend lambda expressions, defun, and defmacro, relevant for
+ lexically-oriented operators like #'labels.
+ * byte-optimize.el (byte-optimize-body): Only return a non-eq
+ object if we've actually optimized something
+ * bytecomp.el (byte-compile-initial-macro-environment):
+ In the labels implementation, work with the byte optimizer, not
+ against it; warn when labels are defined but not used,
+ automatically inline labels that are used only once.
+ * bytecomp.el (byte-recompile-directory):
+ No need to wrap #'byte-compile-report-error in a lambda with
+ #'call-with-condition-handler here.
+ * bytecomp.el (byte-compile-form):
+ Don't inline compiled-function objects, they're probably labels.
+ * bytecomp.el (byte-compile-funcall):
+ No longer inline lambdas, trust the byte optimizer to have done it
+ properly, even for labels.
+ * cl-extra.el (cl-macroexpand-all):
+ Treat labels established by the byte compiler distinctly from
+ those established by cl-macs.el.
+ * cl-macs.el (cl-do-proclaim):
+ Treat labels established by the byte compiler distinctly from
+ those established by cl-macs.el.
+ * gui.el (make-gui-button):
+ When referring to the #'gui-button-action label, quote it using
+ function, otherwise there's a warning from the byte compiler.
+
2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net>
Remove some redundant functions; turn other utility functions into
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r
e9c3fe82127d71edcf53529e7227785809922ff9 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el
+++ b/lisp/byte-optimize.el
@@ -284,19 +284,10 @@
(error "file \"%s\" didn't define \"%s\"" (nth 1 fn)
name))
(if (symbolp fn)
(byte-compile-inline-expand (cons fn (cdr form)))
- (if (compiled-function-p fn)
- (progn
- (fetch-bytecode fn)
- (cons (list 'lambda (compiled-function-arglist fn)
- (list 'byte-code
- (compiled-function-instructions fn)
- (compiled-function-constants fn)
- (compiled-function-stack-depth fn)))
- (cdr form)))
- (if (eq (car-safe fn) 'lambda)
- (cons fn (cdr form))
- ;; Give up on inlining.
- form))))))
+ (if (or (eq (car-safe fn) 'lambda) (compiled-function-p fn))
+ (byte-compile-unfold-lambda (cons fn (cdr form)))
+ ;; Give up on inlining.
+ form)))))
;;; ((lambda ...) ...)
;;;
@@ -354,7 +345,7 @@
(byte-compile-warn
"attempt to open-code %s with too many arguments" name))
form)
- (setq body (mapcar 'byte-optimize-form body))
+ (setq body (byte-optimize-body body nil))
(let ((newform
(if bindings
(cons 'let (cons (nreverse bindings) body))
@@ -363,6 +354,15 @@
newform)))))
+(defun byte-optimize-lambda (form)
+ (let* ((offset 2) (body (nthcdr offset form)))
+ (if (stringp (car body)) (setq body (nthcdr (incf offset) form)))
+ (if (eq 'interactive (car-safe (car body)))
+ (setq body (nthcdr (incf offset) form)))
+ (if (eq body (setq body (byte-optimize-body body nil)))
+ form
+ (nconc (subseq form 0 offset) body))))
+
;;; implementing source-level optimizers
(defun byte-optimize-form-code-walker (form for-effect)
@@ -390,9 +390,19 @@
(and (nth 1 form)
(not for-effect)
form))
- ((or (compiled-function-p fn)
- (eq 'lambda (car-safe fn)))
- (byte-compile-unfold-lambda form))
+ ((eq fn 'function)
+ (when (cddr form)
+ (byte-compile-warn "malformed function form: %S" form))
+ (cond
+ (for-effect nil)
+ ((and (eq (car-safe (cadr form)) 'lambda)
+ (not (eq (cadr form) (setq tmp (byte-optimize-lambda
+ (cadr form))))))
+ (list fn tmp))
+ (t form)))
+ ((and (eq 'lambda (car-safe fn))
+ (not (eq form (setq form (byte-compile-unfold-lambda form)))))
+ form)
((memq fn '(let let*))
;; recursively enter the optimizer for the bindings and body
;; of a let or let*. This for depth-firstness: forms that
@@ -490,11 +500,19 @@
(prin1-to-string form))
nil)
- ((memq fn '(defun defmacro function
- condition-case save-window-excursion))
- ;; These forms are compiled as constants or by breaking out
- ;; all the subexpressions and compiling them separately.
- form)
+ ((memq fn '(defun defmacro))
+ (if (eq (setq tmp (cons 'lambda (cddr form)))
+ (setq tmp (byte-optimize-lambda tmp)))
+ (cons fn (cdr tmp))
+ form))
+
+ ((eq fn 'condition-case)
+ (list* fn (nth 1 form) (byte-optimize-form (nth 2 form) for-effect)
+ (mapcar #'(lambda (handler)
+ (cons (car handler)
+ (byte-optimize-body (cdr handler)
+ for-effect)))
+ (cdddr form))))
((eq fn 'unwind-protect)
;; the "protected" part of an unwind-protect is compiled (and thus
@@ -524,8 +542,11 @@
byte-compile-macro-environment))))
(byte-optimize-form form for-effect))
+ ((compiled-function-p fn)
+ (cons fn (mapcar #'byte-optimize-form (cdr form))))
+
((not (symbolp fn))
- (byte-compile-warn "%s is a malformed function" (prin1-to-string fn))
+ (byte-compile-warn "%S is a malformed function" fn)
form)
;; Support compiler macros as in cl.el.
@@ -593,14 +614,17 @@
;; all-for-effect is true. Returns a new list of forms.
(let ((rest forms)
(result nil)
+ (modified nil)
fe new)
(while rest
(setq fe (or all-for-effect (cdr rest)))
(setq new (and (car rest) (byte-optimize-form (car rest) fe)))
(if (or new (not fe))
- (setq result (cons new result)))
+ (setq result (cons new result)
+ modified (or modified (not (eq new (car rest)))))
+ (setq modified t))
(setq rest (cdr rest)))
- (nreverse result)))
+ (if modified (nreverse result) forms)))
;;; some source-level optimizers
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r
e9c3fe82127d71edcf53529e7227785809922ff9 lisp/bytecomp.el
--- a/lisp/bytecomp.el
+++ b/lisp/bytecomp.el
@@ -522,150 +522,222 @@
#'(lambda (form &optional read-only)
(list wrapper form))))
(labels
- . ,#'(lambda (bindings &rest body)
- (let* ((names (mapcar 'car bindings))
- (lambdas (mapcar
- (function*
- (lambda ((name . definition))
- (cons 'lambda (cdr (cl-transform-lambda
- definition name)))))
- bindings))
- (placeholders
- (mapcar #'(lambda (lambda)
- (make-byte-code (second lambda) "\xc0\x87"
- ;; This list is used for
- ;; the byte-optimize
- ;; property, if the
- ;; function is to be
- ;; inlined. See
- ;; cl-do-proclaim.
- (vector nil) 1))
- lambdas))
- (byte-compile-macro-environment
- (pairlis names (mapcar
- #'(lambda (placeholder)
- `(lambda (&rest cl-labels-args)
- ;; Be careful not to quote
- ;; PLACEHOLDER, otherwise
- ;; byte-optimize-funcall inlines
- ;; it.
- (list* 'funcall ,placeholder
- cl-labels-args)))
- placeholders)
- byte-compile-macro-environment))
- (gensym (gensym)))
- (labels
- ((byte-compile-transform-labels (form names lambdas
- placeholders)
- (let* ((inline
- (mapcan
- #'(lambda (name placeholder lambda)
- (and
- (eq
- (getf (aref
- (compiled-function-constants
- placeholder) 0)
- 'byte-optimizer)
- 'byte-compile-inline-expand)
- `(((function ,placeholder)
- ,(byte-compile-lambda lambda name)
- (function ,lambda)))))
- names placeholders lambdas))
- (compiled
- (mapcar* #'byte-compile-lambda
- (if (not inline)
- lambdas
- ;; See further down for the
- ;; rationale of the sublis calls.
- (sublis (pairlis
- (mapcar #'cadar inline)
- (mapcar #'third inline))
- (sublis
- (pairlis
- (mapcar #'car inline)
- (mapcar #'second inline))
- lambdas :test #'equal)
-:test #'eq))
- names))
- elt)
- (mapc #'(lambda (placeholder function)
- (nsubst function placeholder compiled
-:test #'eq
-:descend-structures t))
- placeholders compiled)
- (when inline
- (dolist (triad inline)
- (nsubst (setq elt (elt compiled
- (position (cadar triad)
- placeholders)))
- (second triad) compiled :test #'eq
-:descend-structures t)
- (setf (second triad) elt))
- ;; For inlined labels: first, replace uses of
- ;; the placeholder in places where it's not an
- ;; evident, explicit funcall (that is, where
- ;; it is not to be inlined) with the compiled
- ;; function:
- (setq form (sublis
- (pairlis (mapcar #'car inline)
- (mapcar #'second inline))
- form :test #'equal)
- ;; Now replace uses of the placeholder
- ;; where it is an evident funcall with the
- ;; lambda, quoted as a function, to allow
- ;; byte-optimize-funcall to do its
- ;; thing. Note that the lambdas still have
- ;; the placeholders, so there's no risk
- ;; of recursive inlining.
- form (sublis (pairlis
- (mapcar #'cadar inline)
- (mapcar #'third inline))
- form :test #'eq)))
- (sublis (pairlis placeholders compiled) form
-:test #'eq))))
- (put gensym 'byte-compile
- #'(lambda (form)
- (let* ((names (cadr (cl-pop2 form)))
- (lambdas (mapcar #'cadr (cdr (pop form))))
- (placeholders (cadr (pop form))))
- (byte-compile-body-do-effect
- (byte-compile-transform-labels form names
- lambdas
- placeholders)))))
- (put gensym 'byte-hunk-handler
- #'(lambda (form)
- (let* ((names (cadr (cl-pop2 form)))
- (lambdas (mapcar #'cadr (cdr (pop form))))
- (placeholders (cadr (pop form))))
- (byte-compile-file-form
- (cons 'progn
- (byte-compile-transform-labels
- form names lambdas placeholders))))))
- (setq body
- (cl-macroexpand-all `(,gensym ',names (list ,@lambdas)
- ',placeholders ,@body)
- byte-compile-macro-environment))
- (if (position 'lambda (mapcar #'(lambda (object)
- (car-safe (cdr-safe
- object)))
- (cdr (third body)))
- :key #'car-safe :test-not #'eq)
- ;; #'lexical-let has worked its magic, not all the
- ;; lambdas are lambdas. Give up on pre-compiling the
- ;; labels.
- (setq names (mapcar #'copy-symbol names)
- lambdas (cdr (third body))
- body (sublis (pairlis placeholders names)
- (nthcdr 4 body) :test #'eq)
- lambdas (sublis (pairlis placeholders names)
- lambdas :test #'eq)
- body (cl-macroexpand-all
- `(lexical-let
- ,names
- (setf ,@(mapcan #'list names lambdas))
- ,@body)
- byte-compile-macro-environment))
- body)))))
+ . ,(symbol-macrolet ((wrapper '#:labels))
+ (labels
+ ((cannot-inline-alist (placeholders lambdas)
+ (let ((inline
+ ;; What labels should be inline?
+ (remove-if-not
+ #'(lambda (placeholder)
+ (eq 'byte-compile-inline-expand
+ (get placeholder
+ 'byte-optimizer)))
+ placeholders)))
+ ;; Which of those labels--that should be
+ ;; inline--reference themeselves, or other labels that
+ ;; should be inline? Give a an alist mapping them to
+ ;; their data placeholders.
+ (mapcan
+ #'(lambda (placeholder lambda)
+ (and
+ (eq 'byte-compile-inline-expand
+ (get placeholder 'byte-optimizer))
+ (block find
+ (subst-if nil
+ #'(lambda (tree)
+ (if (memq tree inline)
+ (return-from find t)))
+ lambda)
+ nil)
+ `((,placeholder
+ . ,(get placeholder
+ 'byte-compile-data-placeholder)))))
+ placeholders lambdas)))
+ (destructure-labels (form for-effect)
+ (let* ((names (cadr (cl-pop2 form)))
+ (lambdas (mapcar #'cadr (cdr (pop form))))
+ (placeholders (cadr (pop form)))
+ (cannot-inline-alist (cannot-inline-alist
+ placeholders lambdas))
+ (lambdas (sublis cannot-inline-alist
+ lambdas :test #'eq)))
+ ;; Used specially, note the bindings in our callers.
+ (setq byte-compile-function-environment
+ (pairlis
+ (mapcar #'cdr cannot-inline-alist)
+ (mapcar #'car cannot-inline-alist)
+ (pairlis placeholders lambdas
+ byte-compile-function-environment)))
+ (if (memq byte-optimize '(t source))
+ (setq lambdas
+ (mapcar #'cadr (mapcar #'byte-optimize-form
+ lambdas))
+ form (byte-optimize-body form for-effect)))
+ (values placeholders lambdas names form)))
+ (warn-about-unused-labels (names placeholders)
+ (when (memq 'unused-vars byte-compile-warnings)
+ (loop
+ for placeholder in placeholders
+ for name in names
+ if (eql 0 (+ (get placeholder
+ 'byte-compile-label-calls 0)
+ (get (get placeholder
+ 'byte-compile-data-placeholder
+ '#:no-such-data-placeholder)
+ 'byte-compile-label-calls 0)))
+ do (byte-compile-warn
+ "label %s bound but not referenced" name))))
+ (byte-compile-transform-labels (form names lambdas
+ placeholders)
+ (let ((compiled
+ (mapcar* #'byte-compile-lambda lambdas names)))
+ (warn-about-unused-labels names placeholders)
+ (mapc #'(lambda (placeholder function)
+ (nsubst function placeholder compiled
+:test #'eq
+:descend-structures t)
+ (nsubst function
+ (get placeholder
+ 'byte-compile-data-placeholder)
+ compiled :test #'eq
+:descend-structures t))
+ placeholders compiled)
+ (sublis (pairlis
+ placeholders compiled
+ (pairlis
+ (mapcar*
+ #'get placeholders
+ (load-time-value
+ (let ((list
+ (list
+ 'byte-compile-data-placeholder)))
+ (nconc list list))))
+ compiled))
+ form :test #'eq))))
+ (put wrapper 'byte-compile
+ #'(lambda (form)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment))
+ (multiple-value-bind
+ (placeholders lambdas names form)
+ (destructure-labels form for-effect)
+ (byte-compile-body-do-effect
+ (byte-compile-transform-labels form names
+ lambdas
+ placeholders))))))
+ (put wrapper 'byte-hunk-handler
+ #'(lambda (form)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment))
+ (multiple-value-bind
+ (placeholders lambdas names form)
+ (destructure-labels form t)
+ (byte-compile-file-form
+ (cons 'progn
+ (byte-compile-transform-labels
+ form names lambdas placeholders)))))))
+ (put wrapper 'cl-compiler-macro
+ ;; This is only used when optimizing code.
+ #'(lambda (form &rest ignore)
+ (let ((byte-compile-function-environment
+ byte-compile-function-environment)
+ byte-optimize-form retry)
+ (multiple-value-bind
+ (placeholders lambdas)
+ (destructure-labels form for-effect)
+ ;; Optimize most of the form, in passing
+ ;; expanding macros.
+ (setq byte-optimize-form
+ (mapcar #'byte-optimize-form
+ (list* (nth 1 form) `(list ,@lambdas)
+ (cdddr form))))
+ ;; It may be reasonable to inline any labels
+ ;; used only once.
+ (dolist (placeholder placeholders)
+ (and
+ (not (eq 'byte-compile-inline-expand
+ (get placeholder 'byte-optimizer)))
+ (eql 0 (get (get placeholder
+ 'byte-compile-data-placeholder
+ '#:no-such-data-placeholder)
+ 'byte-compile-label-calls 0))
+ (eql 1 (get placeholder
+ 'byte-compile-label-calls 0))
+ (progn
+ (byte-compile-log
+ "label %s is used only once, inlining it"
+ placeholder)
+ (setq retry t)
+ (cl-do-proclaim `(inline ,placeholder) t))))
+ (when retry
+ (multiple-value-setq
+ (placeholders lambdas)
+ (destructure-labels form for-effect))
+ (setq byte-optimize-form
+ (mapcar #'byte-optimize-form
+ (list* (nth 1 form)
+ `(list ,@lambdas)
+ (cdddr form)))))
+ (if (equal (cdr form) byte-optimize-form)
+ form
+ (cons (car form) byte-optimize-form)))))))
+ #'(lambda (bindings &rest body)
+ (let* ((names (mapcar 'car bindings))
+ (lambdas (mapcar
+ (function*
+ (lambda ((name . definition))
+ `#'(lambda ,@(cdr (cl-transform-lambda
+ definition name)))))
+ bindings))
+ (placeholders (mapcar #'copy-symbol names))
+ (byte-compile-macro-environment
+ (pairlis names
+ (mapcar
+ #'(lambda (placeholder)
+ `(lambda (&rest byte-compile-labels-args)
+ (put
+ ',placeholder
+ 'byte-compile-label-calls
+ (1+ (get ',placeholder
+ 'byte-compile-label-calls
+ 0)))
+ (cons ',placeholder
+ byte-compile-labels-args)))
+ placeholders)
+ byte-compile-macro-environment)))
+ ;; Tell the macroexpansion code what symbol to use when
+ ;; expanding #'FUNCTION-NAME:
+ (mapc #'put placeholders
+ (load-time-value
+ (let ((list (list 'byte-compile-data-placeholder)))
+ (nconc list list)))
+ (mapcar #'copy-symbol names))
+ (setq body
+ (cl-macroexpand-all
+ `(,wrapper ',names (list ,@lambdas) ',placeholders
+ ,@body)
+ byte-compile-macro-environment))
+ (if (position 'lambda (mapcar #'(lambda (object)
+ (car-safe (cdr-safe
+ object)))
+ (cdr (third body)))
+:key #'car-safe :test-not #'eq)
+ ;; #'lexical-let has worked its magic, not all the
+ ;; lambdas are lambdas. Give up on pre-compiling the
+ ;; labels.
+ (setq names (mapcar #'copy-symbol names)
+ lambdas (cdr (third body))
+ body (sublis (pairlis placeholders names)
+ (nthcdr 4 body) :test #'eq)
+ lambdas (sublis (pairlis placeholders names)
+ lambdas :test #'eq)
+ body (cl-macroexpand-all
+ `(lexical-let
+ ,names
+ (setf ,@(mapcan #'list names lambdas))
+ ,@body)
+ byte-compile-macro-environment))
+ body)))))
(flet .
,#'(lambda (bindings &rest body)
(let* ((names (mapcar 'car bindings))
@@ -1642,8 +1714,7 @@
(unwind-protect
(call-with-condition-handler
- #'(lambda (error-info)
- (byte-compile-report-error error-info))
+ #'byte-compile-report-error
#'(lambda ()
(progn ,@body)))
;; Always set point in log to start of interesting output.
@@ -3010,8 +3081,7 @@
(if (memq 'callargs byte-compile-warnings)
(byte-compile-callargs-warn form))
(byte-compile-normal-call form))))
- ((and (or (compiled-function-p (car form))
- (eq (car-safe (car form)) 'lambda))
+ ((and (eq (car-safe (car form)) 'lambda)
;; if the form comes out the same way it went in, that's
;; because it was malformed, and we couldn't unfold it.
(not (eq form (setq form (byte-compile-unfold-lambda form)))))
@@ -3048,9 +3118,8 @@
(map nil
(function*
(lambda ((function . nargs))
- ;; Document that the car of OBJECT, a symbol, describes a function
- ;; taking keyword arguments from the argument index described by
- ;; the cdr of OBJECT.
+ ;; Document that FUNCTION, a symbol, describes a function taking
+ ;; keyword arguments from the argument index described by NARGS.
(put function 'byte-compile-keyword-start nargs)))
'((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3)
(count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3)
@@ -4175,34 +4244,8 @@
(byte-compile-constp (second form)))
(byte-compile-callargs-warn (cons (cl-const-expr-val (second form))
(nthcdr 2 form))))
- (if (and byte-optimize
- (eq 'function (car-safe (cadr form)))
- (eq 'lambda (car-safe (cadadr form)))
- (or
- (not (eq (setq form (cons (cadadr form) (cddr form)))
- (setq form (byte-compile-unfold-lambda form))))
- (prog1 nil (setq form `(funcall #',(car form) ,@(cdr form))))))
- ;; The byte-compile part of the #'labels implementation, above,
- ;; happens after macroexpansion and after the source optimizer has
- ;; done its thing. When labels are to be made inline we can have code
- ;; that looks like (funcall #'(lambda ...) ...), when the code that
- ;; the optimizer saw looked like (funcall #<compiled-function ...>
- ;; ...).
- ;;
- ;; So, the optimizer doesn't have the opportunity to transform the
- ;; former to (let (...) ...), and it's reasonable to do that here (since
- ;; the labels implementation doesn't change other code that would need
- ;; running through the optimizer; the lambda itself has already been
- ;; through the optimizer).
- ;;
- ;; Equally reasonable, and conceptually a bit clearer, would be to do
- ;; the transformation to (funcall #'(lambda ...) ...) in the
- ;; byte-optimizer, breaking most of the #'sublis calls out of the
- ;; byte-compile method.
- (byte-compile-form form)
- (mapc 'byte-compile-form (cdr form))
- (byte-compile-out 'byte-call (length (cdr (cdr form))))))
-
+ (mapc 'byte-compile-form (cdr form))
+ (byte-compile-out 'byte-call (length (cdr (cdr form)))))
(defun byte-compile-let (form)
;; First compute the binding values in the old scope.
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r
e9c3fe82127d71edcf53529e7227785809922ff9 lisp/cl-extra.el
--- a/lisp/cl-extra.el
+++ b/lisp/cl-extra.el
@@ -569,19 +569,26 @@
;; This is a bit of a hack; special-case symbols with bindings as
;; labels.
(let ((found (cdr (assq (cadr form) env))))
- (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
- (if (consp (nth 2 (nth 2 found)))
- ;; It's a cons; this is the implementation of
- ;; labels in cl-macs.el.
- (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)
- ;; It's an atom, almost certainly a compiled function;
- ;; we're using the implementation of labels in
- ;; bytecomp.el. Quote it with FUNCTION so that code can
- ;; tell uses as data apart from the uses with funcall,
- ;; where it's unquoted. #### We should warn if (car form)
- ;; above is quote, rather than function.
- (list 'function (nth 2 (nth 2 found))))
- form))))
+ (cond
+ ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
+ ;; This is the implementation of labels in cl-macs.el.
+ (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env))
+ ((and (consp found) (eq (nth 1 (nth 1 found))
+ 'byte-compile-labels-args))
+ ;; We're using the implementation of labels in
+ ;; bytecomp.el. Quote its data-placeholder with FUNCTION so
+ ;; that code can tell uses as data apart from the uses with
+ ;; funcall.
+ (unless (eq 'function (car form))
+ (byte-compile-warn
+ "deprecated: '%s, use #'%s instead to quote it as a
function"
+ (cadr form) (cadr form)))
+ (setq found (get (nth 1 (nth 1 (nth 3 found)))
+ 'byte-compile-data-placeholder))
+ (put found 'byte-compile-label-calls
+ (1+ (get found 'byte-compile-label-calls 0)))
+ (list 'function found))
+ (t form)))))
((memq (car form) '(defun defmacro))
(list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
((and (eq (car form) 'progn) (not (cddr form)))
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r
e9c3fe82127d71edcf53529e7227785809922ff9 lisp/cl-macs.el
--- a/lisp/cl-macs.el
+++ b/lisp/cl-macs.el
@@ -1863,39 +1863,40 @@
byte-compile-bound-variables))))
((eq (car-safe spec) 'inline)
- (while (setq spec (cdr spec))
- (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
- (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
- (atom (setq assq (nth 2 (nth 2 assq)))))
- ;; It's a label, and we're using the labels
- ;; implementation in bytecomp.el. Tell the compiler
- ;; to inline it, don't mark the symbol to be inlined
- ;; globally.
- (setf (getf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer)
- 'byte-compile-inline-expand)
- (or (memq (get (car spec) 'byte-optimizer)
- '(nil byte-compile-inline-expand))
- (error
- "%s already has a byte-optimizer, can't make it inline"
- (car spec)))
- (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))))
+ (while (setq spec (cdr spec))
+ (let* ((assq (cdr (assq (car spec)
+ byte-compile-macro-environment)))
+ (symbol (if (and (consp assq)
+ (eq (nth 1 (nth 1 assq))
+ 'byte-compile-labels-args))
+ ;; It's a label, and we're using the labels
+ ;; implementation in bytecomp.el. Tell the
+ ;; compiler to inline it, don't mark the
+ ;; symbol to be inlined globally.
+ (nth 1 (nth 1 (nth 3 assq)))
+ (car spec))))
+ (or (memq (get symbol 'byte-optimizer)
+ '(nil byte-compile-inline-expand))
+ (error
+ "%s already has a byte-optimizer, can't make it inline"
+ symbol))
+ (put symbol 'byte-optimizer 'byte-compile-inline-expand))))
((eq (car-safe spec) 'notinline)
(while (setq spec (cdr spec))
- (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
- (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
- (atom (setq assq (nth 2 (nth 2 assq)))))
- ;; It's a label, and we're using the labels
- ;; implementation in bytecomp.el. Tell the compiler
- ;; not to inline it.
- (if (eq 'byte-compile-inline-expand
- (getf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer))
- (remf (aref (compiled-function-constants assq) 0)
- 'byte-optimizer))
- (if (eq (get (car spec) 'byte-optimizer)
- 'byte-compile-inline-expand)
- (put (car spec) 'byte-optimizer nil))))))
+ (let* ((assq (cdr (assq (car spec)
+ byte-compile-macro-environment)))
+ (symbol (if (and (consp assq)
+ (eq (nth 1 (nth 1 assq))
+ 'byte-compile-labels-args))
+ ;; It's a label, and we're using the labels
+ ;; implementation in bytecomp.el. Tell the
+ ;; compiler not to inline it, don't mark the
+ ;; symbol to be notinline globally.
+ (nth 1 (nth 1 (nth 3 assq)))
+ (car spec))))
+ (if (eq (get symbol 'byte-optimizer)
+ 'byte-compile-inline-expand)
+ (put symbol 'byte-optimizer nil)))))
((eq (car-safe spec) 'optimize)
(let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
'((0 . nil) (1 . t) (2 . t) (3 . t))))
diff -r b7ae5f44b95017d6cee969e8353e73eb16a62f01 -r
e9c3fe82127d71edcf53529e7227785809922ff9 lisp/gui.el
--- a/lisp/gui.el
+++ b/lisp/gui.el
@@ -105,10 +105,10 @@
(vector 'button
:descriptor string
:face 'gui-button-face
-:callback-ex `(lambda (image-instance event)
- (gui-button-action image-instance
- (quote ,action)
- (quote ,user-data))))))
+:callback-ex
+ `(lambda (image-instance event)
+ (funcall ,#'gui-button-action image-instance ',action
+ ',user-data)))))
(defun insert-gui-button (button &optional pos buffer)
"Insert GUI button BUTTON at POS in BUFFER."
Repository URL:
https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from
bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches