mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-605' into 'develop'

Browse source 
Fix 605

Closes #605

See merge request embeddable-common-lisp/ecl!226
This commit is contained in:
Marius Gerbershagen 2020-08-23 17:14:08 +00:00
commit 5277c82c85
2 changed files with 70 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

15
src/lsp/loop.lsp
View file

@ -659,8 +659,19 @@ collected result will be returned as the value of the LOOP."
(cond
((null tree) (car (push (gensym) *ignores*)))
((atom tree) tree)
(t (cons (subst-gensyms-for-nil (car tree))
(subst-gensyms-for-nil (cdr tree))))))
((atom (cdr tree))
(cons (subst-gensyms-for-nil (car tree))
(subst-gensyms-for-nil (cdr tree))))
(t
(do* ((acc (cons '&optional nil))
(acc-last acc)
(elt tree (cdr elt)))
((atom elt)
(setf (cdr acc-last) elt)
acc)
(setf (cdr acc-last)
(cons (subst-gensyms-for-nil (car elt)) nil))
(setf acc-last (cdr acc-last))))))
(defun loop-build-destructuring-bindings (crocks forms)
(if crocks

88
src/tests/normal-tests/ansi.lsp
View file

@ -45,41 +45,67 @@
(is-true (typep '* '(nest (3) 3)))
(is-true (typep 3 '(nest (2) 3)))))
;;; 6. Iteration
;;; Regression test for #605.
(test ansi.6.1.1.7-destructuring
(finishes
(loop with (a b) = '(1)
do (return (list a b))))
(finishes
(loop with (a b . rest) = '(1)
do (return (list a b rest))))
(is-equal '(1 nil 2 nil)
(loop with (a b) = '(1)
for (c d) = '(2)
do (return (list a b c d))))
(is-equal '(1 nil 2 nil nil)
(loop with (a b . rest) = '(1)
for (c d) = '(2)
do (return (list a b c d rest))))
(is-equal '(1 2 nil)
(loop for (a (b) ((c))) ='(1 (2))
do (return (list a b c))))
(signals error
(loop for (a (b)) ='(1 2)
do (return (list a b)))))
;;; 8. Structures
(ext:with-clean-symbols
(my-struct make-my-struct my-struct-2 make-my-struct-2 my-struct-compatible-type)
(test ansi.8.redefine-compatible
(let (foo-1 foo-2 foo-3 foo-4)
(defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2)
(setq foo-1 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 nil)
(slot-2 t)))
(setq foo-2 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 3)
(slot-2 4)))
(setq foo-3 (make-my-struct))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 8 :type t :read-only nil)
(slot-2 8 :type t :read-only nil)))
(setq foo-4 (make-my-struct :slot-1 3 :slot-2 4))
(is (equalp foo-1 foo-2))
(is (equalp foo-2 foo-3))
(is (equalp foo-3 foo-4)))
(deftype my-struct-compatible-type () `(integer 0 10))
(defstruct (my-struct-2 (:constructor make-my-struct-2))
(slot-1 nil :type my-struct-compatible-type :read-only t))
(finishes
(defstruct my-struct-2
(slot-1 nil :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only nil)))))
(test ansi.8.redefine-compatible
(let (foo-1 foo-2 foo-3 foo-4)
(defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2)
(setq foo-1 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 nil)
(slot-2 t)))
(setq foo-2 (make-my-struct :slot-1 3 :slot-2 4))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 3)
(slot-2 4)))
(setq foo-3 (make-my-struct))
(finishes (defstruct (my-struct (:constructor make-my-struct))
(slot-1 8 :type t :read-only nil)
(slot-2 8 :type t :read-only nil)))
(setq foo-4 (make-my-struct :slot-1 3 :slot-2 4))
(is (equalp foo-1 foo-2))
(is (equalp foo-2 foo-3))
(is (equalp foo-3 foo-4)))
(deftype my-struct-compatible-type () `(integer 0 10))
(defstruct (my-struct-2 (:constructor make-my-struct-2))
(slot-1 nil :type my-struct-compatible-type :read-only t))
(finishes
(defstruct my-struct-2
(slot-1 nil :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only t)))
(finishes
(defstruct my-struct-2
(slot-1 4 :type (integer 0 10) :read-only nil)))))
(ext:with-clean-symbols (my-struct make-my-struct)
(test ansi.8.redefine-incompatible