APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1336247304 -3600 # Node ID e9c3fe82127d71edcf53529e7227785809922ff9 # Parent b7ae5f44b95017d6cee969e8353e73eb16a62f01 Co-operate with the byte-optimizer in the bytecomp.el labels implementation. lisp/ChangeLog addition: 2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net&gt; 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. diff -r b7ae5f44b950 -r e9c3fe82127d lisp/ChangeLog --- a/lisp/ChangeLog Sat May 05 18:42:00 2012 +0100 +++ b/lisp/ChangeLog Sat May 05 20:48:24 2012 +0100 ＠＠ -1,3 +1,44 ＠＠ +2012-05-05 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + 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&gt; Remove some redundant functions; turn other utility functions into diff -r b7ae5f44b950 -r e9c3fe82127d lisp/byte-optimize.el --- a/lisp/byte-optimize.el Sat May 05 18:42:00 2012 +0100 +++ b/lisp/byte-optimize.el Sat May 05 20:48:24 2012 +0100 ＠＠ -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 b7ae5f44b950 -r e9c3fe82127d lisp/bytecomp.el --- a/lisp/bytecomp.el Sat May 05 18:42:00 2012 +0100 +++ b/lisp/bytecomp.el Sat May 05 20:48:24 2012 +0100 ＠＠ -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 b7ae5f44b950 -r e9c3fe82127d lisp/cl-extra.el --- a/lisp/cl-extra.el Sat May 05 18:42:00 2012 +0100 +++ b/lisp/cl-extra.el Sat May 05 20:48:24 2012 +0100 ＠＠ -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 b7ae5f44b950 -r e9c3fe82127d lisp/cl-macs.el --- a/lisp/cl-macs.el Sat May 05 18:42:00 2012 +0100 +++ b/lisp/cl-macs.el Sat May 05 20:48:24 2012 +0100 ＠＠ -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 b7ae5f44b950 -r e9c3fe82127d lisp/gui.el --- a/lisp/gui.el Sat May 05 18:42:00 2012 +0100 +++ b/lisp/gui.el Sat May 05 20:48:24 2012 +0100 ＠＠ -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." -- ‘Iodine deficiency was endemic in parts of the UK until, through what has been described as “an unplanned and accidental public health triumph”, iodine was added to cattle feed to improve milk production in the 1930s.’ (EN Pearce, Lancet, June 2011) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches