sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

cmp: fix progv for return during evaluation of symbol and value arguments

Browse source 
Closes #620.
This commit is contained in:
Marius Gerbershagen 2021-01-02 16:38:21 +01:00
parent 2cac9642d4
commit ecb4ed10ea
2 changed files with 29 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
src/cmp/cmpvar.lsp
View file

@ -394,16 +394,15 @@
(let* ((*lcl* *lcl*) (let* ((*lcl* *lcl*)
(lcl (next-lcl)) (lcl (next-lcl))
(sym-loc (make-lcl-var)) (sym-loc (make-lcl-var))
(val-loc (make-lcl-var)) (val-loc (make-lcl-var)))
(*unwind-exit* (cons lcl *unwind-exit*)))
(wt-nl-open-brace) (wt-nl-open-brace)
(wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";") (wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
(let ((*destination* sym-loc)) (c2expr* symbols)) (let ((*destination* sym-loc)) (c2expr* symbols))
(let ((*destination* val-loc)) (c2expr* values)) (let ((*destination* val-loc)) (c2expr* values))
(wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");") (let ((*unwind-exit* (cons lcl *unwind-exit*)))
(c2expr body) (wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
(wt-nl-close-brace) (c2expr body)
)) (wt-nl-close-brace))))
(defun c1psetq (old-args &aux (args nil) (use-psetf nil)) (defun c1psetq (old-args &aux (args nil) (use-psetf nil))
;; A first pass ensures that none of the assigned locations is ;; A first pass ensures that none of the assigned locations is

24
src/tests/normal-tests/compiler.lsp
View file

@ -1943,3 +1943,27 @@
(code `(defmethod test-method () (code `(defmethod test-method ()
,test-obj))) ,test-obj)))
(finishes (eval code))))) (finishes (eval code)))))
;;; Date 2021-01-02
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/620
;;; Description
;;;
;;; RETURN inside the symbol or value arguments for PROGV leads to
;;; a segfault
(ext:with-clean-symbols (*s*)
(test cmp.0083.progv-return
(proclaim '(special *s*))
(is (eql 0 (funcall (compile nil
'(lambda ()
(block nil
(progv (list (return 0)) (list 1))))))))
(is (eql 0 (funcall (compile nil
'(lambda ()
(block nil
(progv '(*s*) (list (return 0)))))))))
(is (not (boundp '*s*)))
(is (eql 1 (funcall (compile nil
'(lambda ()
(block nil
(progv '(*s*) (list 0) (return 1) *s*)))))))
(is (not (boundp '*s*)))))