mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-28 10:56:36 +00:00
Code Issues Releases Activity

* lisp/emacs-lisp/cconv.el: New file.

Browse Source 
* 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.
This commit is contained in:
Igor Kuzmin 2011-02-10 13:53:49 -05:00 committed by Stefan Monnier
parent 8f1d2ef658
commit 94d11cb577
8 changed files with 1109 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
lisp/ChangeLog
View File

@ -1,3 +1,15 @@
2011-02-10 Igor Kuzmin <kuzminig@iro.umontreal.ca>
* 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 <monnier@iro.umontreal.ca>
* emacs-lisp/bytecomp.el (byte-compile-track-mouse): Don't use #'.

1
lisp/dired.el
View File

@ -1,3 +1,4 @@
;;; -*- lexical-binding: t -*-
;;; dired.el --- directory-browsing commands
;; Copyright (C) 1985-1986, 1992-1997, 2000-2011

41
lisp/doc-view.el
View File

@ -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)

11
lisp/emacs-lisp/bytecomp.el
View File

@ -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

891
lisp/emacs-lisp/cconv.el Normal file
View File

@ -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 <value(s)>
;; 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

18
lisp/emacs-lisp/pcase.el
View File

@ -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)))))

33
lisp/mpc.el
View File

@ -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)))

320
lisp/server.el
View File

@ -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))
(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))
;; -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))
;; -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)))
;; -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)))
;; -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))
;; -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
;; -resume: Resume a suspended tty frame.
((equal "-resume" arg)
(let ((terminal (process-get proc 'terminal)))
(setq dontkill t)
(pop command-line-args-left)))
(push (lambda ()
(when (eq (terminal-live-p terminal) t)
(resume-tty terminal)))
commands)))
;; -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))))
;; -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)
(push (lambda ()
(when (eq (terminal-live-p terminal) t)
(suspend-tty terminal)))
commands)))
;; -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) "")))))
;; -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)))
;; -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))
;; -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))))
;; -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)))
;; -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) "")))))
;; -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))
;; -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)))
(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))
;; Unknown command.
(t (error "Unknown command: %s" arg))))
;; -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.