From 94d11cb5773b3b37367ee3c4885a374ff129d475 Mon Sep 17 00:00:00 2001 From: Igor Kuzmin Date: Thu, 10 Feb 2011 13:53:49 -0500 Subject: [PATCH] * lisp/emacs-lisp/cconv.el: New file. * lisp/emacs-lisp/bytecomp.el: Use cconv. (byte-compile-file-form, byte-compile): Call cconv-closure-convert-toplevel when requested. * lisp/server.el: * lisp/mpc.el: * lisp/emacs-lisp/pcase.el: * lisp/doc-view.el: * lisp/dired.el: Use lexical-binding. --- lisp/ChangeLog | 12 + lisp/dired.el | 1 + lisp/doc-view.el | 41 +- lisp/emacs-lisp/bytecomp.el | 11 +- lisp/emacs-lisp/cconv.el | 891 ++++++++++++++++++++++++++++++++++++ lisp/emacs-lisp/pcase.el | 18 +- lisp/mpc.el | 33 +- lisp/server.el | 344 +++++++------- 8 files changed, 1121 insertions(+), 230 deletions(-) create mode 100644 lisp/emacs-lisp/cconv.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7e3982a5a7..c137860013 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2011-02-10 Igor Kuzmin + + * emacs-lisp/cconv.el: New file. + * emacs-lisp/bytecomp.el: Use cconv. + (byte-compile-file-form, byte-compile): + Call cconv-closure-convert-toplevel when requested. + * server.el: + * mpc.el: + * emacs-lisp/pcase.el: + * doc-view.el: + * dired.el: Use lexical-binding. + 2010-12-27 Stefan Monnier * emacs-lisp/bytecomp.el (byte-compile-track-mouse): Don't use #'. diff --git a/lisp/dired.el b/lisp/dired.el index 02d855a0d3..f98ad641fe 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;; dired.el --- directory-browsing commands ;; Copyright (C) 1985-1986, 1992-1997, 2000-2011 diff --git a/lisp/doc-view.el b/lisp/doc-view.el index c67205fd52..4f8c338409 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs ;; Copyright (C) 2007-2011 Free Software Foundation, Inc. @@ -155,7 +156,7 @@ (defcustom doc-view-ghostscript-options '("-dSAFER" ;; Avoid security problems when rendering files from untrusted - ;; sources. + ;; sources. "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4" "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET") "A list of options to give to ghostscript." @@ -442,9 +443,7 @@ Can be `dvi', `pdf', or `ps'.") doc-view-current-converter-processes) ;; The PNG file hasn't been generated yet. (doc-view-pdf->png-1 doc-view-buffer-file-name file page - (lexical-let ((page page) - (win (selected-window)) - (file file)) + (let ((win (selected-window))) (lambda () (and (eq (current-buffer) (window-buffer win)) ;; If we changed page in the mean @@ -453,7 +452,7 @@ Can be `dvi', `pdf', or `ps'.") ;; Make sure we don't infloop. (file-readable-p file) (with-selected-window win - (doc-view-goto-page page)))))))) + (doc-view-goto-page page)))))))) (overlay-put (doc-view-current-overlay) 'help-echo (doc-view-current-info)))) @@ -713,8 +712,8 @@ Should be invoked when the cached images aren't up-to-date." (if (and doc-view-dvipdf-program (executable-find doc-view-dvipdf-program)) (doc-view-start-process "dvi->pdf" doc-view-dvipdf-program - (list dvi pdf) - callback) + (list dvi pdf) + callback) (doc-view-start-process "dvi->pdf" doc-view-dvipdfm-program (list "-o" pdf dvi) callback))) @@ -735,7 +734,7 @@ is named like ODF with the extension turned to pdf." (list (format "-r%d" (round doc-view-resolution)) (concat "-sOutputFile=" png) pdf-ps)) - (lexical-let ((resolution doc-view-resolution)) + (let ((resolution doc-view-resolution)) (lambda () ;; Only create the resolution file when it's all done, so it also ;; serves as a witness that the conversion is complete. @@ -780,7 +779,7 @@ Start by converting PAGES, and then the rest." ;; (almost) consecutive, but since in 99% of the cases, there'll be only ;; a single page anyway, and of the remaining 1%, few cases will have ;; consecutive pages, it's not worth the trouble. - (lexical-let ((pdf pdf) (png png) (rest (cdr pages))) + (let ((rest (cdr pages))) (doc-view-pdf->png-1 pdf (format png (car pages)) (car pages) (lambda () @@ -793,8 +792,8 @@ Start by converting PAGES, and then the rest." ;; not sufficient. (dolist (win (get-buffer-window-list (current-buffer) nil 'visible)) (with-selected-window win - (when (stringp (get-char-property (point-min) 'display)) - (doc-view-goto-page (doc-view-current-page))))) + (when (stringp (get-char-property (point-min) 'display)) + (doc-view-goto-page (doc-view-current-page))))) ;; Convert the rest of the pages. (doc-view-pdf/ps->png pdf png))))))) @@ -816,10 +815,8 @@ Start by converting PAGES, and then the rest." (ps ;; Doc is a PS, so convert it to PDF (which will be converted to ;; TXT thereafter). - (lexical-let ((pdf (expand-file-name "doc.pdf" - (doc-view-current-cache-dir))) - (txt txt) - (callback callback)) + (let ((pdf (expand-file-name "doc.pdf" + (doc-view-current-cache-dir)))) (doc-view-ps->pdf doc-view-buffer-file-name pdf (lambda () (doc-view-pdf->txt pdf txt callback))))) (dvi @@ -873,9 +870,7 @@ Those files are saved in the directory given by the function (dvi ;; DVI files have to be converted to PDF before Ghostscript can process ;; it. - (lexical-let - ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir)) - (png-file png-file)) + (let ((pdf (expand-file-name "doc.pdf" doc-view-current-cache-dir))) (doc-view-dvi->pdf doc-view-buffer-file-name pdf (lambda () (doc-view-pdf/ps->png pdf png-file))))) (odf @@ -1026,8 +1021,8 @@ have the page we want to view." (and (not (member pagefile prev-pages)) (member pagefile doc-view-current-files))) (with-selected-window win - (assert (eq (current-buffer) buffer)) - (doc-view-goto-page page)))))))) + (assert (eq (current-buffer) buffer)) + (doc-view-goto-page page)))))))) (defun doc-view-buffer-message () ;; Only show this message initially, not when refreshing the buffer (in which @@ -1470,9 +1465,9 @@ See the command `doc-view-mode' for more information on this mode." (when (not (eq major-mode 'doc-view-mode)) (doc-view-toggle-display)) (with-selected-window - (or (get-buffer-window (current-buffer) 0) - (selected-window)) - (doc-view-goto-page page))))) + (or (get-buffer-window (current-buffer) 0) + (selected-window)) + (doc-view-goto-page page))))) (provide 'doc-view) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index be3e1ed617..b258524b45 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -119,6 +119,7 @@ (require 'backquote) (require 'macroexp) +(require 'cconv) (eval-when-compile (require 'cl)) (or (fboundp 'defsubst) @@ -2238,6 +2239,8 @@ list that represents a doc string reference. (let ((byte-compile-current-form nil) ; close over this for warnings. bytecomp-handler) (setq form (macroexpand-all form byte-compile-macro-environment)) + (if lexical-binding + (setq form (cconv-closure-convert-toplevel form))) (cond ((not (consp form)) (byte-compile-keep-pending form)) ((and (symbolp (car form)) @@ -2585,9 +2588,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) ;; expand macros - (setq fun - (macroexpand-all fun - byte-compile-initial-macro-environment)) + (setq fun + (macroexpand-all fun + byte-compile-initial-macro-environment)) + (if lexical-binding + (setq fun (cconv-closure-convert-toplevel fun))) ;; get rid of the `function' quote added by the `lambda' macro (setq fun (cadr fun)) (setq fun (if macro diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el new file mode 100644 index 0000000000..ddcc7882d8 --- /dev/null +++ b/lisp/emacs-lisp/cconv.el @@ -0,0 +1,891 @@ +;;; -*- lexical-binding: t -*- +;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. + +;; licence stuff will be added later(I don't know yet what to write here) + +;;; Commentary: + +;; This takes a piece of Elisp code, and eliminates all free variables from +;; lambda expressions. The user entry points are cconv-closure-convert and +;; cconv-closure-convert-toplevel(for toplevel forms). +;; All macros should be expanded. +;; +;; Here is a brief explanation how this code works. +;; Firstly, we analyse the tree by calling cconv-analyse-form. +;; This function finds all mutated variables, all functions that are suitable +;; for lambda lifting and all variables captured by closure. It passes the tree +;; once, returning a list of three lists. +;; +;; Then we calculate the intersection of first and third lists returned by +;; cconv-analyse form to find all mutated variables that are captured by +;; closure. + +;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the +;; tree recursivly, lifting lambdas where possible, building closures where it +;; is needed and eliminating mutable variables used in closure. +;; +;; We do following replacements : +;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) +;; if the function is suitable for lambda lifting (if all calls are known) +;; +;; (function (lambda (v1 ...) ... fv ...)) => +;; (curry (lambda (env v1 ...) ... env ...) env) +;; if the function has only 1 free variable +;; +;; and finally +;; (function (lambda (v1 ...) ... fv1 fv2 ...)) => +;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2)) +;; if the function has 2 or more free variables +;; +;; If the function has no free variables, we don't do anything. +;; +;; If the variable is mutable(updated by setq), and it is used in closure +;; we wrap it's definition with list: (list var) and we also replace +;; var => (car var) wherever this variable is used, and also +;; (setq var value) => (setcar var value) where it is updated. +;; +;; If defun argument is closure mutable, we letbind it and wrap it's +;; definition with list. +;; (defun foo (... mutable-arg ...) ...) => +;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) +;; +;; +;; +;; +;; +;;; Code: + +(require 'pcase) +(eval-when-compile (require 'cl)) + +(defconst cconv-liftwhen 3 + "Try to do lambda lifting if the number of arguments + free variables +is less than this number.") +(defvar cconv-mutated + "List of mutated variables in current form") +(defvar cconv-captured + "List of closure captured variables in current form") +(defvar cconv-captured+mutated + "An intersection between cconv-mutated and cconv-captured lists.") +(defvar cconv-lambda-candidates + "List of candidates for lambda lifting") + + + +(defun cconv-freevars (form &optional fvrs) + "Find all free variables of given form. +Arguments: +-- FORM is a piece of Elisp code after macroexpansion. +-- FVRS(optional) is a list of variables already found. Used for recursive tree +traversal + +Returns a list of free variables." + ;; If a leaf in the tree is a symbol, but it is not a global variable, not a + ;; keyword, not 'nil or 't we consider this leaf as a variable. + ;; Free variables are the variables that are not declared above in this tree. + ;; For example free variables of (lambda (a1 a2 ..) body-forms) are + ;; free variables of body-forms excluding a1, a2 .. + ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are + ;; free variables of body-forms excluding v1, v2 ... + ;; and so on. + + ;; a list of free variables already found(FVRS) is passed in parameter + ;; to try to use cons or push where possible, and to minimize the usage + ;; of append + + ;; This function can contain duplicates(because we use 'append instead + ;; of union of two sets - for performance reasons). + (pcase form + (`(let ,varsvalues . ,body-forms) ; let special form + (let ((fvrs-1 '())) + (dolist (exp body-forms) + (setq fvrs-1 (cconv-freevars exp fvrs-1))) + (dolist (elm varsvalues) + (if (listp elm) + (setq fvrs-1 (delq (car elm) fvrs-1)) + (setq fvrs-1 (delq elm fvrs-1)))) + (setq fvrs (append fvrs fvrs-1)) + (dolist (exp varsvalues) + (when (listp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs)))) + fvrs)) + + (`(let* ,varsvalues . ,body-forms) ; let* special form + (let ((vrs '()) + (fvrs-1 '())) + (dolist (exp varsvalues) + (if (listp exp) + (progn + (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)) + (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) + (push (car exp) vrs)) + (progn + (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) + (push exp vrs)))) + (dolist (exp body-forms) + (setq fvrs-1 (cconv-freevars exp fvrs-1))) + (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) + (append fvrs fvrs-1))) + + (`((lambda . ,_) . ,_) ; first element is lambda expression + (dolist (exp `((function ,(car form)) . ,(cdr form))) + (setq fvrs (cconv-freevars exp fvrs))) fvrs) + + (`(cond . ,cond-forms) ; cond special form + (dolist (exp1 cond-forms) + (dolist (exp2 exp1) + (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs) + + (`(quote . ,_) fvrs) ; quote form + + (`(function . ((lambda ,vars . ,body-forms))) + (let ((functionform (cadr form)) (fvrs-1 '())) + (dolist (exp body-forms) + (setq fvrs-1 (cconv-freevars exp fvrs-1))) + (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1))) + (append fvrs fvrs-1))) ; function form + + (`(function . ,_) fvrs) ; same as quote + ;condition-case + (`(condition-case ,var ,protected-form . ,conditions-bodies) + (let ((fvrs-1 '())) + (setq fvrs-1 (cconv-freevars protected-form '())) + (dolist (exp conditions-bodies) + (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))) + (setq fvrs-1 (delq var fvrs-1)) + (append fvrs fvrs-1))) + + (`(,(and sym (or `defun `defconst `defvar)) . ,_) + ;; we call cconv-freevars only for functions(lambdas) + ;; defun, defconst, defvar are not allowed to be inside + ;; a function(lambda) + (error "Invalid form: %s inside a function" sym)) + + (`(,_ . ,body-forms) ; first element is a function or whatever + (dolist (exp body-forms) + (setq fvrs (cconv-freevars exp fvrs))) fvrs) + + (_ (if (or (not (symbolp form)) ; form is not a list + (special-variable-p form) + (memq form '(nil t)) + (keywordp form)) + fvrs + (cons form fvrs))))) + +;;;###autoload +(defun cconv-closure-convert (form &optional toplevel) + ;; cconv-closure-convert-rec has a lot of parameters that are + ;; whether useless for user, whether they should contain + ;; specific data like a list of closure mutables or the list + ;; of lambdas suitable for lifting. + ;; + ;; That's why this function exists. + "Main entry point for non-toplevel forms. +-- FORM is a piece of Elisp code after macroexpansion. +-- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST + +Returns a form where all lambdas don't have any free variables." + (let ((cconv-mutated '()) + (cconv-lambda-candidates '()) + (cconv-captured '()) + (cconv-captured+mutated '())) + ;; Analyse form - fill these variables with new information + (cconv-analyse-form form '() nil) + ;; Calculate an intersection of cconv-mutated and cconv-captured + (dolist (mvr cconv-mutated) + (when (memq mvr cconv-captured) ; + (push mvr cconv-captured+mutated))) + (cconv-closure-convert-rec + form ; the tree + '() ; + '() ; fvrs initially empty + '() ; envs initially empty + '() + toplevel))) ; true if the tree is a toplevel form + +;;;###autoload +(defun cconv-closure-convert-toplevel (form) + "Entry point for toplevel forms. +-- FORM is a piece of Elisp code after macroexpansion. + +Returns a form where all lambdas don't have any free variables." + ;; we distinguish toplevel forms to treat def(un|var|const) correctly. + (cconv-closure-convert form t)) + +(defun cconv-closure-convert-rec + (form emvrs fvrs envs lmenvs defs-are-legal) + ;; This function actually rewrites the tree. + "Eliminates all free variables of all lambdas in given forms. +Arguments: +-- FORM is a piece of Elisp code after macroexpansion. +-- LMENVS is a list of environments used for lambda-lifting. Initially empty. +-- EMVRS is a list that contains mutated variables that are visible +within current environment. +-- ENVS is an environment(list of free variables) of current closure. +Initially empty. +-- FVRS is a list of variables to substitute in each context. +Initially empty. +-- DEFS-ARE-LEGAL is a boolean variable, true if def(un|var|const) +can be used in this form(e.g. toplevel form) + +Returns a form where all lambdas don't have any free variables." + ;; What's the difference between fvrs and envs? + ;; Suppose that we have the code + ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) + ;; only the first occurrence of fvr should be replaced by + ;; (aref env ...). + ;; So initially envs and fvrs are the same thing, but when we descend to + ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? + ;; Because in envs the order of variables is important. We use this list + ;; to find the number of a specific variable in the environment vector, + ;; so we never touch it(unless we enter to the other closure). +;;(if (listp form) (print (car form)) form) + (pcase form + (`(,(and letsym (or `let* `let)) ,varsvalues . ,body-forms) + + ; let and let* special forms + (let ((body-forms-new '()) + (varsvalues-new '()) + ;; next for variables needed for delayed push + ;; because we should process + ;; before we change any arguments + (lmenvs-new '()) ;needed only in case of let + (emvrs-new '()) ;needed only in case of let + (emvr-push) ;needed only in case of let* + (lmenv-push)) ;needed only in case of let* + + (dolist (elm varsvalues) ;begin of dolist over varsvalues + (let (var value elm-new iscandidate ismutated) + (if (listp elm) ; (let (v1) ...) => (let ((v1 nil)) ...) + (progn + (setq var (car elm)) + (setq value (cadr elm))) + (setq var elm)) + + ;; Check if var is a candidate for lambda lifting + (let ((lcandid cconv-lambda-candidates)) + (while (and lcandid (not iscandidate)) + (when (and (eq (caar lcandid) var) + (eq (caddar lcandid) elm) + (eq (cadr (cddar lcandid)) form)) + (setq iscandidate t)) + (setq lcandid (cdr lcandid)))) + + ; declared variable is a candidate + ; for lambda lifting + (if iscandidate + (let* ((func (cadr elm)) ; function(lambda) itself + ; free variables + (fv (delete-dups (cconv-freevars func '()))) + (funcvars (append fv (cadadr func))) ;function args + (funcbodies (cddadr func)) ; function bodies + (funcbodies-new '())) + ; lambda lifting condition + (if (or (not fv) (< cconv-liftwhen (length funcvars))) + ; do not lift + (setq + elm-new + `(,var + ,(cconv-closure-convert-rec + func emvrs fvrs envs lmenvs nil))) + ; lift + (progn + (dolist (elm2 funcbodies) + (push ; convert function bodies + (cconv-closure-convert-rec + elm2 emvrs nil envs lmenvs nil) + funcbodies-new)) + (if (eq letsym 'let*) + (setq lmenv-push (cons var fv)) + (push (cons var fv) lmenvs-new)) + ; push lifted function + + (setq elm-new + `(,var + (function . + ((lambda ,funcvars . + ,(reverse funcbodies-new))))))))) + + ;declared variable is not a function + (progn + ;; Check if var is mutated + (let ((lmutated cconv-captured+mutated)) + (while (and lmutated (not ismutated)) + (when (and (eq (caar lmutated) var) + (eq (caddar lmutated) elm) + (eq (cadr (cddar lmutated)) form)) + (setq ismutated t)) + (setq lmutated (cdr lmutated)))) + (if ismutated + (progn ; declared variable is mutated + (setq elm-new + `(,var (list ,(cconv-closure-convert-rec + value emvrs + fvrs envs lmenvs nil)))) + (if (eq letsym 'let*) + (setq emvr-push var) + (push var emvrs-new))) + (progn + (setq + elm-new + `(,var ; else + ,(cconv-closure-convert-rec + value emvrs fvrs envs lmenvs nil))))))) + + ;; this piece of code below letbinds free + ;; variables of a lambda lifted function + ;; if they are redefined in this let + ;; example: + ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) + ;; Here we can not pass y as parameter because it is + ;; redefined. We add a (closed-y y) declaration. + ;; We do that even if the function is not used inside + ;; this let(*). The reason why we ignore this case is + ;; that we can't "look forward" to see if the function + ;; is called there or not. To treat well this case we + ;; need to traverse the tree one more time to collect this + ;; data, and I think that it's not worth it. + + (when (eq letsym 'let*) + (let ((closedsym '()) + (new-lmenv '()) + (old-lmenv '())) + (dolist (lmenv lmenvs) + (when (memq var (cdr lmenv)) + (setq closedsym + (make-symbol + (concat "closed-" (symbol-name var)))) + (setq new-lmenv (list (car lmenv))) + (dolist (frv (cdr lmenv)) (if (eq frv var) + (push closedsym new-lmenv) + (push frv new-lmenv))) + (setq new-lmenv (reverse new-lmenv)) + (setq old-lmenv lmenv))) + (when new-lmenv + (setq lmenvs (remq old-lmenv lmenvs)) + (push new-lmenv lmenvs) + (push `(,closedsym ,var) varsvalues-new)))) + ;; we push the element after redefined free variables + ;; are processes. this is important to avoid the bug + ;; when free variable and the function have the same + ;; name + (push elm-new varsvalues-new) + + (when (eq letsym 'let*) ; update fvrs + (setq fvrs (remq var fvrs)) + (setq emvrs (remq var emvrs)) ; remove if redefined + (when emvr-push + (push emvr-push emvrs) + (setq emvr-push nil)) + (let (lmenvs-1) ; remove var from lmenvs if redefined + (dolist (iter lmenvs) + (when (not (assq var lmenvs)) + (push iter lmenvs-1))) + (setq lmenvs lmenvs-1)) + (when lmenv-push + (push lmenv-push lmenvs) + (setq lmenv-push nil))) + )) ; end of dolist over varsvalues + (when (eq letsym 'let) + + (let (var fvrs-1 emvrs-1 lmenvs-1) + ;; Here we update emvrs, fvrs and lmenvs lists + (dolist (vr fvrs) + ; safely remove + (when (not (assq vr varsvalues-new)) (push vr fvrs-1))) + (setq fvrs fvrs-1) + (dolist (vr emvrs) + ; safely remove + (when (not (assq vr varsvalues-new)) (push vr emvrs-1))) + (setq emvrs emvrs-1) + ; push new + (setq emvrs (append emvrs emvrs-new)) + (dolist (vr lmenvs) + (when (not (assq (car vr) varsvalues-new)) + (push vr lmenvs-1))) + (setq lmenvs (append lmenvs lmenvs-new))) + + ;; Here we do the same letbinding as for let* above + ;; to avoid situation when a free variable of a lambda lifted + ;; function got redefined. + + (let ((new-lmenv) + (var nil) + (closedsym nil) + (letbinds '()) + (fvrs-new)) ; list of (closed-var var) + (dolist (elm varsvalues) + (if (listp elm) + (setq var (car elm)) + (setq var elm)) + + (let ((lmenvs-1 lmenvs)) ; just to avoid manipulating + (dolist (lmenv lmenvs-1) ; the counter inside the loop + (when (memq var (cdr lmenv)) + (setq closedsym (make-symbol + (concat "closed-" + (symbol-name var)))) + + (setq new-lmenv (list (car lmenv))) + (dolist (frv (cdr lmenv)) (if (eq frv var) + (push closedsym new-lmenv) + (push frv new-lmenv))) + (setq new-lmenv (reverse new-lmenv)) + (setq lmenvs (remq lmenv lmenvs)) + (push new-lmenv lmenvs) + (push `(,closedsym ,var) letbinds) + )))) + (setq varsvalues-new (append varsvalues-new letbinds)))) + + (dolist (elm body-forms) ; convert body forms + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs nil) + body-forms-new)) + `(,letsym ,(reverse varsvalues-new) . ,(reverse body-forms-new)))) + ;end of let let* forms + + ; first element is lambda expression + (`(,(and `(lambda . ,_) fun) . ,other-body-forms) + + (let ((other-body-forms-new '())) + (dolist (elm other-body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs nil) + other-body-forms-new)) + (cons + (cadr + (cconv-closure-convert-rec + (list 'function fun) emvrs fvrs envs lmenvs nil)) + (reverse other-body-forms-new)))) + + (`(cond . ,cond-forms) ; cond special form + (let ((cond-forms-new '())) + (dolist (elm cond-forms) + (push (let ((elm-new '())) + (dolist (elm-2 elm) + (push + (cconv-closure-convert-rec + elm-2 emvrs fvrs envs lmenvs nil) + elm-new)) + (reverse elm-new)) + cond-forms-new)) + (cons 'cond + (reverse cond-forms-new)))) + + (`(quote . ,_) form) ; quote form + + (`(function . ((lambda ,vars . ,body-forms))) ; function form + (let (fvrs-new) ; we remove vars from fvrs + (dolist (elm fvrs) ;i use such a tricky way to avoid side effects + (when (not (memq elm vars)) + (push elm fvrs-new))) + (setq fvrs fvrs-new)) + (let* ((fv (delete-dups (cconv-freevars form '()))) + (leave fvrs) ; leave = non nil if we should leave env unchanged + (body-forms-new '()) + (letbind '()) + (mv nil) + (envector nil)) + (when fv + ;; Here we form our environment vector. + ;; If outer closure contains all + ;; free variables of this function(and nothing else) + ;; then we use the same environment vector as for outer closure, + ;; i.e. we leave the environment vector unchanged + ;; otherwise we build a new environmet vector + (if (eq (length envs) (length fv)) + (let ((fv-temp fv)) + (while (and fv-temp leave) + (when (not (memq (car fv-temp) fvrs)) (setq leave nil)) + (setq fv-temp (cdr fv-temp)))) + (setq leave nil)) + + (if (not leave) + (progn + (dolist (elm fv) + (push + (cconv-closure-convert-rec + elm (remq elm emvrs) fvrs envs lmenvs nil) + envector)) ; process vars for closure vector + (setq envector (reverse envector)) + (setq envs fv)) + (setq envector `(env))) ; leave unchanged + (setq fvrs fv)) ; update substitution list + + ;; the difference between envs and fvrs is explained + ;; in comment in the beginning of the function + (dolist (elm cconv-captured+mutated) ; find mutated arguments + (setq mv (car elm)) ; used in inner closures + (when (and (memq mv vars) (eq form (caddr elm))) + (progn (push mv emvrs) + (push `(,mv (list ,mv)) letbind)))) + (dolist (elm body-forms) ; convert function body + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs nil) + body-forms-new)) + + (setq body-forms-new + (if letbind `((let ,letbind . ,(reverse body-forms-new))) + (reverse body-forms-new))) + + (cond + ;if no freevars - do nothing + ((null envector) + `(function (lambda ,vars . ,body-forms-new))) + ; 1 free variable - do not build vector + ((null (cdr envector)) + `(curry + (function (lambda (env . ,vars) . ,body-forms-new)) + ,(car envector))) + ; >=2 free variables - build vector + (t + `(curry + (function (lambda (env . ,vars) . ,body-forms-new)) + (vector . ,envector)))))) + + (`(function . ,_) form) ; same as quote + + ;defconst, defvar + (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms) + + (if defs-are-legal + (let ((body-forms-new '())) + (dolist (elm body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs nil) + body-forms-new)) + (setq body-forms-new (reverse body-forms-new)) + `(,sym ,definedsymbol . ,body-forms-new)) + (error "Invalid form: %s inside a function" sym))) + + ;defun, defmacro, defsubst + (`(,(and sym (or `defun `defmacro `defsubst)) + ,func ,vars . ,body-forms) + (if defs-are-legal + (let ((body-new '()) ; the whole body + (body-forms-new '()) ; body w\o docstring and interactive + (letbind '())) + ; find mutable arguments + (let ((lmutated cconv-captured+mutated) ismutated) + (dolist (elm vars) + (setq ismutated nil) + (while (and lmutated (not ismutated)) + (when (and (eq (caar lmutated) elm) + (eq (cadar lmutated) form)) + (setq ismutated t)) + (setq lmutated (cdr lmutated))) + (when ismutated + (push elm letbind) + (push elm emvrs)))) + ;transform body-forms + (when (stringp (car body-forms)) ; treat docstring well + (push (car body-forms) body-new) + (setq body-forms (cdr body-forms))) + (when (and (listp (car body-forms)) ; treat (interactive) well + (eq (caar body-forms) 'interactive)) + (push + (cconv-closure-convert-rec + (car body-forms) + emvrs fvrs envs lmenvs nil) body-new) + (setq body-forms (cdr body-forms))) + + (dolist (elm body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs nil) + body-forms-new)) + (setq body-forms-new (reverse body-forms-new)) + + (if letbind + ; letbind mutable arguments + (let ((varsvalues-new '())) + (dolist (elm letbind) (push `(,elm (list ,elm)) + varsvalues-new)) + (push `(let ,(reverse varsvalues-new) . + ,body-forms-new) body-new) + (setq body-new (reverse body-new))) + (setq body-new (append (reverse body-new) body-forms-new))) + + `(,sym ,func ,vars . ,body-new)) + + (error "Invalid form: defun inside a function"))) + ;condition-case + (`(condition-case ,var ,protected-form . ,conditions-bodies) + (let ((conditions-bodies-new '())) + (setq fvrs (remq var fvrs)) + (dolist (elm conditions-bodies) + (push (let ((elm-new '())) + (dolist (elm-2 (cdr elm)) + (push + (cconv-closure-convert-rec + elm-2 emvrs fvrs envs lmenvs nil) + elm-new)) + (cons (car elm) (reverse elm-new))) + conditions-bodies-new)) + `(condition-case + ,var + ,(cconv-closure-convert-rec + protected-form emvrs fvrs envs lmenvs nil) + . ,(reverse conditions-bodies-new)))) + + (`(setq . ,forms) ; setq special form + (let (prognlist sym sym-new value) + (while forms + (setq sym (car forms)) + (setq sym-new (cconv-closure-convert-rec + sym + (remq sym emvrs) fvrs envs lmenvs nil)) + (setq value + (cconv-closure-convert-rec + (cadr forms) emvrs fvrs envs lmenvs nil)) + (if (memq sym emvrs) + (push `(setcar ,sym-new ,value) prognlist) + (if (symbolp sym-new) + (push `(setq ,sym-new ,value) prognlist) + (push `(set ,sym-new ,value) prognlist))) + (setq forms (cddr forms))) + (if (cdr prognlist) + `(progn . ,(reverse prognlist)) + (car prognlist)))) + + (`(,(and (or `funcall `apply) callsym) ,fun . ,args) + ; funcall is not a special form + ; but we treat it separately + ; for the needs of lambda lifting + (let ((fv (cdr (assq fun lmenvs)))) + (if fv + (let ((args-new '()) + (processed-fv '())) + ;; All args (free variables and actual arguments) + ;; should be processed, because they can be fvrs + ;; (free variables of another closure) + (dolist (fvr fv) + (push (cconv-closure-convert-rec + fvr (remq fvr emvrs) + fvrs envs lmenvs nil) + processed-fv)) + (setq processed-fv (reverse processed-fv)) + (dolist (elm args) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs nil) + args-new)) + (setq args-new (append processed-fv (reverse args-new))) + (setq fun (cconv-closure-convert-rec + fun emvrs fvrs envs lmenvs nil)) + `(,callsym ,fun . ,args-new)) + (let ((cdr-new '())) + (dolist (elm (cdr form)) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs nil) + cdr-new)) + `(,callsym . ,(reverse cdr-new)))))) + + (`(,func . ,body-forms) ; first element is function or whatever + ; function-like forms are: + ; or, and, if, progn, prog1, prog2, + ; while, until + (let ((body-forms-new '())) + (dolist (elm body-forms) + (push (cconv-closure-convert-rec + elm emvrs fvrs envs lmenvs defs-are-legal) + body-forms-new)) + (setq body-forms-new (reverse body-forms-new)) + `(,func . ,body-forms-new))) + + (_ + (if (memq form fvrs) ;form is a free variable + (let* ((numero (position form envs)) + (var '())) + (assert numero) + (if (null (cdr envs)) + (setq var 'env) + ;replace form => + ;(aref env #) + (setq var `(aref env ,numero))) + (if (memq form emvrs) ; form => (car (aref env #)) if mutable + `(car ,var) + var)) + (if (memq form emvrs) ; if form is a mutable variable + `(car ,form) ; replace form => (car form) + form))))) + +(defun cconv-analyse-form (form vars inclosure) + + "Find mutated variables and variables captured by closure. Analyse +lambdas if they are suitable for lambda lifting. +-- FORM is a piece of Elisp code after macroexpansion. +-- MLCVRS is a structure that contains captured and mutated variables. + (first MLCVRS) is a list of mutated variables, (second MLCVRS) is a +list of candidates for lambda lifting and (third MLCVRS) is a list of +variables captured by closure. It should be (nil nil nil) initially. +-- VARS is a list of local variables visible in current environment + (initially empty). +-- INCLOSURE is a boolean variable, true if we are in closure. +Initially false" + (pcase form + ; let special form + (`(,(and (or `let* `let) letsym) ,varsvalues . ,body-forms) + + (when (eq letsym 'let) + (dolist (elm varsvalues) ; analyse values + (when (listp elm) + (cconv-analyse-form (cadr elm) vars inclosure)))) + + (let ((v nil) + (var nil) + (value nil) + (varstruct nil)) + (dolist (elm varsvalues) + (if (listp elm) + (progn + (setq var (car elm)) + (setq value (cadr elm))) + (progn + (setq var elm) ; treat the form (let (x) ...) well + (setq value nil))) + + (when (eq letsym 'let*) ; analyse value + (cconv-analyse-form value vars inclosure)) + + (let (vars-new) ; remove the old var + (dolist (vr vars) + (when (not (eq (car vr) var)) + (push vr vars-new))) + (setq vars vars-new)) + + (setq varstruct (list var inclosure elm form)) + (push varstruct vars) ; push a new one + + (when (and (listp value) + (eq (car value) 'function) + (eq (caadr value) 'lambda)) + ; if var is a function + ; push it to lambda list + (push varstruct cconv-lambda-candidates)))) + + (dolist (elm body-forms) ; analyse body forms + (cconv-analyse-form elm vars inclosure)) + nil) + ; defun special form + (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) + (let ((v nil)) + (dolist (vr vrs) + (push (list vr form) vars))) ;push vrs to vars + (dolist (elm body-forms) ; analyse body forms + (cconv-analyse-form elm vars inclosure)) + nil) + + (`(function . ((lambda ,vrs . ,body-forms))) + (if inclosure ;we are in closure + (setq inclosure (+ inclosure 1)) + (setq inclosure 1)) + (let (vars-new) ; update vars + (dolist (vr vars) ; we do that in such a tricky way + (when (not (memq (car vr) vrs)) ; to avoid side effects + (push vr vars-new))) + (dolist (vr vrs) + (push (list vr inclosure form) vars-new)) + (setq vars vars-new)) + + (dolist (elm body-forms) + (cconv-analyse-form elm vars inclosure)) + nil) + + (`(setq . ,forms) ; setq + ; if a local variable (member of vars) + ; is modified by setq + ; then it is a mutated variable + (while forms + (let ((v (assq (car forms) vars))) ; v = non nil if visible + (when v + (push v cconv-mutated) + ;; delete from candidate list for lambda lifting + (setq cconv-lambda-candidates (delq v cconv-lambda-candidates)) + (when inclosure + ;; test if v is declared as argument for lambda + (let* ((thirdv (third v)) + (isarg (if (listp thirdv) + (eq (car thirdv) 'function) nil))) + (if isarg + (when (> inclosure (cadr v)) ; when we are in closure + (push v cconv-captured)) ; push it to captured vars + ;; FIXME more detailed comments needed + (push v cconv-captured)))))) + (cconv-analyse-form (cadr forms) vars inclosure) + (setq forms (cddr forms))) + nil) + + (`((lambda . ,_) . ,_) ; first element is lambda expression + (dolist (exp `((function ,(car form)) . ,(cdr form))) + (cconv-analyse-form exp vars inclosure)) + nil) + + (`(cond . ,cond-forms) ; cond special form + (dolist (exp1 cond-forms) + (dolist (exp2 exp1) + (cconv-analyse-form exp2 vars inclosure))) + nil) + + (`(quote . ,_) nil) ; quote form + + (`(function . ,_) nil) ; same as quote + + (`(condition-case ,var ,protected-form . ,conditions-bodies) + ;condition-case + (cconv-analyse-form protected-form vars inclosure) + (dolist (exp conditions-bodies) + (cconv-analyse-form (cadr exp) vars inclosure)) + nil) + + (`(,(or `defconst `defvar `defsubst) ,value) + (cconv-analyse-form value vars inclosure)) + + (`(,(or `funcall `apply) ,fun . ,args) + ;; Here we ignore fun because + ;; funcall and apply are the only two + ;; functions where we can pass a candidate + ;; for lambda lifting as argument. + ;; So, if we see fun elsewhere, we'll + ;; delete it from lambda candidate list. + + ;; If this funcall and the definition of fun + ;; are in different closures - we delete fun from + ;; canidate list, because it is too complicated + ;; to manage free variables in this case. + (let ((lv (assq fun cconv-lambda-candidates))) + (when lv + (when (not (eq (cadr lv) inclosure)) + (setq cconv-lambda-candidates + (delq lv cconv-lambda-candidates))))) + + (dolist (elm args) + (cconv-analyse-form elm vars inclosure)) + nil) + + (`(,_ . ,body-forms) ; first element is a function or whatever + (dolist (exp body-forms) + (cconv-analyse-form exp vars inclosure)) + nil) + + (_ + (when (and (symbolp form) + (not (memq form '(nil t))) + (not (keywordp form)) + (not (special-variable-p form))) + (let ((dv (assq form vars))) ; dv = declared and visible + (when dv + (when inclosure + ;; test if v is declared as argument of lambda + (let* ((thirddv (third dv)) + (isarg (if (listp thirddv) + (eq (car thirddv) 'function) nil))) + (if isarg + ;; FIXME add detailed comments + (when (> inclosure (cadr dv)) ; capturing condition + (push dv cconv-captured)) + (push dv cconv-captured)))) + ; delete lambda + (setq cconv-lambda-candidates ; if it is found here + (delq dv cconv-lambda-candidates))))) + nil))) + +(provide 'cconv) +;;; cconv.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 24ea0a3e80..7990df264a 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;; pcase.el --- ML-style pattern-matching macro for Elisp ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. @@ -501,15 +502,14 @@ and otherwise defers to REST which is a list of branches of the form ;; `(PAT3 . PAT4)) which the programmer can easily rewrite ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). (pcase--u1 `((match ,sym . ,(cadr upat))) - (lexical-let ((rest rest)) - ;; FIXME: This codegen is not careful to share its - ;; code if used several times: code blow up is likely. - (lambda (vars) - ;; `vars' will likely contain bindings which are - ;; not always available in other paths to - ;; `rest', so there' no point trying to pass - ;; them down. - (pcase--u rest))) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase--u rest)) vars (list `((and . ,matches) ,code . ,vars)))) (t (error "Unknown upattern `%s'" upat))))) diff --git a/lisp/mpc.el b/lisp/mpc.el index 8feddf8829..4f21a162c0 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*- ;; Copyright (C) 2006-2011 Free Software Foundation, Inc. @@ -341,9 +342,7 @@ CMD can be a string which is passed as-is to MPD or a list of strings which will be concatenated with proper quoting before passing them to MPD." (let ((proc (mpc-proc))) (if (and callback (not (process-get proc 'ready))) - (lexical-let ((old (process-get proc 'callback)) - (callback callback) - (cmd cmd)) + (let ((old (process-get proc 'callback))) (process-put proc 'callback (lambda () (funcall old) @@ -359,8 +358,7 @@ which will be concatenated with proper quoting before passing them to MPD." (mapconcat 'mpc--proc-quote-string cmd " ")) "\n"))) (if callback - (lexical-let ((buf (current-buffer)) - (callback callback)) + (let ((buf (current-buffer))) (process-put proc 'callback callback ;; (lambda () @@ -402,8 +400,7 @@ which will be concatenated with proper quoting before passing them to MPD." (defun mpc-proc-cmd-to-alist (cmd &optional callback) (if callback - (lexical-let ((buf (current-buffer)) - (callback callback)) + (let ((buf (current-buffer))) (mpc-proc-cmd cmd (lambda () (funcall callback (prog1 (mpc-proc-buf-to-alist (current-buffer)) @@ -522,7 +519,7 @@ to call FUN for any change whatsoever.") (defun mpc-status-refresh (&optional callback) "Refresh `mpc-status'." - (lexical-let ((cb callback)) + (let ((cb callback)) (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong")) (lambda () (mpc--status-callback) @@ -775,7 +772,7 @@ The songs are returned as alists." (defun mpc-cmd-pause (&optional arg callback) "Pause or resume playback of the queue of songs." - (lexical-let ((cb callback)) + (let ((cb callback)) (mpc-proc-cmd (list "pause" arg) (lambda () (mpc-status-refresh) (if cb (funcall cb)))) (unless callback (mpc-proc-sync)))) @@ -839,7 +836,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))) (defun mpc-cmd-update (&optional arg callback) - (lexical-let ((cb callback)) + (let ((cb callback)) (mpc-proc-cmd (if arg (list "update" arg) "update") (lambda () (mpc-status-refresh) (if cb (funcall cb)))) (unless callback (mpc-proc-sync)))) @@ -2351,8 +2348,7 @@ This is used so that they can be compared with `eq', which is needed for (mpc-proc-cmd (list "seekid" songid time) 'mpc-status-refresh)))) (let ((status (mpc-cmd-status))) - (lexical-let* ((songid (cdr (assq 'songid status))) - (step step) + (let* ((songid (cdr (assq 'songid status))) (time (if songid (string-to-number (cdr (assq 'time status)))))) (let ((timer (run-with-timer @@ -2389,13 +2385,12 @@ This is used so that they can be compared with `eq', which is needed for (if mpc--faster-toggle-timer (mpc--faster-stop) (mpc-status-refresh) (mpc-proc-sync) - (lexical-let* ((speedup speedup) - songid ;The ID of the currently ffwd/rewinding song. - songnb ;The position of that song in the playlist. - songduration ;The duration of that song. - songtime ;The time of the song last time we ran. - oldtime ;The timeoftheday last time we ran. - prevsongid) ;The song we're in the process leaving. + (let* (songid ;The ID of the currently ffwd/rewinding song. + songnb ;The position of that song in the playlist. + songduration ;The duration of that song. + songtime ;The time of the song last time we ran. + oldtime ;The timeoftheday last time we ran. + prevsongid) ;The song we're in the process leaving. (let ((fun (lambda () (let ((newsongid (cdr (assq 'songid mpc-status))) diff --git a/lisp/server.el b/lisp/server.el index 62c59b41ce..1ee30f5bc3 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;; server.el --- Lisp code for GNU Emacs running as server process ;; Copyright (C) 1986-1987, 1992, 1994-2011 Free Software Foundation, Inc. @@ -335,9 +336,9 @@ If CLIENT is non-nil, add a description of it to the logged message." (goto-char (point-max)) (insert (funcall server-log-time-function) (cond - ((null client) " ") - ((listp client) (format " %s: " (car client))) - (t (format " %s: " client))) + ((null client) " ") + ((listp client) (format " %s: " (car client))) + (t (format " %s: " client))) string) (or (bolp) (newline))))) @@ -355,7 +356,7 @@ If CLIENT is non-nil, add a description of it to the logged message." (and (process-contact proc :server) (eq (process-status proc) 'closed) (ignore-errors - (delete-file (process-get proc :server-file)))) + (delete-file (process-get proc :server-file)))) (server-log (format "Status changed to %s: %s" (process-status proc) msg) proc) (server-delete-client proc)) @@ -410,10 +411,10 @@ If CLIENT is non-nil, add a description of it to the logged message." proc ;; See if this is the last frame for this client. (>= 1 (let ((frame-num 0)) - (dolist (f (frame-list)) - (when (eq proc (frame-parameter f 'client)) - (setq frame-num (1+ frame-num)))) - frame-num))) + (dolist (f (frame-list)) + (when (eq proc (frame-parameter f 'client)) + (setq frame-num (1+ frame-num)))) + frame-num))) (server-log (format "server-handle-delete-frame, frame %s" frame) proc) (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later. @@ -534,8 +535,8 @@ To force-start a server, do \\[server-force-delete] and then (if (not (eq t (server-running-p server-name))) ;; Remove any leftover socket or authentication file (ignore-errors - (let (delete-by-moving-to-trash) - (delete-file server-file))) + (let (delete-by-moving-to-trash) + (delete-file server-file))) (setq server-mode nil) ;; already set by the minor mode code (display-warning 'server @@ -590,11 +591,11 @@ server or call `M-x server-force-delete' to forcibly disconnect it.") (when server-use-tcp (let ((auth-key (loop - ;; The auth key is a 64-byte string of random chars in the - ;; range `!'..`~'. - repeat 64 - collect (+ 33 (random 94)) into auth - finally return (concat auth)))) + ;; The auth key is a 64-byte string of random chars in the + ;; range `!'..`~'. + repeat 64 + collect (+ 33 (random 94)) into auth + finally return (concat auth)))) (process-put server-process :auth-key auth-key) (with-temp-file server-file (set-buffer-multibyte nil) @@ -689,31 +690,31 @@ Server mode runs a process that accepts commands from the (add-to-list 'frame-inherited-parameters 'client) (let ((frame (server-with-environment (process-get proc 'env) - '("LANG" "LC_CTYPE" "LC_ALL" - ;; For tgetent(3); list according to ncurses(3). - "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" - "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" - "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" - "TERMINFO_DIRS" "TERMPATH" - ;; rxvt wants these - "COLORFGBG" "COLORTERM") - (make-frame `((window-system . nil) - (tty . ,tty) - (tty-type . ,type) - ;; Ignore nowait here; we always need to - ;; clean up opened ttys when the client dies. - (client . ,proc) - ;; This is a leftover from an earlier - ;; attempt at making it possible for process - ;; run in the server process to use the - ;; environment of the client process. - ;; It has no effect now and to make it work - ;; we'd need to decide how to make - ;; process-environment interact with client - ;; envvars, and then to change the - ;; C functions `child_setup' and - ;; `getenv_internal' accordingly. - (environment . ,(process-get proc 'env))))))) + '("LANG" "LC_CTYPE" "LC_ALL" + ;; For tgetent(3); list according to ncurses(3). + "BAUDRATE" "COLUMNS" "ESCDELAY" "HOME" "LINES" + "NCURSES_ASSUMED_COLORS" "NCURSES_NO_PADDING" + "NCURSES_NO_SETBUF" "TERM" "TERMCAP" "TERMINFO" + "TERMINFO_DIRS" "TERMPATH" + ;; rxvt wants these + "COLORFGBG" "COLORTERM") + (make-frame `((window-system . nil) + (tty . ,tty) + (tty-type . ,type) + ;; Ignore nowait here; we always need to + ;; clean up opened ttys when the client dies. + (client . ,proc) + ;; This is a leftover from an earlier + ;; attempt at making it possible for process + ;; run in the server process to use the + ;; environment of the client process. + ;; It has no effect now and to make it work + ;; we'd need to decide how to make + ;; process-environment interact with client + ;; envvars, and then to change the + ;; C functions `child_setup' and + ;; `getenv_internal' accordingly. + (environment . ,(process-get proc 'env))))))) ;; ttys don't use the `display' parameter, but callproc.c does to set ;; the DISPLAY environment on subprocesses. @@ -777,8 +778,7 @@ Server mode runs a process that accepts commands from the ;; frame because input from that display will be blocked (until exiting ;; the minibuffer). Better exit this minibuffer right away. ;; Similarly with recursive-edits such as the splash screen. - (run-with-timer 0 nil (lexical-let ((proc proc)) - (lambda () (server-execute-continuation proc)))) + (run-with-timer 0 nil (lambda () (server-execute-continuation proc))) (top-level))) ;; We use various special properties on process objects: @@ -944,119 +944,119 @@ The following commands are accepted by the client: (setq command-line-args-left (mapcar 'server-unquote-arg (split-string request " " t))) (while (setq arg (pop command-line-args-left)) - (cond - ;; -version CLIENT-VERSION: obsolete at birth. - ((and (equal "-version" arg) command-line-args-left) - (pop command-line-args-left)) - - ;; -nowait: Emacsclient won't wait for a result. - ((equal "-nowait" arg) (setq nowait t)) - - ;; -current-frame: Don't create frames. - ((equal "-current-frame" arg) (setq use-current-frame t)) - - ;; -display DISPLAY: - ;; Open X frames on the given display instead of the default. - ((and (equal "-display" arg) command-line-args-left) - (setq display (pop command-line-args-left)) - (if (zerop (length display)) (setq display nil))) - - ;; -parent-id ID: - ;; Open X frame within window ID, via XEmbed. - ((and (equal "-parent-id" arg) command-line-args-left) - (setq parent-id (pop command-line-args-left)) - (if (zerop (length parent-id)) (setq parent-id nil))) - - ;; -window-system: Open a new X frame. - ((equal "-window-system" arg) - (setq dontkill t) - (setq tty-name 'window-system)) - - ;; -resume: Resume a suspended tty frame. - ((equal "-resume" arg) - (lexical-let ((terminal (process-get proc 'terminal))) - (setq dontkill t) - (push (lambda () - (when (eq (terminal-live-p terminal) t) - (resume-tty terminal))) - commands))) - - ;; -suspend: Suspend the client's frame. (In case we - ;; get out of sync, and a C-z sends a SIGTSTP to - ;; emacsclient.) - ((equal "-suspend" arg) - (lexical-let ((terminal (process-get proc 'terminal))) - (setq dontkill t) - (push (lambda () - (when (eq (terminal-live-p terminal) t) - (suspend-tty terminal))) - commands))) - - ;; -ignore COMMENT: Noop; useful for debugging emacsclient. - ;; (The given comment appears in the server log.) - ((and (equal "-ignore" arg) command-line-args-left + (cond + ;; -version CLIENT-VERSION: obsolete at birth. + ((and (equal "-version" arg) command-line-args-left) + (pop command-line-args-left)) + + ;; -nowait: Emacsclient won't wait for a result. + ((equal "-nowait" arg) (setq nowait t)) + + ;; -current-frame: Don't create frames. + ((equal "-current-frame" arg) (setq use-current-frame t)) + + ;; -display DISPLAY: + ;; Open X frames on the given display instead of the default. + ((and (equal "-display" arg) command-line-args-left) + (setq display (pop command-line-args-left)) + (if (zerop (length display)) (setq display nil))) + + ;; -parent-id ID: + ;; Open X frame within window ID, via XEmbed. + ((and (equal "-parent-id" arg) command-line-args-left) + (setq parent-id (pop command-line-args-left)) + (if (zerop (length parent-id)) (setq parent-id nil))) + + ;; -window-system: Open a new X frame. + ((equal "-window-system" arg) + (setq dontkill t) + (setq tty-name 'window-system)) + + ;; -resume: Resume a suspended tty frame. + ((equal "-resume" arg) + (let ((terminal (process-get proc 'terminal))) + (setq dontkill t) + (push (lambda () + (when (eq (terminal-live-p terminal) t) + (resume-tty terminal))) + commands))) + + ;; -suspend: Suspend the client's frame. (In case we + ;; get out of sync, and a C-z sends a SIGTSTP to + ;; emacsclient.) + ((equal "-suspend" arg) + (let ((terminal (process-get proc 'terminal))) (setq dontkill t) - (pop command-line-args-left))) - - ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client. - ((and (equal "-tty" arg) - (cdr command-line-args-left)) - (setq tty-name (pop command-line-args-left) - tty-type (pop command-line-args-left) - dontkill (or dontkill - (not use-current-frame)))) - - ;; -position LINE[:COLUMN]: Set point to the given - ;; position in the next file. - ((and (equal "-position" arg) - command-line-args-left - (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" - (car command-line-args-left))) - (setq arg (pop command-line-args-left)) - (setq filepos - (cons (string-to-number (match-string 1 arg)) - (string-to-number (or (match-string 2 arg) ""))))) - - ;; -file FILENAME: Load the given file. - ((and (equal "-file" arg) - command-line-args-left) - (let ((file (pop command-line-args-left))) - (if coding-system - (setq file (decode-coding-string file coding-system))) - (setq file (expand-file-name file dir)) - (push (cons file filepos) files) - (server-log (format "New file: %s %s" - file (or filepos "")) proc)) - (setq filepos nil)) - - ;; -eval EXPR: Evaluate a Lisp expression. - ((and (equal "-eval" arg) - command-line-args-left) - (if use-current-frame - (setq use-current-frame 'always)) - (lexical-let ((expr (pop command-line-args-left))) - (if coding-system - (setq expr (decode-coding-string expr coding-system))) - (push (lambda () (server-eval-and-print expr proc)) - commands) - (setq filepos nil))) - - ;; -env NAME=VALUE: An environment variable. - ((and (equal "-env" arg) command-line-args-left) - (let ((var (pop command-line-args-left))) - ;; XXX Variables should be encoded as in getenv/setenv. - (process-put proc 'env - (cons var (process-get proc 'env))))) - - ;; -dir DIRNAME: The cwd of the emacsclient process. - ((and (equal "-dir" arg) command-line-args-left) - (setq dir (pop command-line-args-left)) + (push (lambda () + (when (eq (terminal-live-p terminal) t) + (suspend-tty terminal))) + commands))) + + ;; -ignore COMMENT: Noop; useful for debugging emacsclient. + ;; (The given comment appears in the server log.) + ((and (equal "-ignore" arg) command-line-args-left + (setq dontkill t) + (pop command-line-args-left))) + + ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client. + ((and (equal "-tty" arg) + (cdr command-line-args-left)) + (setq tty-name (pop command-line-args-left) + tty-type (pop command-line-args-left) + dontkill (or dontkill + (not use-current-frame)))) + + ;; -position LINE[:COLUMN]: Set point to the given + ;; position in the next file. + ((and (equal "-position" arg) + command-line-args-left + (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" + (car command-line-args-left))) + (setq arg (pop command-line-args-left)) + (setq filepos + (cons (string-to-number (match-string 1 arg)) + (string-to-number (or (match-string 2 arg) ""))))) + + ;; -file FILENAME: Load the given file. + ((and (equal "-file" arg) + command-line-args-left) + (let ((file (pop command-line-args-left))) (if coding-system - (setq dir (decode-coding-string dir coding-system))) - (setq dir (command-line-normalize-file-name dir))) - - ;; Unknown command. - (t (error "Unknown command: %s" arg)))) + (setq file (decode-coding-string file coding-system))) + (setq file (expand-file-name file dir)) + (push (cons file filepos) files) + (server-log (format "New file: %s %s" + file (or filepos "")) proc)) + (setq filepos nil)) + + ;; -eval EXPR: Evaluate a Lisp expression. + ((and (equal "-eval" arg) + command-line-args-left) + (if use-current-frame + (setq use-current-frame 'always)) + (let ((expr (pop command-line-args-left))) + (if coding-system + (setq expr (decode-coding-string expr coding-system))) + (push (lambda () (server-eval-and-print expr proc)) + commands) + (setq filepos nil))) + + ;; -env NAME=VALUE: An environment variable. + ((and (equal "-env" arg) command-line-args-left) + (let ((var (pop command-line-args-left))) + ;; XXX Variables should be encoded as in getenv/setenv. + (process-put proc 'env + (cons var (process-get proc 'env))))) + + ;; -dir DIRNAME: The cwd of the emacsclient process. + ((and (equal "-dir" arg) command-line-args-left) + (setq dir (pop command-line-args-left)) + (if coding-system + (setq dir (decode-coding-string dir coding-system))) + (setq dir (command-line-normalize-file-name dir))) + + ;; Unknown command. + (t (error "Unknown command: %s" arg)))) (setq frame (cond @@ -1079,23 +1079,15 @@ The following commands are accepted by the client: (process-put proc 'continuation - (lexical-let ((proc proc) - (files files) - (nowait nowait) - (commands commands) - (dontkill dontkill) - (frame frame) - (dir dir) - (tty-name tty-name)) - (lambda () - (with-current-buffer (get-buffer-create server-buffer) - ;; Use the same cwd as the emacsclient, if possible, so - ;; relative file names work correctly, even in `eval'. - (let ((default-directory - (if (and dir (file-directory-p dir)) - dir default-directory))) - (server-execute proc files nowait commands - dontkill frame tty-name)))))) + (lambda () + (with-current-buffer (get-buffer-create server-buffer) + ;; Use the same cwd as the emacsclient, if possible, so + ;; relative file names work correctly, even in `eval'. + (let ((default-directory + (if (and dir (file-directory-p dir)) + dir default-directory))) + (server-execute proc files nowait commands + dontkill frame tty-name))))) (when (or frame files) (server-goto-toplevel proc)) @@ -1372,12 +1364,12 @@ If invoked with a prefix argument, or if there is no server process running, starts server process and that is all. Invoked by \\[server-edit]." (interactive "P") (cond - ((or arg - (not server-process) - (memq (process-status server-process) '(signal exit))) - (server-mode 1)) - (server-clients (apply 'server-switch-buffer (server-done))) - (t (message "No server editing buffers exist")))) + ((or arg + (not server-process) + (memq (process-status server-process) '(signal exit))) + (server-mode 1)) + (server-clients (apply 'server-switch-buffer (server-done))) + (t (message "No server editing buffers exist")))) (defun server-switch-buffer (&optional next-buffer killed-one filepos) "Switch to another buffer, preferably one that has a client. -- 2.20.1