mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-24 19:03:29 +00:00
Compute freevars in cconv-analyse.
* lisp/emacs-lisp/cconv.el: Compute freevars in cconv-analyse. (cconv-mutated, cconv-captured): Remove. (cconv-captured+mutated, cconv-lambda-candidates): Don't give them a global value. (cconv-freevars-alist): New var. (cconv-freevars): Remove. (cconv--lookup-let): Remove. (cconv-closure-convert-function): Extract from cconv-closure-convert-rec. (cconv-closure-convert-rec): Adjust to above changes. (fboundp): New function. (cconv-analyse-function, form): Rewrite. * lisp/emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment): Handle declare-function here. (byte-compile-obsolete): Remove. (byte-compile-arglist-warn): Check late defsubst here. (byte-compile-file-form): Simplify. (byte-compile-file-form-defsubst): Remove. (byte-compile-macroexpand-declare-function): Rename from byte-compile-declare-function, turn it into a macro-expander. (byte-compile-normal-call): Check obsolescence. (byte-compile-quote-form): Remove. (byte-compile-defmacro): Revert to trunk's definition which seems to work just as well and handles `declare'. * lisp/emacs-lisp/byte-run.el (make-obsolete): Don't modify byte-compile. * lisp/Makefile.in (BIG_STACK_DEPTH): Increase to 1200. (compile-onefile): Pass $(BIG_STACK_OPTS) before "-l bytecomp". * lisp/emacs-lisp/macroexp.el: Use lexbind. (macroexpand-all-1): Check macro obsolescence. * lisp/vc/diff-mode.el: Use lexbind. * lisp/follow.el (follow-calc-win-end): Simplify.
This commit is contained in:
Stefan Monnier
parent
876c194cba
commit
a9de04fa62
@ -1,3 +1,36 @@
|
||||
2011-02-26 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/cconv.el: Compute freevars in cconv-analyse.
|
||||
(cconv-mutated, cconv-captured): Remove.
|
||||
(cconv-captured+mutated, cconv-lambda-candidates): Don't give them
|
||||
a global value.
|
||||
(cconv-freevars-alist): New var.
|
||||
(cconv-freevars): Remove.
|
||||
(cconv--lookup-let): Remove.
|
||||
(cconv-closure-convert-function): Extract from cconv-closure-convert-rec.
|
||||
(cconv-closure-convert-rec): Adjust to above changes.
|
||||
(fboundp): New function.
|
||||
(cconv-analyse-function, form): Rewrite.
|
||||
* emacs-lisp/bytecomp.el (byte-compile-initial-macro-environment):
|
||||
Handle declare-function here.
|
||||
(byte-compile-obsolete): Remove.
|
||||
(byte-compile-arglist-warn): Check late defsubst here.
|
||||
(byte-compile-file-form): Simplify.
|
||||
(byte-compile-file-form-defsubst): Remove.
|
||||
(byte-compile-macroexpand-declare-function): Rename from
|
||||
byte-compile-declare-function, turn it into a macro-expander.
|
||||
(byte-compile-normal-call): Check obsolescence.
|
||||
(byte-compile-quote-form): Remove.
|
||||
(byte-compile-defmacro): Revert to trunk's definition which seems to
|
||||
work just as well and handles `declare'.
|
||||
* emacs-lisp/byte-run.el (make-obsolete): Don't modify byte-compile.
|
||||
* Makefile.in (BIG_STACK_DEPTH): Increase to 1200.
|
||||
(compile-onefile): Pass $(BIG_STACK_OPTS) before "-l bytecomp".
|
||||
* emacs-lisp/macroexp.el: Use lexbind.
|
||||
(macroexpand-all-1): Check macro obsolescence.
|
||||
* vc/diff-mode.el: Use lexbind.
|
||||
* follow.el (follow-calc-win-end): Simplify.
|
||||
|
||||
2011-02-25 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/bytecomp.el (byte-compile-lapcode): Handle new form of
|
||||
|
||||
@ -74,7 +74,7 @@ AUTOGENEL = loaddefs.el \
|
||||
# During bootstrapping the byte-compiler is run interpreted when compiling
|
||||
# itself, and uses more stack than usual.
|
||||
#
|
||||
BIG_STACK_DEPTH = 1000
|
||||
BIG_STACK_DEPTH = 1200
|
||||
BIG_STACK_OPTS = --eval "(setq max-lisp-eval-depth $(BIG_STACK_DEPTH))"
|
||||
|
||||
# Files to compile before others during a bootstrap. This is done to
|
||||
@ -205,8 +205,8 @@ compile-onefile:
|
||||
@echo Compiling $(THEFILE)
|
||||
@# Use byte-compile-refresh-preloaded to try and work around some of
|
||||
@# the most common bootstrapping problems.
|
||||
$(emacs) -l bytecomp.el -f byte-compile-refresh-preloaded \
|
||||
$(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \
|
||||
@$(emacs) $(BIG_STACK_OPTS) -l bytecomp $(BYTE_COMPILE_EXTRA_FLAGS) \
|
||||
-f byte-compile-refresh-preloaded \
|
||||
-f batch-byte-compile $(THEFILE)
|
||||
|
||||
# Files MUST be compiled one by one. If we compile several files in a
|
||||
@ -222,7 +222,7 @@ compile-onefile:
|
||||
# cannot have prerequisites.
|
||||
.el.elc:
|
||||
@echo Compiling $<
|
||||
$(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \
|
||||
@$(emacs) $(BIG_STACK_OPTS) $(BYTE_COMPILE_EXTRA_FLAGS) \
|
||||
-f batch-byte-compile $<
|
||||
|
||||
.PHONY: compile-first compile-main compile compile-always
|
||||
|
||||
@ -123,12 +123,10 @@ If CURRENT-NAME is a string, that is the `use instead' message
|
||||
If provided, WHEN should be a string indicating when the function
|
||||
was first made obsolete, for example a date or a release number."
|
||||
(interactive "aMake function obsolete: \nxObsoletion replacement: ")
|
||||
(let ((handler (get obsolete-name 'byte-compile)))
|
||||
(if (eq 'byte-compile-obsolete handler)
|
||||
(setq handler (nth 1 (get obsolete-name 'byte-obsolete-info)))
|
||||
(put obsolete-name 'byte-compile 'byte-compile-obsolete))
|
||||
(put obsolete-name 'byte-obsolete-info
|
||||
(list (purecopy current-name) handler (purecopy when))))
|
||||
(put obsolete-name 'byte-obsolete-info
|
||||
;; The second entry used to hold the `byte-compile' handler, but
|
||||
;; is not used any more nowadays.
|
||||
(list (purecopy current-name) nil (purecopy when)))
|
||||
obsolete-name)
|
||||
(set-advertised-calling-convention
|
||||
;; New code should always provide the `when' argument.
|
||||
|
||||
@ -424,6 +424,7 @@ This list lives partly on the stack.")
|
||||
'(
|
||||
;; (byte-compiler-options . (lambda (&rest forms)
|
||||
;; (apply 'byte-compiler-options-handler forms)))
|
||||
(declare-function . byte-compile-macroexpand-declare-function)
|
||||
(eval-when-compile . (lambda (&rest body)
|
||||
(list
|
||||
'quote
|
||||
@ -1140,13 +1141,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
|
||||
(byte-compile-log-warning
|
||||
(error-message-string error-info)
|
||||
nil :error))
|
||||
|
||||
;;; Used by make-obsolete.
|
||||
(defun byte-compile-obsolete (form)
|
||||
(byte-compile-set-symbol-position (car form))
|
||||
(byte-compile-warn-obsolete (car form))
|
||||
(funcall (or (cadr (get (car form) 'byte-obsolete-info)) ; handler
|
||||
'byte-compile-normal-call) form))
|
||||
|
||||
;;; sanity-checking arglists
|
||||
|
||||
@ -1328,7 +1322,8 @@ extra args."
|
||||
;; Warn if the function or macro is being redefined with a different
|
||||
;; number of arguments.
|
||||
(defun byte-compile-arglist-warn (form macrop)
|
||||
(let ((old (byte-compile-fdefinition (nth 1 form) macrop)))
|
||||
(let* ((name (nth 1 form))
|
||||
(old (byte-compile-fdefinition name macrop)))
|
||||
(if (and old (not (eq old t)))
|
||||
(progn
|
||||
(and (eq 'macro (car-safe old))
|
||||
@ -1342,36 +1337,39 @@ extra args."
|
||||
(t '(&rest def)))))
|
||||
(sig2 (byte-compile-arglist-signature (nth 2 form))))
|
||||
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
|
||||
(byte-compile-set-symbol-position (nth 1 form))
|
||||
(byte-compile-set-symbol-position name)
|
||||
(byte-compile-warn
|
||||
"%s %s used to take %s %s, now takes %s"
|
||||
(if (eq (car form) 'defun) "function" "macro")
|
||||
(nth 1 form)
|
||||
name
|
||||
(byte-compile-arglist-signature-string sig1)
|
||||
(if (equal sig1 '(1 . 1)) "argument" "arguments")
|
||||
(byte-compile-arglist-signature-string sig2)))))
|
||||
;; This is the first definition. See if previous calls are compatible.
|
||||
(let ((calls (assq (nth 1 form) byte-compile-unresolved-functions))
|
||||
(let ((calls (assq name byte-compile-unresolved-functions))
|
||||
nums sig min max)
|
||||
(if calls
|
||||
(progn
|
||||
(setq sig (byte-compile-arglist-signature (nth 2 form))
|
||||
nums (sort (copy-sequence (cdr calls)) (function <))
|
||||
min (car nums)
|
||||
max (car (nreverse nums)))
|
||||
(when (or (< min (car sig))
|
||||
(and (cdr sig) (> max (cdr sig))))
|
||||
(byte-compile-set-symbol-position (nth 1 form))
|
||||
(byte-compile-warn
|
||||
"%s being defined to take %s%s, but was previously called with %s"
|
||||
(nth 1 form)
|
||||
(byte-compile-arglist-signature-string sig)
|
||||
(if (equal sig '(1 . 1)) " arg" " args")
|
||||
(byte-compile-arglist-signature-string (cons min max))))
|
||||
(when calls
|
||||
(when (and (symbolp name)
|
||||
(eq (get name 'byte-optimizer)
|
||||
'byte-compile-inline-expand))
|
||||
(byte-compile-warn "defsubst `%s' was used before it was defined"
|
||||
name))
|
||||
(setq sig (byte-compile-arglist-signature (nth 2 form))
|
||||
nums (sort (copy-sequence (cdr calls)) (function <))
|
||||
min (car nums)
|
||||
max (car (nreverse nums)))
|
||||
(when (or (< min (car sig))
|
||||
(and (cdr sig) (> max (cdr sig))))
|
||||
(byte-compile-set-symbol-position name)
|
||||
(byte-compile-warn
|
||||
"%s being defined to take %s%s, but was previously called with %s"
|
||||
name
|
||||
(byte-compile-arglist-signature-string sig)
|
||||
(if (equal sig '(1 . 1)) " arg" " args")
|
||||
(byte-compile-arglist-signature-string (cons min max))))
|
||||
|
||||
(setq byte-compile-unresolved-functions
|
||||
(delq calls byte-compile-unresolved-functions)))))
|
||||
)))
|
||||
(setq byte-compile-unresolved-functions
|
||||
(delq calls byte-compile-unresolved-functions)))))))
|
||||
|
||||
(defvar byte-compile-cl-functions nil
|
||||
"List of functions defined in CL.")
|
||||
@ -1470,7 +1468,7 @@ symbol itself."
|
||||
(if any-value
|
||||
(or (memq symbol byte-compile-const-variables)
|
||||
;; FIXME: We should provide a less intrusive way to find out
|
||||
;; is a variable is "constant".
|
||||
;; if a variable is "constant".
|
||||
(and (boundp symbol)
|
||||
(condition-case nil
|
||||
(progn (set symbol (symbol-value symbol)) nil)
|
||||
@ -2198,9 +2196,8 @@ list that represents a doc string reference.
|
||||
;; byte-hunk-handlers can call this.
|
||||
(defun byte-compile-file-form (form)
|
||||
(let (bytecomp-handler)
|
||||
(cond ((not (consp form))
|
||||
(byte-compile-keep-pending form))
|
||||
((and (symbolp (car form))
|
||||
(cond ((and (consp form)
|
||||
(symbolp (car form))
|
||||
(setq bytecomp-handler (get (car form) 'byte-hunk-handler)))
|
||||
(cond ((setq form (funcall bytecomp-handler form))
|
||||
(byte-compile-flush-pending)
|
||||
@ -2212,16 +2209,6 @@ list that represents a doc string reference.
|
||||
;; so make-docfile can recognise them. Most other things can be output
|
||||
;; as byte-code.
|
||||
|
||||
(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
|
||||
(defun byte-compile-file-form-defsubst (form)
|
||||
(when (assq (nth 1 form) byte-compile-unresolved-functions)
|
||||
(setq byte-compile-current-form (nth 1 form))
|
||||
(byte-compile-warn "defsubst `%s' was used before it was defined"
|
||||
(nth 1 form)))
|
||||
(byte-compile-file-form form)
|
||||
;; Return nil so the form is not output twice.
|
||||
nil)
|
||||
|
||||
(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
|
||||
(defun byte-compile-file-form-autoload (form)
|
||||
(and (let ((form form))
|
||||
@ -2914,7 +2901,6 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
||||
|
||||
;; Given BYTECOMP-BODY, compile it and return a new body.
|
||||
(defun byte-compile-top-level-body (bytecomp-body &optional for-effect)
|
||||
;; FIXME: lexbind. Check all callers!
|
||||
(setq bytecomp-body
|
||||
(byte-compile-top-level (cons 'progn bytecomp-body) for-effect t))
|
||||
(cond ((eq (car-safe bytecomp-body) 'progn)
|
||||
@ -2922,20 +2908,18 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
||||
(bytecomp-body
|
||||
(list bytecomp-body))))
|
||||
|
||||
;; FIXME: Like defsubst's, this hunk-handler won't be called any more
|
||||
;; because the macro is expanded away before we see it.
|
||||
(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function)
|
||||
(defun byte-compile-declare-function (form)
|
||||
(push (cons (nth 1 form)
|
||||
(if (and (> (length form) 3)
|
||||
(listp (nth 3 form)))
|
||||
(list 'declared (nth 3 form))
|
||||
;; Special macro-expander used during byte-compilation.
|
||||
(defun byte-compile-macroexpand-declare-function (fn file &rest args)
|
||||
(push (cons fn
|
||||
(if (and (consp args) (listp (car args)))
|
||||
(list 'declared (car args))
|
||||
t)) ; arglist not specified
|
||||
byte-compile-function-environment)
|
||||
;; We are stating that it _will_ be defined at runtime.
|
||||
(setq byte-compile-noruntime-functions
|
||||
(delq (nth 1 form) byte-compile-noruntime-functions))
|
||||
nil)
|
||||
(delq fn byte-compile-noruntime-functions))
|
||||
;; Delegate the rest to the normal macro definition.
|
||||
(macroexpand `(declare-function ,fn ,file ,@args)))
|
||||
|
||||
|
||||
;; This is the recursive entry point for compiling each subform of an
|
||||
@ -3005,6 +2989,8 @@ That command is designed for interactive use only" bytecomp-fn))
|
||||
'(custom-declare-group custom-declare-variable
|
||||
custom-declare-face))
|
||||
(byte-compile-nogroup-warn form))
|
||||
(when (get (car form) 'byte-obsolete-info)
|
||||
(byte-compile-warn-obsolete (car form)))
|
||||
(byte-compile-callargs-warn form))
|
||||
(if byte-compile-generate-call-tree
|
||||
(byte-compile-annotate-call-tree form))
|
||||
@ -3562,7 +3548,6 @@ discarding."
|
||||
(byte-defop-compiler-1 setq)
|
||||
(byte-defop-compiler-1 setq-default)
|
||||
(byte-defop-compiler-1 quote)
|
||||
(byte-defop-compiler-1 quote-form)
|
||||
|
||||
(defun byte-compile-setq (form)
|
||||
(let ((bytecomp-args (cdr form)))
|
||||
@ -3606,10 +3591,6 @@ discarding."
|
||||
|
||||
(defun byte-compile-quote (form)
|
||||
(byte-compile-constant (car (cdr form))))
|
||||
|
||||
(defun byte-compile-quote-form (form)
|
||||
(byte-compile-constant (byte-compile-top-level (nth 1 form))))
|
||||
|
||||
|
||||
;;; control structures
|
||||
|
||||
@ -3845,6 +3826,7 @@ Return the offset in the form (VAR . OFFSET)."
|
||||
(byte-compile-push-constant nil)))))
|
||||
|
||||
(defun byte-compile-not-lexical-var-p (var)
|
||||
;; FIXME: this doesn't catch defcustoms!
|
||||
(or (not (symbolp var))
|
||||
(special-variable-p var)
|
||||
(memq var byte-compile-bound-variables)
|
||||
@ -4097,15 +4079,16 @@ binding slots have been popped."
|
||||
|
||||
(defun byte-compile-defmacro (form)
|
||||
;; This is not used for file-level defmacros with doc strings.
|
||||
;; FIXME handle decls, use defalias?
|
||||
(let ((decls (byte-compile-defmacro-declaration form))
|
||||
(code (byte-compile-lambda (cdr (cdr form)) t))
|
||||
(for-effect nil))
|
||||
(byte-compile-push-constant (nth 1 form))
|
||||
(byte-compile-push-constant (cons 'macro code))
|
||||
(byte-compile-out 'byte-fset)
|
||||
(byte-compile-discard))
|
||||
(byte-compile-constant (nth 1 form)))
|
||||
(byte-compile-body-do-effect
|
||||
(let ((decls (byte-compile-defmacro-declaration form))
|
||||
(code (byte-compile-byte-code-maker
|
||||
(byte-compile-lambda (cdr (cdr form)) t))))
|
||||
`((defalias ',(nth 1 form)
|
||||
,(if (eq (car-safe code) 'make-byte-code)
|
||||
`(cons 'macro ,code)
|
||||
`'(macro . ,(eval code))))
|
||||
,@decls
|
||||
',(nth 1 form)))))
|
||||
|
||||
(defun byte-compile-defvar (form)
|
||||
;; This is not used for file-level defvar/consts with doc strings.
|
||||
@ -4153,7 +4136,7 @@ binding slots have been popped."
|
||||
`(if (not (default-boundp ',var)) (setq-default ,var ,value))))
|
||||
(when (eq fun 'defconst)
|
||||
;; This will signal an appropriate error at runtime.
|
||||
`(eval ',form))) ;FIXME: lexbind
|
||||
`(eval ',form)))
|
||||
`',var))))
|
||||
|
||||
(defun byte-compile-autoload (form)
|
||||
|
||||
@ -82,110 +82,19 @@
|
||||
(defconst cconv-liftwhen 3
|
||||
"Try to do lambda lifting if the number of arguments + free variables
|
||||
is less than this number.")
|
||||
(defvar cconv-mutated nil
|
||||
"List of mutated variables in current form")
|
||||
(defvar cconv-captured nil
|
||||
"List of closure captured variables in current form")
|
||||
(defvar cconv-captured+mutated nil
|
||||
"An intersection between cconv-mutated and cconv-captured lists.")
|
||||
(defvar cconv-lambda-candidates nil
|
||||
"List of candidates for lambda lifting.
|
||||
Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).")
|
||||
;; List of all the variables that are both captured by a closure
|
||||
;; and mutated. Each entry in the list takes the form
|
||||
;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the
|
||||
;; variable (or is just (VAR) for variables not introduced by let).
|
||||
(defvar cconv-captured+mutated)
|
||||
|
||||
(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
|
||||
;; List of candidates for lambda lifting.
|
||||
;; Each candidate has the form (BINDER . PARENTFORM). A candidate
|
||||
;; is a variable that is only passed to `funcall' or `apply'.
|
||||
(defvar cconv-lambda-candidates)
|
||||
|
||||
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 return 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)
|
||||
(setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1)))
|
||||
(setq fvrs (nconc fvrs-1 fvrs))
|
||||
(dolist (exp varsvalues)
|
||||
(when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs))))
|
||||
fvrs))
|
||||
|
||||
(`(let* ,varsvalues . ,body-forms) ; let* special form
|
||||
(let ((vrs '())
|
||||
(fvrs-1 '()))
|
||||
(dolist (exp varsvalues)
|
||||
(if (consp 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 '()))
|
||||
(dolist (exp conditions-bodies)
|
||||
(setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)))
|
||||
(setq fvrs-1 (delq var fvrs-1))
|
||||
(setq fvrs-1 (cconv-freevars protected-form 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)
|
||||
(cconv-freevars `(progn ,@(cddr form)) fvrs))
|
||||
|
||||
(`(,_ . ,body-forms) ; First element is (like) a function.
|
||||
(dolist (exp body-forms)
|
||||
(setq fvrs (cconv-freevars exp fvrs))) fvrs)
|
||||
|
||||
(_ (if (byte-compile-not-lexical-var-p form)
|
||||
fvrs
|
||||
(cons form fvrs)))))
|
||||
;; Alist associating to each function body the list of its free variables.
|
||||
(defvar cconv-freevars-alist)
|
||||
|
||||
;;;###autoload
|
||||
(defun cconv-closure-convert (form)
|
||||
@ -195,16 +104,12 @@ Returns a list of free variables."
|
||||
|
||||
Returns a form where all lambdas don't have any free variables."
|
||||
;; (message "Entering cconv-closure-convert...")
|
||||
(let ((cconv-mutated '())
|
||||
(let ((cconv-freevars-alist '())
|
||||
(cconv-lambda-candidates '())
|
||||
(cconv-captured '())
|
||||
(cconv-captured+mutated '()))
|
||||
;; Analyse form - fill these variables with new information.
|
||||
(cconv-analyse-form form '() 0)
|
||||
;; Calculate an intersection of cconv-mutated and cconv-captured.
|
||||
(dolist (mvr cconv-mutated)
|
||||
(when (memq mvr cconv-captured) ;
|
||||
(push mvr cconv-captured+mutated)))
|
||||
(cconv-analyse-form form '())
|
||||
(setq cconv-freevars-alist (nreverse cconv-freevars-alist))
|
||||
(cconv-closure-convert-rec
|
||||
form ; the tree
|
||||
'() ;
|
||||
@ -213,15 +118,6 @@ Returns a form where all lambdas don't have any free variables."
|
||||
'()
|
||||
)))
|
||||
|
||||
(defun cconv--lookup-let (table var binder form)
|
||||
(let ((res nil))
|
||||
(dolist (elem table)
|
||||
(when (and (eq (nth 2 elem) binder)
|
||||
(eq (nth 3 elem) form))
|
||||
(assert (eq (car elem) var))
|
||||
(setq res elem)))
|
||||
res))
|
||||
|
||||
(defconst cconv--dummy-var (make-symbol "ignored"))
|
||||
|
||||
(defun cconv--set-diff (s1 s2)
|
||||
@ -261,6 +157,57 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(unless (memq (car b) s) (push b res)))
|
||||
(nreverse res)))
|
||||
|
||||
(defun cconv-closure-convert-function (fvrs vars emvrs envs lmenvs body-forms
|
||||
parentform)
|
||||
(assert (equal body-forms (caar cconv-freevars-alist)))
|
||||
(let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs.
|
||||
(fv (cdr (pop cconv-freevars-alist)))
|
||||
(body-forms-new '())
|
||||
(letbind '())
|
||||
(envector nil))
|
||||
(when fv
|
||||
;; Here we form our environment vector.
|
||||
|
||||
(dolist (elm fv)
|
||||
(push
|
||||
(cconv-closure-convert-rec
|
||||
;; Remove `elm' from `emvrs' for this call because in case
|
||||
;; `elm' is a variable that's wrapped in a cons-cell, we
|
||||
;; want to put the cons-cell itself in the closure, rather
|
||||
;; than just a copy of its current content.
|
||||
elm (remq elm emvrs) fvrs envs lmenvs)
|
||||
envector)) ; Process vars for closure vector.
|
||||
(setq envector (reverse envector))
|
||||
(setq envs fv)
|
||||
(setq fvrs-new fv)) ; Update substitution list.
|
||||
|
||||
(setq emvrs (cconv--set-diff emvrs vars))
|
||||
(setq lmenvs (cconv--map-diff-set lmenvs vars))
|
||||
|
||||
;; The difference between envs and fvrs is explained
|
||||
;; in comment in the beginning of the function.
|
||||
(dolist (var vars)
|
||||
(when (member (cons (list var) parentform) cconv-captured+mutated)
|
||||
(push var emvrs)
|
||||
(push `(,var (list ,var)) letbind)))
|
||||
(dolist (elm body-forms) ; convert function body
|
||||
(push (cconv-closure-convert-rec
|
||||
elm emvrs fvrs-new envs lmenvs)
|
||||
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
|
||||
(t
|
||||
`(internal-make-closure
|
||||
,vars ,envector . ,body-forms-new)))))
|
||||
|
||||
(defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs)
|
||||
;; This function actually rewrites the tree.
|
||||
"Eliminates all free variables of all lambdas in given forms.
|
||||
@ -303,15 +250,18 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(dolist (binder binders)
|
||||
(let* ((value nil)
|
||||
(var (if (not (consp binder))
|
||||
binder
|
||||
(prog1 binder (setq binder (list binder)))
|
||||
(setq value (cadr binder))
|
||||
(car binder)))
|
||||
(new-val
|
||||
(cond
|
||||
;; Check if var is a candidate for lambda lifting.
|
||||
((cconv--lookup-let cconv-lambda-candidates var binder form)
|
||||
|
||||
(let* ((fv (delete-dups (cconv-freevars value '())))
|
||||
((member (cons binder form) cconv-lambda-candidates)
|
||||
(assert (and (eq (car value) 'function)
|
||||
(eq (car (cadr value)) 'lambda)))
|
||||
(assert (equal (cddr (cadr value))
|
||||
(caar cconv-freevars-alist)))
|
||||
(let* ((fv (cdr (pop cconv-freevars-alist)))
|
||||
(funargs (cadr (cadr value)))
|
||||
(funcvars (append fv funargs))
|
||||
(funcbodies (cddadr value)) ; function bodies
|
||||
@ -338,7 +288,7 @@ Returns a form where all lambdas don't have any free variables."
|
||||
,(reverse funcbodies-new))))))))
|
||||
|
||||
;; Check if it needs to be turned into a "ref-cell".
|
||||
((cconv--lookup-let cconv-captured+mutated var binder form)
|
||||
((member (cons binder form) cconv-captured+mutated)
|
||||
;; Declared variable is mutated and captured.
|
||||
(prog1
|
||||
`(list ,(cconv-closure-convert-rec
|
||||
@ -404,13 +354,12 @@ Returns a form where all lambdas don't have any free variables."
|
||||
)) ; end of dolist over binders
|
||||
(when (eq letsym 'let)
|
||||
|
||||
(let (var fvrs-1 emvrs-1 lmenvs-1)
|
||||
;; Here we update emvrs, fvrs and lmenvs lists
|
||||
(setq fvrs (cconv--set-diff-map fvrs binders-new))
|
||||
(setq emvrs (cconv--set-diff-map emvrs binders-new))
|
||||
(setq emvrs (append emvrs emvrs-new))
|
||||
(setq lmenvs (cconv--set-diff-map lmenvs binders-new))
|
||||
(setq lmenvs (append lmenvs lmenvs-new)))
|
||||
;; Here we update emvrs, fvrs and lmenvs lists
|
||||
(setq fvrs (cconv--set-diff-map fvrs binders-new))
|
||||
(setq emvrs (cconv--set-diff-map emvrs binders-new))
|
||||
(setq emvrs (append emvrs emvrs-new))
|
||||
(setq lmenvs (cconv--set-diff-map lmenvs binders-new))
|
||||
(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
|
||||
@ -478,56 +427,8 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(`(quote . ,_) form)
|
||||
|
||||
(`(function (lambda ,vars . ,body-forms)) ; function form
|
||||
(let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs.
|
||||
(fv (delete-dups (cconv-freevars form '())))
|
||||
(leave fvrs-new) ; 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.
|
||||
|
||||
(dolist (elm fv)
|
||||
(push
|
||||
(cconv-closure-convert-rec
|
||||
;; Remove `elm' from `emvrs' for this call because in case
|
||||
;; `elm' is a variable that's wrapped in a cons-cell, we
|
||||
;; want to put the cons-cell itself in the closure, rather
|
||||
;; than just a copy of its current content.
|
||||
elm (remq elm emvrs) fvrs envs lmenvs)
|
||||
envector)) ; Process vars for closure vector.
|
||||
(setq envector (reverse envector))
|
||||
(setq envs fv)
|
||||
(setq fvrs-new fv)) ; Update substitution list.
|
||||
|
||||
(setq emvrs (cconv--set-diff emvrs vars))
|
||||
(setq lmenvs (cconv--map-diff-set lmenvs vars))
|
||||
|
||||
;; 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-new envs lmenvs)
|
||||
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
|
||||
(t
|
||||
`(internal-make-closure
|
||||
,vars ,envector . ,body-forms-new)))))
|
||||
(cconv-closure-convert-function
|
||||
fvrs vars emvrs envs lmenvs body-forms form))
|
||||
|
||||
(`(internal-make-closure . ,_)
|
||||
(error "Internal byte-compiler error: cconv called twice"))
|
||||
@ -548,21 +449,21 @@ Returns a form where all lambdas don't have any free variables."
|
||||
;defun, defmacro
|
||||
(`(,(and sym (or `defun `defmacro))
|
||||
,func ,vars . ,body-forms)
|
||||
|
||||
;; The freevar data was pushed onto cconv-freevars-alist
|
||||
;; but we don't need it.
|
||||
(assert (equal body-forms (caar cconv-freevars-alist)))
|
||||
(assert (null (cdar cconv-freevars-alist)))
|
||||
(setq cconv-freevars-alist (cdr cconv-freevars-alist))
|
||||
|
||||
(let ((body-new '()) ; The whole body.
|
||||
(body-forms-new '()) ; Body w\o docstring and interactive.
|
||||
(letbind '()))
|
||||
; Find mutable arguments.
|
||||
(dolist (elm vars)
|
||||
(let ((lmutated cconv-captured+mutated)
|
||||
(ismutated nil))
|
||||
(while (and lmutated (not ismutated))
|
||||
(when (and (eq (caar lmutated) elm)
|
||||
(eq (caddar lmutated) form))
|
||||
(setq ismutated t))
|
||||
(setq lmutated (cdr lmutated)))
|
||||
(when ismutated
|
||||
(push elm letbind)
|
||||
(push elm emvrs))))
|
||||
(when (member (cons (list elm) form) cconv-captured+mutated)
|
||||
(push elm letbind)
|
||||
(push elm emvrs)))
|
||||
;Transform body-forms.
|
||||
(when (stringp (car body-forms)) ; Treat docstring well.
|
||||
(push (car body-forms) body-new)
|
||||
@ -629,12 +530,13 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(setq value
|
||||
(cconv-closure-convert-rec
|
||||
(cadr forms) emvrs fvrs envs lmenvs))
|
||||
(if (memq sym emvrs)
|
||||
(push `(setcar ,sym-new ,value) prognlist)
|
||||
(if (symbolp sym-new)
|
||||
(push `(setq ,sym-new ,value) prognlist)
|
||||
(debug) ;FIXME: When can this be right?
|
||||
(push `(set ,sym-new ,value) prognlist)))
|
||||
(cond
|
||||
((memq sym emvrs) (push `(setcar ,sym-new ,value) prognlist))
|
||||
((symbolp sym-new) (push `(setq ,sym-new ,value) prognlist))
|
||||
;; This should never happen, but for variables which are
|
||||
;; mutated+captured+unused, we may end up trying to `setq'
|
||||
;; on a closed-over variable, so just drop the setq.
|
||||
(t (push value prognlist)))
|
||||
(setq forms (cddr forms)))
|
||||
(if (cdr prognlist)
|
||||
`(progn . ,(reverse prognlist))
|
||||
@ -697,54 +599,110 @@ Returns a form where all lambdas don't have any free variables."
|
||||
`(car ,form) ; replace form => (car form)
|
||||
form))))))
|
||||
|
||||
(defun cconv-analyse-function (args body env parentform inclosure)
|
||||
(dolist (arg args)
|
||||
(cond
|
||||
((byte-compile-not-lexical-var-p arg)
|
||||
(byte-compile-report-error
|
||||
(format "Argument %S is not a lexical variable" arg)))
|
||||
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
|
||||
(t (push (list arg inclosure parentform) env)))) ;Push vrs to vars.
|
||||
(dolist (form body) ;Analyse body forms.
|
||||
(cconv-analyse-form form env inclosure)))
|
||||
(unless (fboundp 'byte-compile-not-lexical-var-p)
|
||||
;; Only used to test the code in non-lexbind Emacs.
|
||||
(defalias 'byte-compile-not-lexical-var-p 'boundp))
|
||||
|
||||
(defun cconv-analyse-form (form env inclosure)
|
||||
"Find mutated variables and variables captured by closure. Analyse
|
||||
lambdas if they are suitable for lambda lifting.
|
||||
(defun cconv-analyse-use (vardata form)
|
||||
;; use = `(,binder ,read ,mutated ,captured ,called)
|
||||
(pcase vardata
|
||||
(`(,binder nil ,_ ,_ nil)
|
||||
;; FIXME: Don't warn about unused fun-args.
|
||||
;; FIXME: Don't warn about uninterned vars or _ vars.
|
||||
;; FIXME: This gives warnings in the wrong order and with wrong line
|
||||
;; number and without function name info.
|
||||
(byte-compile-log-warning (format "Unused variable %S" (car binder))))
|
||||
;; If it's unused, there's no point converting it into a cons-cell, even if
|
||||
;; it's captures and mutated.
|
||||
(`(,binder ,_ t t ,_)
|
||||
(push (cons binder form) cconv-captured+mutated))
|
||||
(`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
|
||||
;; This is very rare in typical Elisp code. It's probably not really
|
||||
;; worth the trouble to try and use lambda-lifting in Elisp, but
|
||||
;; since we coded it up, we might as well use it.
|
||||
(push (cons binder form) cconv-lambda-candidates))
|
||||
(`(,_ ,_ ,_ ,_ ,_) nil)
|
||||
(dontcare)))
|
||||
|
||||
(defun cconv-analyse-function (args body env parentform)
|
||||
(let* ((newvars nil)
|
||||
(freevars (list body))
|
||||
;; We analyze the body within a new environment where all uses are
|
||||
;; nil, so we can distinguish uses within that function from uses
|
||||
;; outside of it.
|
||||
(envcopy
|
||||
(mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env))
|
||||
(newenv envcopy))
|
||||
;; Push it before recursing, so cconv-freevars-alist contains entries in
|
||||
;; the order they'll be used by closure-convert-rec.
|
||||
(push freevars cconv-freevars-alist)
|
||||
(dolist (arg args)
|
||||
(cond
|
||||
((byte-compile-not-lexical-var-p arg)
|
||||
(byte-compile-report-error
|
||||
(format "Argument %S is not a lexical variable" arg)))
|
||||
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
|
||||
(t (let ((varstruct (list arg nil nil nil nil)))
|
||||
(push (cons (list arg) (cdr varstruct)) newvars)
|
||||
(push varstruct newenv)))))
|
||||
(dolist (form body) ;Analyse body forms.
|
||||
(cconv-analyse-form form newenv))
|
||||
;; Summarize resulting data about arguments.
|
||||
(dolist (vardata newvars)
|
||||
(cconv-analyse-use vardata parentform))
|
||||
;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
|
||||
;; and compute free variables.
|
||||
(while env
|
||||
(assert (and envcopy (eq (caar env) (caar envcopy))))
|
||||
(let ((free nil)
|
||||
(x (cdr (car env)))
|
||||
(y (cdr (car envcopy))))
|
||||
(while x
|
||||
(when (car y) (setcar x t) (setq free t))
|
||||
(setq x (cdr x) y (cdr y)))
|
||||
(when free
|
||||
(push (caar env) (cdr freevars))
|
||||
(setf (nth 3 (car env)) t))
|
||||
(setq env (cdr env) envcopy (cdr envcopy))))))
|
||||
|
||||
(defun cconv-analyse-form (form env)
|
||||
"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.
|
||||
-- ENV is a list of variables visible in current lexical environment.
|
||||
Each entry has the form (VAR INCLOSURE BINDER PARENTFORM)
|
||||
for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments.
|
||||
-- INCLOSURE is the nesting level within lambdas."
|
||||
-- ENV is an alist mapping each enclosing lexical variable to its info.
|
||||
I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)).
|
||||
This function does not return anything but instead fills the
|
||||
`cconv-captured+mutated' and `cconv-lambda-candidates' variables
|
||||
and updates the data stored in ENV."
|
||||
(pcase form
|
||||
; let special form
|
||||
(`(,(and (or `let* `let) letsym) ,binders . ,body-forms)
|
||||
|
||||
(let ((orig-env env)
|
||||
(newvars nil)
|
||||
(var nil)
|
||||
(value nil))
|
||||
(dolist (binder binders)
|
||||
(if (not (consp binder))
|
||||
(progn
|
||||
(setq var binder) ; treat the form (let (x) ...) well
|
||||
(setq binder (list binder))
|
||||
(setq value nil))
|
||||
(setq var (car binder))
|
||||
(setq value (cadr binder))
|
||||
|
||||
(cconv-analyse-form value (if (eq letsym 'let*) env orig-env)
|
||||
inclosure))
|
||||
(cconv-analyse-form value (if (eq letsym 'let*) env orig-env)))
|
||||
|
||||
(unless (byte-compile-not-lexical-var-p var)
|
||||
(let ((varstruct (list var inclosure binder form)))
|
||||
(push varstruct env) ; Push a new one.
|
||||
(let ((varstruct (list var nil nil nil nil)))
|
||||
(push (cons binder (cdr varstruct)) newvars)
|
||||
(push varstruct env))))
|
||||
|
||||
(pcase value
|
||||
(`(function (lambda . ,_))
|
||||
;; If var is a function push it to lambda list.
|
||||
(push varstruct cconv-lambda-candidates)))))))
|
||||
(dolist (form body-forms) ; Analyse body forms.
|
||||
(cconv-analyse-form form env))
|
||||
|
||||
(dolist (form body-forms) ; Analyse body forms.
|
||||
(cconv-analyse-form form env inclosure)))
|
||||
(dolist (vardata newvars)
|
||||
(cconv-analyse-use vardata form))))
|
||||
|
||||
; defun special form
|
||||
(`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
|
||||
@ -753,33 +711,28 @@ lambdas if they are suitable for lambda lifting.
|
||||
(format "Function %S will ignore its context %S"
|
||||
func (mapcar #'car env))
|
||||
t :warning))
|
||||
(cconv-analyse-function vrs body-forms nil form 0))
|
||||
(cconv-analyse-function vrs body-forms nil form))
|
||||
|
||||
(`(function (lambda ,vrs . ,body-forms))
|
||||
(cconv-analyse-function vrs body-forms env form (1+ inclosure)))
|
||||
(cconv-analyse-function vrs body-forms env form))
|
||||
|
||||
(`(setq . ,forms)
|
||||
;; If a local variable (member of env) is modified by setq then
|
||||
;; it is a mutated variable.
|
||||
(while forms
|
||||
(let ((v (assq (car forms) env))) ; 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))
|
||||
(unless (eq inclosure (cadr v)) ;Bound in a different closure level.
|
||||
(push v cconv-captured))))
|
||||
(cconv-analyse-form (cadr forms) env inclosure)
|
||||
(when v (setf (nth 2 v) t)))
|
||||
(cconv-analyse-form (cadr forms) env)
|
||||
(setq forms (cddr forms))))
|
||||
|
||||
(`((lambda . ,_) . ,_) ; first element is lambda expression
|
||||
(dolist (exp `((function ,(car form)) . ,(cdr form)))
|
||||
(cconv-analyse-form exp env inclosure)))
|
||||
(cconv-analyse-form exp env)))
|
||||
|
||||
(`(cond . ,cond-forms) ; cond special form
|
||||
(dolist (forms cond-forms)
|
||||
(dolist (form forms)
|
||||
(cconv-analyse-form form env inclosure))))
|
||||
(cconv-analyse-form form env))))
|
||||
|
||||
(`(quote . ,_) nil) ; quote form
|
||||
(`(function . ,_) nil) ; same as quote
|
||||
@ -788,63 +741,44 @@ lambdas if they are suitable for lambda lifting.
|
||||
;; FIXME: The bytecode for condition-case forces us to wrap the
|
||||
;; form and handlers in closures (for handlers, it's probably
|
||||
;; unavoidable, but not for the protected form).
|
||||
(setq inclosure (1+ inclosure))
|
||||
(cconv-analyse-form protected-form env inclosure)
|
||||
(push (list var inclosure form) env)
|
||||
(cconv-analyse-function () (list protected-form) env form)
|
||||
(dolist (handler handlers)
|
||||
(dolist (form (cdr handler))
|
||||
(cconv-analyse-form form env inclosure))))
|
||||
(cconv-analyse-function (if var (list var)) (cdr handler) env form)))
|
||||
|
||||
;; FIXME: The bytecode for catch forces us to wrap the body.
|
||||
(`(,(or `catch `unwind-protect) ,form . ,body)
|
||||
(cconv-analyse-form form env inclosure)
|
||||
(setq inclosure (1+ inclosure))
|
||||
(dolist (form body)
|
||||
(cconv-analyse-form form env inclosure)))
|
||||
(cconv-analyse-form form env)
|
||||
(cconv-analyse-function () body env form))
|
||||
|
||||
;; FIXME: The bytecode for save-window-excursion and the lack of
|
||||
;; bytecode for track-mouse forces us to wrap the body.
|
||||
(`(track-mouse . ,body)
|
||||
(setq inclosure (1+ inclosure))
|
||||
(dolist (form body)
|
||||
(cconv-analyse-form form env inclosure)))
|
||||
(cconv-analyse-function () body env form))
|
||||
|
||||
(`(,(or `defconst `defvar) ,var ,value . ,_)
|
||||
(push var byte-compile-bound-variables)
|
||||
(cconv-analyse-form value env inclosure))
|
||||
(cconv-analyse-form value env))
|
||||
|
||||
(`(,(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 (symbolp fun)
|
||||
(let ((lv (assq fun cconv-lambda-candidates)))
|
||||
(when lv
|
||||
(unless (eq (cadr lv) inclosure)
|
||||
(push lv cconv-captured)
|
||||
;; If this funcall and the definition of fun are in
|
||||
;; different closures - we delete fun from candidate
|
||||
;; list, because it is too complicated to manage free
|
||||
;; variables in this case.
|
||||
(setq cconv-lambda-candidates
|
||||
(delq lv cconv-lambda-candidates)))))
|
||||
(cconv-analyse-form fun env inclosure))
|
||||
(let ((fdata (and (symbolp fun) (assq fun env))))
|
||||
(if fdata
|
||||
(setf (nth 4 fdata) t)
|
||||
(cconv-analyse-form fun env)))
|
||||
(dolist (form args)
|
||||
(cconv-analyse-form form env inclosure)))
|
||||
(cconv-analyse-form form env)))
|
||||
|
||||
(`(,_ . ,body-forms) ; First element is a function or whatever.
|
||||
(dolist (form body-forms)
|
||||
(cconv-analyse-form form env inclosure)))
|
||||
(cconv-analyse-form form env)))
|
||||
|
||||
((pred symbolp)
|
||||
(let ((dv (assq form env))) ; dv = declared and visible
|
||||
(when dv
|
||||
(unless (eq inclosure (cadr dv)) ; capturing condition
|
||||
(push dv cconv-captured))
|
||||
;; Delete lambda if it is found here, since it escapes.
|
||||
(setq cconv-lambda-candidates
|
||||
(delq dv cconv-lambda-candidates)))))))
|
||||
(setf (nth 1 dv) t))))))
|
||||
|
||||
(provide 'cconv)
|
||||
;;; cconv.el ends here
|
||||
|
||||
@ -269,6 +269,7 @@ That buffer should be current already."
|
||||
(setq buffer-undo-list t)
|
||||
(let ((standard-output (current-buffer))
|
||||
(print-escape-newlines t)
|
||||
(print-quoted t) ;Doesn't seem to work :-(
|
||||
(print-level 1000) ;8
|
||||
;; (print-length 50)
|
||||
)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
;;; macroexp.el --- Additional macro-expansion support
|
||||
;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*-
|
||||
;;
|
||||
;; Copyright (C) 2004-2011 Free Software Foundation, Inc.
|
||||
;;
|
||||
@ -108,7 +108,14 @@ Assumes the caller has bound `macroexpand-all-environment'."
|
||||
(macroexpand (macroexpand-all-forms form 1)
|
||||
macroexpand-all-environment)
|
||||
;; Normal form; get its expansion, and then expand arguments.
|
||||
(setq form (macroexpand form macroexpand-all-environment))
|
||||
(let ((new-form (macroexpand form macroexpand-all-environment)))
|
||||
(when (and (not (eq form new-form)) ;It was a macro call.
|
||||
(car-safe form)
|
||||
(symbolp (car form))
|
||||
(get (car form) 'byte-obsolete-info)
|
||||
(fboundp 'byte-compile-warn-obsolete))
|
||||
(byte-compile-warn-obsolete (car form)))
|
||||
(setq form new-form))
|
||||
(pcase form
|
||||
(`(cond . ,clauses)
|
||||
(maybe-cons 'cond (macroexpand-all-clauses clauses) form))
|
||||
|
||||
@ -871,8 +871,7 @@ Returns (end-pos end-of-buffer-p)"
|
||||
;; XEmacs can calculate the end of the window by using
|
||||
;; the 'guarantee options. GOOD!
|
||||
(let ((end (window-end win t)))
|
||||
(if (= end (funcall (symbol-function 'point-max)
|
||||
(window-buffer win)))
|
||||
(if (= end (point-max (window-buffer win)))
|
||||
(list end t)
|
||||
(list (+ end 1) nil)))
|
||||
;; Emacs: We have to calculate the end by ourselves.
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
;;; diff-mode.el --- a mode for viewing/editing context diffs
|
||||
;;; diff-mode.el --- a mode for viewing/editing context diffs -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 1998-2011 Free Software Foundation, Inc.
|
||||
|
||||
@ -1278,7 +1278,7 @@ a diff with \\[diff-reverse-direction].
|
||||
(add-hook 'after-change-functions 'diff-after-change-function nil t)
|
||||
(add-hook 'post-command-hook 'diff-post-command-hook nil t))
|
||||
;; Neat trick from Dave Love to add more bindings in read-only mode:
|
||||
(lexical-let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
|
||||
(let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map)))
|
||||
(add-to-list 'minor-mode-overriding-map-alist ro-bind)
|
||||
;; Turn off this little trick in case the buffer is put in view-mode.
|
||||
(add-hook 'view-mode-hook
|
||||
|
||||
@ -51,7 +51,7 @@ by Hallvard:
|
||||
*
|
||||
* define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
|
||||
*/
|
||||
/* #define BYTE_CODE_SAFE */
|
||||
#define BYTE_CODE_SAFE 1
|
||||
/* #define BYTE_CODE_METER */
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user