mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-28 10:56:36 +00:00
Various compiler bug-fixes. MPC seems to run correctly now.
* lisp/files.el (lexical-binding): Add a safe-local-variable property. * lisp/emacs-lisp/byte-opt.el (byte-inline-lapcode): Check how many elements are added to the stack. (byte-compile-splice-in-already-compiled-code): Don't touch lexical nor byte-compile-depth now that byte-inline-lapcode does it for us. (byte-compile-inline-expand): Don't inline dynbind byte code into lexbind code, since it has to be done differently. * lisp/emacs-lisp/bytecomp.el (byte-compile-arglist-warn): Correctly extract arglist from `closure's. (byte-compile-cl-warn): Compiler-macros are run earlier now. (byte-compile-top-level): Bind byte-compile-lexical-environment to nil, except for lambdas. (byte-compile-form): Don't run the compiler-macro expander here. (byte-compile-let): Merge with byte-compile-let*. Don't preserve-body-value if the body's value was discarded. * lisp/emacs-lisp/cconv.el (cconv--set-diff, cconv--set-diff-map) (cconv--map-diff, cconv--map-diff-elem, cconv--map-diff-set): New funs. (cconv--env-var): New constant. (cconv-closure-convert-rec): Use it and use them. Fix a typo that ended up forgetting to remove entries from lmenvs in `let'. For `lambda' use the outer `fvrs' when building the closure and don't forget to remove `vars' from the `emvrs' and `lmenvs' of the body. * lisp/emacs-lisp/cl-macs.el (cl-byte-compile-block): Disable optimization in lexbind, because it needs a different implementation. * src/bytecode.c (exec_byte_code): Fix handling of &rest. * src/eval.c (Vinternal_interpreter_environment): Remove. (syms_of_eval): Do declare Vinternal_interpreter_environment as a global lisp var, but unintern it to hide it. (Fcommandp): * src/data.c (Finteractive_form): Understand `closure's.
This commit is contained in:
Stefan Monnier
parent
ce5b520a37
commit
b38b1ec071
@ -1,3 +1,34 @@
|
||||
2011-02-17 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* files.el (lexical-binding): Add a safe-local-variable property.
|
||||
|
||||
* emacs-lisp/cl-macs.el (cl-byte-compile-block): Disable optimization
|
||||
in lexbind, because it needs a different implementation.
|
||||
|
||||
* emacs-lisp/cconv.el (cconv--set-diff, cconv--set-diff-map)
|
||||
(cconv--map-diff, cconv--map-diff-elem, cconv--map-diff-set): New funs.
|
||||
(cconv--env-var): New constant.
|
||||
(cconv-closure-convert-rec): Use it and use them. Fix a typo that
|
||||
ended up forgetting to remove entries from lmenvs in `let'.
|
||||
For `lambda' use the outer `fvrs' when building the closure and don't
|
||||
forget to remove `vars' from the `emvrs' and `lmenvs' of the body.
|
||||
|
||||
* emacs-lisp/bytecomp.el (byte-compile-arglist-warn):
|
||||
Correctly extract arglist from `closure's.
|
||||
(byte-compile-cl-warn): Compiler-macros are run earlier now.
|
||||
(byte-compile-top-level): Bind byte-compile-lexical-environment to nil,
|
||||
except for lambdas.
|
||||
(byte-compile-form): Don't run the compiler-macro expander here.
|
||||
(byte-compile-let): Merge with byte-compile-let*.
|
||||
Don't preserve-body-value if the body's value was discarded.
|
||||
|
||||
* emacs-lisp/byte-opt.el (byte-inline-lapcode): Check how many elements
|
||||
are added to the stack.
|
||||
(byte-compile-splice-in-already-compiled-code): Don't touch lexical nor
|
||||
byte-compile-depth now that byte-inline-lapcode does it for us.
|
||||
(byte-compile-inline-expand): Don't inline dynbind byte code into
|
||||
lexbind code, since it has to be done differently.
|
||||
|
||||
2011-02-12 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/byte-lexbind.el: Delete.
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
;;; -*- lexical-binding: t -*-
|
||||
;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs
|
||||
;;; doc-view.el --- View PDF/PostScript/DVI files in Emacs -*- lexical-binding: t -*-
|
||||
|
||||
|
||||
;; Copyright (C) 2007-2011 Free Software Foundation, Inc.
|
||||
;;
|
||||
|
||||
@ -248,7 +248,18 @@
|
||||
;; are no collisions, and that byte-compile-tag-number is reasonable
|
||||
;; after this is spliced in. The provided list is destroyed.
|
||||
(defun byte-inline-lapcode (lap)
|
||||
(setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
|
||||
;; "Replay" the operations: we used to just do
|
||||
;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))
|
||||
;; but that fails to update byte-compile-depth, so we had to assume
|
||||
;; that `lap' ends up adding exactly 1 element to the stack. This
|
||||
;; happens to be true for byte-code generated by bytecomp.el without
|
||||
;; lexical-binding, but it's not true in general, and it's not true for
|
||||
;; code output by bytecomp.el with lexical-binding.
|
||||
(dolist (op lap)
|
||||
(cond
|
||||
((eq (car op) 'TAG) (byte-compile-out-tag op))
|
||||
((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op)))
|
||||
(t (byte-compile-out (car op) (cdr op))))))
|
||||
|
||||
(defun byte-compile-inline-expand (form)
|
||||
(let* ((name (car form))
|
||||
@ -266,25 +277,32 @@
|
||||
(cdr (assq name byte-compile-function-environment)))))
|
||||
(if (and (consp fn) (eq (car fn) 'autoload))
|
||||
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
|
||||
(if (and (symbolp fn) (not (eq fn t)))
|
||||
(byte-compile-inline-expand (cons fn (cdr form)))
|
||||
(if (byte-code-function-p fn)
|
||||
(let (string)
|
||||
(fetch-bytecode fn)
|
||||
(setq string (aref fn 1))
|
||||
;; Isn't it an error for `string' not to be unibyte?? --stef
|
||||
(if (fboundp 'string-as-unibyte)
|
||||
(setq string (string-as-unibyte string)))
|
||||
;; `byte-compile-splice-in-already-compiled-code'
|
||||
;; takes care of inlining the body.
|
||||
(cons `(lambda ,(aref fn 0)
|
||||
(byte-code ,string ,(aref fn 2) ,(aref fn 3)))
|
||||
(cdr form)))
|
||||
(if (eq (car-safe fn) 'lambda)
|
||||
(macroexpand-all (cons fn (cdr form))
|
||||
byte-compile-macro-environment)
|
||||
;; Give up on inlining.
|
||||
form))))))
|
||||
(cond
|
||||
((and (symbolp fn) (not (eq fn t))) ;A function alias.
|
||||
(byte-compile-inline-expand (cons fn (cdr form))))
|
||||
((and (byte-code-function-p fn)
|
||||
;; FIXME: This works to inline old-style-byte-codes into
|
||||
;; old-style-byte-codes, but not mixed cases (not sure
|
||||
;; about new-style into new-style).
|
||||
(not lexical-binding)
|
||||
(not (and (>= (length fn) 7)
|
||||
(aref fn 6)))) ;6 = COMPILED_PUSH_ARGS
|
||||
;; (message "Inlining %S byte-code" name)
|
||||
(fetch-bytecode fn)
|
||||
(let ((string (aref fn 1)))
|
||||
;; Isn't it an error for `string' not to be unibyte?? --stef
|
||||
(if (fboundp 'string-as-unibyte)
|
||||
(setq string (string-as-unibyte string)))
|
||||
;; `byte-compile-splice-in-already-compiled-code'
|
||||
;; takes care of inlining the body.
|
||||
(cons `(lambda ,(aref fn 0)
|
||||
(byte-code ,string ,(aref fn 2) ,(aref fn 3)))
|
||||
(cdr form))))
|
||||
((eq (car-safe fn) 'lambda)
|
||||
(macroexpand-all (cons fn (cdr form))
|
||||
byte-compile-macro-environment))
|
||||
(t ;; Give up on inlining.
|
||||
form)))))
|
||||
|
||||
;; ((lambda ...) ...)
|
||||
(defun byte-compile-unfold-lambda (form &optional name)
|
||||
@ -1298,10 +1316,7 @@
|
||||
(if (not (memq byte-optimize '(t lap)))
|
||||
(byte-compile-normal-call form)
|
||||
(byte-inline-lapcode
|
||||
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
|
||||
(setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
|
||||
byte-compile-maxdepth))
|
||||
(setq byte-compile-depth (1+ byte-compile-depth))))
|
||||
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))))
|
||||
|
||||
(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
|
||||
|
||||
|
||||
@ -752,9 +752,10 @@ BYTES and PC are updated after evaluating all the arguments."
|
||||
(bytes-var (car (last args 2)))
|
||||
(pc-var (car (last args))))
|
||||
`(setq ,bytes-var ,(if (null (cdr byte-exprs))
|
||||
`(cons ,@byte-exprs ,bytes-var)
|
||||
`(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
|
||||
,pc-var (+ ,(length byte-exprs) ,pc-var))))
|
||||
`(progn (assert (<= 0 ,(car byte-exprs)))
|
||||
(cons ,@byte-exprs ,bytes-var))
|
||||
`(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
|
||||
,pc-var (+ ,(length byte-exprs) ,pc-var))))
|
||||
|
||||
(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
|
||||
"Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
|
||||
@ -817,7 +818,7 @@ CONST2 may be evaulated multiple times."
|
||||
;; These insns all put their operand into one extra byte.
|
||||
(byte-compile-push-bytecodes opcode off bytes pc))
|
||||
((= opcode byte-discardN)
|
||||
;; byte-discardN is wierd in that it encodes a flag in the
|
||||
;; byte-discardN is weird in that it encodes a flag in the
|
||||
;; top bit of its one-byte argument. If the argument is
|
||||
;; too large to fit in 7 bits, the opcode can be repeated.
|
||||
(let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0)))
|
||||
@ -1330,11 +1331,11 @@ extra args."
|
||||
(eq 'lambda (car-safe (cdr-safe old)))
|
||||
(setq old (cdr old)))
|
||||
(let ((sig1 (byte-compile-arglist-signature
|
||||
(if (eq 'lambda (car-safe old))
|
||||
(nth 1 old)
|
||||
(if (byte-code-function-p old)
|
||||
(aref old 0)
|
||||
'(&rest def)))))
|
||||
(pcase old
|
||||
(`(lambda ,args . ,_) args)
|
||||
(`(closure ,_ ,_ ,args . ,_) args)
|
||||
((pred byte-code-function-p) (aref old 0))
|
||||
(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))
|
||||
@ -1402,14 +1403,7 @@ extra args."
|
||||
;; but such warnings are never useful,
|
||||
;; so don't warn about them.
|
||||
macroexpand cl-macroexpand-all
|
||||
cl-compiling-file)))
|
||||
;; Avoid warnings for things which are safe because they
|
||||
;; have suitable compiler macros, but those aren't
|
||||
;; expanded at this stage. There should probably be more
|
||||
;; here than caaar and friends.
|
||||
(not (and (eq (get func 'byte-compile)
|
||||
'cl-byte-compile-compiler-macro)
|
||||
(string-match "\\`c[ad]+r\\'" (symbol-name func)))))
|
||||
cl-compiling-file))))
|
||||
(byte-compile-warn "function `%s' from cl package called at runtime"
|
||||
func)))
|
||||
form)
|
||||
@ -2701,8 +2695,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
||||
(if (eq (car-safe form) 'list)
|
||||
(byte-compile-top-level (nth 1 bytecomp-int))
|
||||
(setq bytecomp-int (list 'interactive
|
||||
(byte-compile-top-level
|
||||
(nth 1 bytecomp-int)))))))
|
||||
(byte-compile-top-level
|
||||
(nth 1 bytecomp-int)))))))
|
||||
((cdr bytecomp-int)
|
||||
(byte-compile-warn "malformed interactive spec: %s"
|
||||
(prin1-to-string bytecomp-int)))))
|
||||
@ -2788,6 +2782,9 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
||||
(byte-compile-tag-number 0)
|
||||
(byte-compile-depth 0)
|
||||
(byte-compile-maxdepth 0)
|
||||
(byte-compile-lexical-environment
|
||||
(when (eq output-type 'lambda)
|
||||
byte-compile-lexical-environment))
|
||||
(byte-compile-output nil))
|
||||
(if (memq byte-optimize '(t source))
|
||||
(setq form (byte-optimize-form form for-effect)))
|
||||
@ -2798,14 +2795,13 @@ If FORM is a lambda or a macro, byte-compile it as a function."
|
||||
(stringp (nth 1 form)) (vectorp (nth 2 form))
|
||||
(natnump (nth 3 form)))
|
||||
form
|
||||
;; Set up things for a lexically-bound function
|
||||
;; Set up things for a lexically-bound function.
|
||||
(when (and lexical-binding (eq output-type 'lambda))
|
||||
;; See how many arguments there are, and set the current stack depth
|
||||
;; accordingly
|
||||
(dolist (var byte-compile-lexical-environment)
|
||||
(setq byte-compile-depth (1+ byte-compile-depth)))
|
||||
;; accordingly.
|
||||
(setq byte-compile-depth (length byte-compile-lexical-environment))
|
||||
;; If there are args, output a tag to record the initial
|
||||
;; stack-depth for the optimizer
|
||||
;; stack-depth for the optimizer.
|
||||
(when (> byte-compile-depth 0)
|
||||
(byte-compile-out-tag (byte-compile-make-tag))))
|
||||
;; Now compile FORM
|
||||
@ -2964,9 +2960,10 @@ That command is designed for interactive use only" bytecomp-fn))
|
||||
;; for CL compiler macros since the symbol may be
|
||||
;; `cl-byte-compile-compiler-macro' but if CL isn't
|
||||
;; loaded, this function doesn't exist.
|
||||
(or (not (memq bytecomp-handler
|
||||
'(cl-byte-compile-compiler-macro)))
|
||||
(functionp bytecomp-handler)))
|
||||
(and (not (eq bytecomp-handler
|
||||
;; Already handled by macroexpand-all.
|
||||
'cl-byte-compile-compiler-macro))
|
||||
(functionp bytecomp-handler)))
|
||||
(funcall bytecomp-handler form)
|
||||
(byte-compile-normal-call form))
|
||||
(if (byte-compile-warning-enabled-p 'cl-functions)
|
||||
@ -3612,7 +3609,7 @@ discarding."
|
||||
(byte-defop-compiler-1 while)
|
||||
(byte-defop-compiler-1 funcall)
|
||||
(byte-defop-compiler-1 let)
|
||||
(byte-defop-compiler-1 let*)
|
||||
(byte-defop-compiler-1 let* byte-compile-let)
|
||||
|
||||
(defun byte-compile-progn (form)
|
||||
(byte-compile-body-do-effect (cdr form)))
|
||||
@ -3819,10 +3816,8 @@ Return the offset in the form (VAR . OFFSET)."
|
||||
(byte-compile-push-constant nil)))))
|
||||
|
||||
(defun byte-compile-not-lexical-var-p (var)
|
||||
(or (not (symbolp var)) ; form is not a list
|
||||
(if (eval-when-compile (fboundp 'special-variable-p))
|
||||
(special-variable-p var)
|
||||
(boundp var))
|
||||
(or (not (symbolp var))
|
||||
(special-variable-p var)
|
||||
(memq var byte-compile-bound-variables)
|
||||
(memq var '(nil t))
|
||||
(keywordp var)))
|
||||
@ -3833,9 +3828,8 @@ INIT-LEXENV should be a lexical-environment alist describing the
|
||||
positions of the init value that have been pushed on the stack.
|
||||
Return non-nil if the TOS value was popped."
|
||||
;; The presence of lexical bindings mean that we may have to
|
||||
;; juggle things on the stack, either to move them to TOS for
|
||||
;; dynamic binding, or to put them in a non-stack environment
|
||||
;; vector.
|
||||
;; juggle things on the stack, to move them to TOS for
|
||||
;; dynamic binding.
|
||||
(cond ((not (byte-compile-not-lexical-var-p var))
|
||||
;; VAR is a simple stack-allocated lexical variable
|
||||
(push (assq var init-lexenv)
|
||||
@ -3883,56 +3877,41 @@ binding slots have been popped."
|
||||
|
||||
(defun byte-compile-let (form)
|
||||
"Generate code for the `let' form FORM."
|
||||
;; First compute the binding values in the old scope.
|
||||
(let ((varlist (car (cdr form)))
|
||||
(init-lexenv nil))
|
||||
(dolist (var varlist)
|
||||
(push (byte-compile-push-binding-init var) init-lexenv))
|
||||
;; Now do the bindings, execute the body, and undo the bindings.
|
||||
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
|
||||
(varlist (reverse (car (cdr form))))
|
||||
(let ((clauses (cadr form))
|
||||
(init-lexenv nil))
|
||||
(when (eq (car form) 'let)
|
||||
;; First compute the binding values in the old scope.
|
||||
(dolist (var clauses)
|
||||
(push (byte-compile-push-binding-init var) init-lexenv)))
|
||||
;; New scope.
|
||||
(let ((byte-compile-bound-variables byte-compile-bound-variables)
|
||||
(byte-compile-lexical-environment byte-compile-lexical-environment))
|
||||
(dolist (var varlist)
|
||||
(let ((var (if (consp var) (car var) var)))
|
||||
(cond ((null lexical-binding)
|
||||
;; If there are no lexical bindings, we can do things simply.
|
||||
(byte-compile-dynamic-variable-bind var))
|
||||
((byte-compile-bind var init-lexenv)
|
||||
(pop init-lexenv)))))
|
||||
;; Bind the variables.
|
||||
;; For `let', do it in reverse order, because it makes no
|
||||
;; semantic difference, but it is a lot more efficient since the
|
||||
;; values are now in reverse order on the stack.
|
||||
(dolist (var (if (eq (car form) 'let) (reverse clauses) clauses))
|
||||
(unless (eq (car form) 'let)
|
||||
(push (byte-compile-push-binding-init var) init-lexenv))
|
||||
(let ((var (if (consp var) (car var) var)))
|
||||
(cond ((null lexical-binding)
|
||||
;; If there are no lexical bindings, we can do things simply.
|
||||
(byte-compile-dynamic-variable-bind var))
|
||||
((byte-compile-bind var init-lexenv)
|
||||
(pop init-lexenv)))))
|
||||
;; Emit the body.
|
||||
(byte-compile-body-do-effect (cdr (cdr form)))
|
||||
;; Unbind the variables.
|
||||
(if lexical-binding
|
||||
;; Unbind both lexical and dynamic variables.
|
||||
(byte-compile-unbind varlist init-lexenv t)
|
||||
;; Unbind dynamic variables.
|
||||
(byte-compile-out 'byte-unbind (length varlist))))))
|
||||
|
||||
(defun byte-compile-let* (form)
|
||||
"Generate code for the `let*' form FORM."
|
||||
(let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
|
||||
(clauses (cadr form))
|
||||
(init-lexenv nil)
|
||||
;; bind these to restrict the scope of any changes
|
||||
|
||||
(byte-compile-lexical-environment byte-compile-lexical-environment))
|
||||
;; Bind the variables
|
||||
(dolist (var clauses)
|
||||
(push (byte-compile-push-binding-init var) init-lexenv)
|
||||
(let ((var (if (consp var) (car var) var)))
|
||||
(cond ((null lexical-binding)
|
||||
;; If there are no lexical bindings, we can do things simply.
|
||||
(byte-compile-dynamic-variable-bind var))
|
||||
((byte-compile-bind var init-lexenv)
|
||||
(pop init-lexenv)))))
|
||||
;; Emit the body
|
||||
(byte-compile-body-do-effect (cdr (cdr form)))
|
||||
;; Unbind the variables
|
||||
(if lexical-binding
|
||||
;; Unbind both lexical and dynamic variables
|
||||
(byte-compile-unbind clauses init-lexenv t)
|
||||
;; Unbind dynamic variables
|
||||
(byte-compile-out 'byte-unbind (length clauses)))))
|
||||
(let ((init-stack-depth byte-compile-depth))
|
||||
(byte-compile-body-do-effect (cdr (cdr form)))
|
||||
;; Unbind the variables.
|
||||
(if lexical-binding
|
||||
;; Unbind both lexical and dynamic variables.
|
||||
(progn
|
||||
(assert (or (eq byte-compile-depth init-stack-depth)
|
||||
(eq byte-compile-depth (1+ init-stack-depth))))
|
||||
(byte-compile-unbind clauses init-lexenv (> byte-compile-depth
|
||||
init-stack-depth)))
|
||||
;; Unbind dynamic variables.
|
||||
(byte-compile-out 'byte-unbind (length clauses)))))))
|
||||
|
||||
|
||||
|
||||
@ -4254,8 +4233,8 @@ binding slots have been popped."
|
||||
(progn
|
||||
;; ## remove this someday
|
||||
(and byte-compile-depth
|
||||
(not (= (cdr (cdr tag)) byte-compile-depth))
|
||||
(error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
|
||||
(not (= (cdr (cdr tag)) byte-compile-depth))
|
||||
(error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
|
||||
(setq byte-compile-depth (cdr (cdr tag))))
|
||||
(setcdr (cdr tag) byte-compile-depth)))
|
||||
|
||||
|
||||
@ -70,6 +70,15 @@
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
;;; TODO:
|
||||
;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp
|
||||
;; should turn into building corresponding byte-code function.
|
||||
;; - don't use `curry', instead build a new compiled-byte-code object
|
||||
;; (merge the closure env into the static constants pool).
|
||||
;; - use relative addresses for byte-code-stack-ref.
|
||||
;; - warn about unused lexical vars.
|
||||
;; - clean up cconv-closure-convert-rec, especially the `let' binding part.
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
(defconst cconv-liftwhen 3
|
||||
@ -187,14 +196,14 @@ Returns a list of free variables."
|
||||
-- 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."
|
||||
(message "Entering cconv-closure-convert...")
|
||||
;; (message "Entering cconv-closure-convert...")
|
||||
(let ((cconv-mutated '())
|
||||
(cconv-lambda-candidates '())
|
||||
(cconv-captured '())
|
||||
(cconv-captured+mutated '()))
|
||||
;; Analyse form - fill these variables with new information
|
||||
;; Analyse form - fill these variables with new information.
|
||||
(cconv-analyse-form form '() 0)
|
||||
;; Calculate an intersection of cconv-mutated and cconv-captured
|
||||
;; Calculate an intersection of cconv-mutated and cconv-captured.
|
||||
(dolist (mvr cconv-mutated)
|
||||
(when (memq mvr cconv-captured) ;
|
||||
(push mvr cconv-captured+mutated)))
|
||||
@ -216,14 +225,51 @@ Returns a form where all lambdas don't have any free variables."
|
||||
res))
|
||||
|
||||
(defconst cconv--dummy-var (make-symbol "ignored"))
|
||||
(defconst cconv--env-var (make-symbol "env"))
|
||||
|
||||
(defun cconv-closure-convert-rec
|
||||
(form emvrs fvrs envs lmenvs)
|
||||
(defun cconv--set-diff (s1 s2)
|
||||
"Return elements of set S1 that are not in set S2."
|
||||
(let ((res '()))
|
||||
(dolist (x s1)
|
||||
(unless (memq x s2) (push x res)))
|
||||
(nreverse res)))
|
||||
|
||||
(defun cconv--set-diff-map (s m)
|
||||
"Return elements of set S that are not in Dom(M)."
|
||||
(let ((res '()))
|
||||
(dolist (x s)
|
||||
(unless (assq x m) (push x res)))
|
||||
(nreverse res)))
|
||||
|
||||
(defun cconv--map-diff (m1 m2)
|
||||
"Return the submap of map M1 that has Dom(M2) removed."
|
||||
(let ((res '()))
|
||||
(dolist (x m1)
|
||||
(unless (assq (car x) m2) (push x res)))
|
||||
(nreverse res)))
|
||||
|
||||
(defun cconv--map-diff-elem (m x)
|
||||
"Return the map M minus any mapping for X."
|
||||
;; Here we assume that X appears at most once in M.
|
||||
(let* ((b (assq x m))
|
||||
(res (if b (remq b m) m)))
|
||||
(assert (null (assq x res))) ;; Check the assumption was warranted.
|
||||
res))
|
||||
|
||||
(defun cconv--map-diff-set (m s)
|
||||
"Return the map M minus any mapping for elements of S."
|
||||
;; Here we assume that X appears at most once in M.
|
||||
(let ((res '()))
|
||||
(dolist (b m)
|
||||
(unless (memq (car b) s) (push b res)))
|
||||
(nreverse res)))
|
||||
|
||||
(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.
|
||||
Arguments:
|
||||
-- FORM is a piece of Elisp code after macroexpansion.
|
||||
-- LMENVS is a list of environments used for lambda-lifting. Initially empty.
|
||||
-- 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.
|
||||
@ -343,10 +389,9 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(setq lmenvs (remq old-lmenv lmenvs))
|
||||
(push new-lmenv lmenvs)
|
||||
(push `(,closedsym ,var) binders-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
|
||||
;; We push the element after redefined free variables are
|
||||
;; processed. This is important to avoid the bug when free
|
||||
;; variable and the function have the same name.
|
||||
(push (list var new-val) binders-new)
|
||||
|
||||
(when (eq letsym 'let*) ; update fvrs
|
||||
@ -355,11 +400,7 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(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))
|
||||
(setq lmenvs (cconv--map-diff-elem lmenvs var))
|
||||
(when lmenv-push
|
||||
(push lmenv-push lmenvs)
|
||||
(setq lmenv-push nil)))
|
||||
@ -368,19 +409,10 @@ Returns a form where all lambdas don't have any free variables."
|
||||
|
||||
(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 binders-new)) (push vr fvrs-1)))
|
||||
(setq fvrs fvrs-1)
|
||||
(dolist (vr emvrs)
|
||||
; safely remove
|
||||
(when (not (assq vr binders-new)) (push vr emvrs-1)))
|
||||
(setq emvrs emvrs-1)
|
||||
; push new
|
||||
(setq fvrs (cconv--set-diff-map fvrs binders-new))
|
||||
(setq emvrs (cconv--set-diff-map emvrs binders-new))
|
||||
(setq emvrs (append emvrs emvrs-new))
|
||||
(dolist (vr lmenvs)
|
||||
(when (not (assq (car vr) binders-new))
|
||||
(push vr lmenvs-1)))
|
||||
(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
|
||||
@ -402,9 +434,9 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(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)))
|
||||
(dolist (frv (cdr lmenv))
|
||||
(push (if (eq frv var) closedsym frv)
|
||||
new-lmenv))
|
||||
(setq new-lmenv (reverse new-lmenv))
|
||||
(setq lmenvs (remq lmenv lmenvs))
|
||||
(push new-lmenv lmenvs)
|
||||
@ -449,13 +481,9 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(`(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
|
||||
(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)
|
||||
@ -470,7 +498,7 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(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))
|
||||
(when (not (memq (car fv-temp) fvrs-new)) (setq leave nil))
|
||||
(setq fv-temp (cdr fv-temp))))
|
||||
(setq leave nil))
|
||||
|
||||
@ -479,23 +507,30 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(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
|
||||
envector)) ; Process vars for closure vector.
|
||||
(setq envector (reverse envector))
|
||||
(setq envs fv))
|
||||
(setq envector `(env))) ; leave unchanged
|
||||
(setq fvrs fv)) ; update substitution list
|
||||
(setq envector `(,cconv--env-var))) ; Leave unchanged.
|
||||
(setq fvrs-new 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
|
||||
(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 envs lmenvs)
|
||||
elm emvrs fvrs-new envs lmenvs)
|
||||
body-forms-new))
|
||||
|
||||
(setq body-forms-new
|
||||
@ -509,12 +544,12 @@ Returns a form where all lambdas don't have any free variables."
|
||||
; 1 free variable - do not build vector
|
||||
((null (cdr envector))
|
||||
`(curry
|
||||
(function (lambda (env . ,vars) . ,body-forms-new))
|
||||
(function (lambda (,cconv--env-var . ,vars) . ,body-forms-new))
|
||||
,(car envector)))
|
||||
; >=2 free variables - build vector
|
||||
(t
|
||||
`(curry
|
||||
(function (lambda (env . ,vars) . ,body-forms-new))
|
||||
(function (lambda (,cconv--env-var . ,vars) . ,body-forms-new))
|
||||
(vector . ,envector))))))
|
||||
|
||||
(`(function . ,_) form) ; same as quote
|
||||
@ -674,13 +709,10 @@ Returns a form where all lambdas don't have any free variables."
|
||||
(let ((free (memq form fvrs)))
|
||||
(if free ;form is a free variable
|
||||
(let* ((numero (- (length fvrs) (length free)))
|
||||
(var '()))
|
||||
(assert numero)
|
||||
(if (null (cdr envs))
|
||||
(setq var 'env)
|
||||
;replace form =>
|
||||
;(aref env #)
|
||||
(setq var `(aref env ,numero)))
|
||||
(var (if (null (cdr envs))
|
||||
cconv--env-var
|
||||
;; Replace form => (aref env #)
|
||||
`(aref ,cconv--env-var ,numero))))
|
||||
(if (memq form emvrs) ; form => (car (aref env #)) if mutable
|
||||
`(car ,var)
|
||||
var))
|
||||
|
||||
@ -282,7 +282,7 @@ Not documented
|
||||
;;;;;; do-all-symbols do-symbols dotimes dolist do* do loop return-from
|
||||
;;;;;; return block etypecase typecase ecase case load-time-value
|
||||
;;;;;; eval-when destructuring-bind function* defmacro* defun* gentemp
|
||||
;;;;;; gensym) "cl-macs" "cl-macs.el" "0904b956872432ae7cc5fa9abcefce63")
|
||||
;;;;;; gensym) "cl-macs" "cl-macs.el" "7602128fa01003de9a8df4c752865300")
|
||||
;;; Generated autoloads from cl-macs.el
|
||||
|
||||
(autoload 'gensym "cl-macs" "\
|
||||
|
||||
@ -602,7 +602,13 @@ called from BODY."
|
||||
|
||||
(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
|
||||
(defun cl-byte-compile-block (cl-form)
|
||||
(if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler
|
||||
;; Here we try to determine if a catch tag is used or not, so as to get rid
|
||||
;; of the catch when it's not used.
|
||||
(if (and (fboundp 'byte-compile-form-do-effect) ; Optimizing compiler?
|
||||
;; FIXME: byte-compile-top-level can only be used for code that is
|
||||
;; closed (as the name implies), so for lexical scoping we should
|
||||
;; implement this optimization differently.
|
||||
(not lexical-binding))
|
||||
(progn
|
||||
(let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
|
||||
(cl-active-block-names (cons cl-entry cl-active-block-names))
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
;;; -*- lexical-binding: t -*-
|
||||
;;; pcase.el --- ML-style pattern-matching macro for Elisp
|
||||
;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
|
||||
|
||||
|
||||
@ -2851,18 +2851,19 @@ asking you for confirmation."
|
||||
;;
|
||||
;; For variables defined in the C source code the declaration should go here:
|
||||
|
||||
(mapc (lambda (pair)
|
||||
(put (car pair) 'safe-local-variable (cdr pair)))
|
||||
'((buffer-read-only . booleanp) ;; C source code
|
||||
(default-directory . stringp) ;; C source code
|
||||
(fill-column . integerp) ;; C source code
|
||||
(indent-tabs-mode . booleanp) ;; C source code
|
||||
(left-margin . integerp) ;; C source code
|
||||
(no-update-autoloads . booleanp)
|
||||
(tab-width . integerp) ;; C source code
|
||||
(truncate-lines . booleanp) ;; C source code
|
||||
(word-wrap . booleanp) ;; C source code
|
||||
(bidi-display-reordering . booleanp))) ;; C source code
|
||||
(dolist (pair
|
||||
'((buffer-read-only . booleanp) ;; C source code
|
||||
(default-directory . stringp) ;; C source code
|
||||
(fill-column . integerp) ;; C source code
|
||||
(indent-tabs-mode . booleanp) ;; C source code
|
||||
(left-margin . integerp) ;; C source code
|
||||
(no-update-autoloads . booleanp)
|
||||
(lexical-binding . booleanp) ;; C source code
|
||||
(tab-width . integerp) ;; C source code
|
||||
(truncate-lines . booleanp) ;; C source code
|
||||
(word-wrap . booleanp) ;; C source code
|
||||
(bidi-display-reordering . booleanp))) ;; C source code
|
||||
(put (car pair) 'safe-local-variable (cdr pair)))
|
||||
|
||||
(put 'bidi-paragraph-direction 'safe-local-variable
|
||||
(lambda (v) (memq v '(nil right-to-left left-to-right))))
|
||||
|
||||
@ -530,7 +530,7 @@ suitable file is found, return nil."
|
||||
(let ((fill-begin (point)))
|
||||
(insert (car high) "\n")
|
||||
(fill-region fill-begin (point)))
|
||||
(setq doc (cdr high))))
|
||||
(setq doc (cdr high))))
|
||||
(let* ((obsolete (and
|
||||
;; function might be a lambda construct.
|
||||
(symbolp function)
|
||||
|
||||
@ -1,3 +1,13 @@
|
||||
2011-02-17 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* eval.c (Vinternal_interpreter_environment): Remove.
|
||||
(syms_of_eval): Do declare Vinternal_interpreter_environment as
|
||||
a global lisp var, but unintern it to hide it.
|
||||
(Fcommandp):
|
||||
* data.c (Finteractive_form): Understand `closure's.
|
||||
|
||||
* bytecode.c (exec_byte_code): Fix handling of &rest.
|
||||
|
||||
2011-02-12 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* bytecode.c (Bvec_ref, Bvec_set): Remove.
|
||||
|
||||
@ -500,7 +500,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
|
||||
optional = 1;
|
||||
else if (EQ (XCAR (at), Qand_rest))
|
||||
{
|
||||
PUSH (Flist (nargs, args));
|
||||
PUSH (pushed < nargs
|
||||
? Flist (nargs - pushed, args)
|
||||
: Qnil);
|
||||
pushed = nargs;
|
||||
at = Qnil;
|
||||
break;
|
||||
|
||||
@ -755,6 +755,8 @@ Value, if non-nil, is a list \(interactive SPEC). */)
|
||||
else if (CONSP (fun))
|
||||
{
|
||||
Lisp_Object funcar = XCAR (fun);
|
||||
if (EQ (funcar, Qclosure))
|
||||
fun = Fcdr (XCDR (fun)), funcar = Fcar (fun);
|
||||
if (EQ (funcar, Qlambda))
|
||||
return Fassq (Qinteractive, Fcdr (XCDR (fun)));
|
||||
else if (EQ (funcar, Qautoload))
|
||||
|
||||
34
src/eval.c
34
src/eval.c
@ -78,16 +78,6 @@ Lisp_Object Vrun_hooks;
|
||||
|
||||
Lisp_Object Vautoload_queue;
|
||||
|
||||
/* When lexical binding is being used, this is non-nil, and contains an
|
||||
alist of lexically-bound variable, or (t), indicating an empty
|
||||
environment. The lisp name of this variable is
|
||||
`internal-interpreter-environment'. Every element of this list
|
||||
can be either a cons (VAR . VAL) specifying a lexical binding,
|
||||
or a single symbol VAR indicating that this variable should use
|
||||
dynamic scoping. */
|
||||
|
||||
Lisp_Object Vinternal_interpreter_environment;
|
||||
|
||||
/* Current number of specbindings allocated in specpdl. */
|
||||
|
||||
EMACS_INT specpdl_size;
|
||||
@ -2092,9 +2082,11 @@ then strings and vectors are not accepted. */)
|
||||
if (!CONSP (fun))
|
||||
return Qnil;
|
||||
funcar = XCAR (fun);
|
||||
if (EQ (funcar, Qclosure))
|
||||
fun = Fcdr (XCDR (fun)), funcar = Fcar (fun);
|
||||
if (EQ (funcar, Qlambda))
|
||||
return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
|
||||
if (EQ (funcar, Qautoload))
|
||||
else if (EQ (funcar, Qautoload))
|
||||
return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
|
||||
else
|
||||
return Qnil;
|
||||
@ -3695,6 +3687,8 @@ mark_backtrace (void)
|
||||
}
|
||||
}
|
||||
|
||||
EXFUN (Funintern, 2);
|
||||
|
||||
void
|
||||
syms_of_eval (void)
|
||||
{
|
||||
@ -3840,19 +3834,27 @@ DECL is a list `(declare ...)' containing the declarations.
|
||||
The value the function returns is not used. */);
|
||||
Vmacro_declaration_function = Qnil;
|
||||
|
||||
/* When lexical binding is being used,
|
||||
vinternal_interpreter_environment is non-nil, and contains an alist
|
||||
of lexically-bound variable, or (t), indicating an empty
|
||||
environment. The lisp name of this variable would be
|
||||
`internal-interpreter-environment' if it weren't hidden.
|
||||
Every element of this list can be either a cons (VAR . VAL)
|
||||
specifying a lexical binding, or a single symbol VAR indicating
|
||||
that this variable should use dynamic scoping. */
|
||||
Qinternal_interpreter_environment
|
||||
= intern_c_string ("internal-interpreter-environment");
|
||||
staticpro (&Qinternal_interpreter_environment);
|
||||
#if 0 /* Don't export this variable to Elisp, so noone can mess with it
|
||||
(Just imagine if someone makes it buffer-local). */
|
||||
DEFVAR__LISP ("internal-interpreter-environment",
|
||||
Vinternal_interpreter_environment,
|
||||
DEFVAR_LISP ("internal-interpreter-environment",
|
||||
Vinternal_interpreter_environment,
|
||||
doc: /* If non-nil, the current lexical environment of the lisp interpreter.
|
||||
When lexical binding is not being used, this variable is nil.
|
||||
A value of `(t)' indicates an empty environment, otherwise it is an
|
||||
alist of active lexical bindings. */);
|
||||
#endif
|
||||
Vinternal_interpreter_environment = Qnil;
|
||||
/* Don't export this variable to Elisp, so noone can mess with it
|
||||
(Just imagine if someone makes it buffer-local). */
|
||||
Funintern (Qinternal_interpreter_environment, Qnil);
|
||||
|
||||
Vrun_hooks = intern_c_string ("run-hooks");
|
||||
staticpro (&Vrun_hooks);
|
||||
|
||||
@ -2855,7 +2855,7 @@ extern void syms_of_lread (void);
|
||||
|
||||
/* Defined in eval.c */
|
||||
extern Lisp_Object Qautoload, Qexit, Qinteractive, Qcommandp, Qdefun, Qmacro;
|
||||
extern Lisp_Object Qinhibit_quit;
|
||||
extern Lisp_Object Qinhibit_quit, Qclosure;
|
||||
extern Lisp_Object Vautoload_queue;
|
||||
extern Lisp_Object Vsignaling_function;
|
||||
extern int handling_signal;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user