commit/XEmacs: kehoea: Co-operate with the byte-optimizer in the bytecomp.el labels implementation.

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&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. 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&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 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