Don't forget to analyze args of lambda lifted functions (Bug#30872)
* lisp/emacs-lisp/cconv.el (cconv--convert-funcbody): New function. (cconv--convert-function): Extracted from here. (cconv-convert): Also use it here, in the lambda lifted case, so that mutated args are properly accounted for. * test/lisp/emacs-lisp/cconv-tests.el: New test.
This commit is contained in:
Noam Postavsky
parent
05345babc9
commit
6021e1db92
2 changed files with 71 additions and 24 deletions
|
|
@ -206,7 +206,6 @@ Returns a form where all lambdas don't have any free variables."
|
|||
(cl-assert (equal body (caar cconv-freevars-alist)))
|
||||
(let* ((fvs (cdr (pop cconv-freevars-alist)))
|
||||
(body-new '())
|
||||
(letbind '())
|
||||
(envector ())
|
||||
(i 0)
|
||||
(new-env ()))
|
||||
|
|
@ -227,25 +226,8 @@ Returns a form where all lambdas don't have any free variables."
|
|||
(setq envector (nreverse envector))
|
||||
(setq new-env (nreverse new-env))
|
||||
|
||||
(dolist (arg args)
|
||||
(if (not (member (cons (list arg) parentform) cconv-captured+mutated))
|
||||
(if (assq arg new-env) (push `(,arg) new-env))
|
||||
(push `(,arg . (car-safe ,arg)) new-env)
|
||||
(push `(,arg (list ,arg)) letbind)))
|
||||
|
||||
(setq body-new (mapcar (lambda (form)
|
||||
(cconv-convert form new-env nil))
|
||||
body))
|
||||
|
||||
(when letbind
|
||||
(let ((special-forms '()))
|
||||
;; Keep special forms at the beginning of the body.
|
||||
(while (or (stringp (car body-new)) ;docstring.
|
||||
(memq (car-safe (car body-new)) '(interactive declare)))
|
||||
(push (pop body-new) special-forms))
|
||||
(setq body-new
|
||||
`(,@(nreverse special-forms) (let ,letbind . ,body-new)))))
|
||||
|
||||
(setq body-new (cconv--convert-funcbody
|
||||
args body new-env parentform))
|
||||
(cond
|
||||
((not (or envector docstring)) ;If no freevars - do nothing.
|
||||
`(function (lambda ,args . ,body-new)))
|
||||
|
|
@ -279,6 +261,30 @@ Returns a form where all lambdas don't have any free variables."
|
|||
(nthcdr 3 mapping)))))
|
||||
new-env))
|
||||
|
||||
(defun cconv--convert-funcbody (funargs funcbody env parentform)
|
||||
"Run `cconv-convert' on FUNCBODY, the forms of a lambda expression.
|
||||
PARENTFORM is the form containing the lambda expression. ENV is a
|
||||
lexical environment (same format as for `cconv-convert'), not
|
||||
including FUNARGS, the function's argument list. Return a list
|
||||
of converted forms."
|
||||
(let ((letbind ()))
|
||||
(dolist (arg funargs)
|
||||
(if (not (member (cons (list arg) parentform) cconv-captured+mutated))
|
||||
(if (assq arg env) (push `(,arg . nil) env))
|
||||
(push `(,arg . (car-safe ,arg)) env)
|
||||
(push `(,arg (list ,arg)) letbind)))
|
||||
(setq funcbody (mapcar (lambda (form)
|
||||
(cconv-convert form env nil))
|
||||
funcbody))
|
||||
(if letbind
|
||||
(let ((special-forms '()))
|
||||
;; Keep special forms at the beginning of the body.
|
||||
(while (or (stringp (car funcbody)) ;docstring.
|
||||
(memq (car-safe (car funcbody)) '(interactive declare)))
|
||||
(push (pop funcbody) special-forms))
|
||||
`(,@(nreverse special-forms) (let ,letbind . ,funcbody)))
|
||||
funcbody)))
|
||||
|
||||
(defun cconv-convert (form env extend)
|
||||
;; This function actually rewrites the tree.
|
||||
"Return FORM with all its lambdas changed so they are closed.
|
||||
|
|
@ -292,6 +298,9 @@ ENV is a list where each entry takes the shape either:
|
|||
environment's Nth slot.
|
||||
(VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
|
||||
additional arguments ARGs.
|
||||
(VAR . nil): VAR is accessed normally. This is the same as VAR
|
||||
being absent from ENV, but an explicit nil entry is useful
|
||||
for shadowing VAR for a specific scope.
|
||||
EXTEND is a list of variables which might need to be accessed even from places
|
||||
where they are shadowed, because some part of ENV causes them to be used at
|
||||
places where they originally did not directly appear."
|
||||
|
|
@ -360,10 +369,8 @@ places where they originally did not directly appear."
|
|||
(not (memq fv funargs)))
|
||||
(push `(,fv . (car-safe ,fv)) funcbody-env)))
|
||||
`(function (lambda ,funcvars .
|
||||
,(mapcar (lambda (form)
|
||||
(cconv-convert
|
||||
form funcbody-env nil))
|
||||
funcbody)))))
|
||||
,(cconv--convert-funcbody
|
||||
funargs funcbody funcbody-env value)))))
|
||||
|
||||
;; Check if it needs to be turned into a "ref-cell".
|
||||
((member (cons binder form) cconv-captured+mutated)
|
||||
|
|
|
|||
40
test/lisp/emacs-lisp/cconv-tests.el
Normal file
40
test/lisp/emacs-lisp/cconv-tests.el
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
;;; cconv-tests.el -*- lexical-binding: t -*-
|
||||
|
||||
;; Copyright (C) 2018 Free Software Foundation, Inc.
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
(require 'ert)
|
||||
|
||||
(ert-deftest cconv-convert-lambda-lifted ()
|
||||
"Bug#30872."
|
||||
(should
|
||||
(equal (funcall
|
||||
(byte-compile
|
||||
'#'(lambda (handle-fun arg)
|
||||
(let* ((subfun
|
||||
#'(lambda (params)
|
||||
(ignore handle-fun)
|
||||
(funcall #'(lambda () (setq params 42)))
|
||||
params)))
|
||||
(funcall subfun arg))))
|
||||
nil 99)
|
||||
42)))
|
||||
|
||||
(provide 'cconv-tests)
|
||||
;; cconv-tests.el ends here.
|
||||
Loading…
Add table
Reference in a new issue