From b2c9ea8c6e5ed96bdd3113475ce7563c8322a92c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 14 Aug 2020 16:30:40 +0200 Subject: [PATCH 1/3] tests: add a regression test for #605 --- src/tests/normal-tests/ansi.lsp | 88 +++++++++++++++++++++------------ 1 file changed, 57 insertions(+), 31 deletions(-) diff --git a/src/tests/normal-tests/ansi.lsp b/src/tests/normal-tests/ansi.lsp index 2df7ed8c..b489199f 100644 --- a/src/tests/normal-tests/ansi.lsp +++ b/src/tests/normal-tests/ansi.lsp @@ -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 From 809b9de86f300dafc412c679c3dc6061d23a57b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 14 Aug 2020 16:30:54 +0200 Subject: [PATCH 2/3] loop: destructuring: allow values shorter than variables We achieve that by adding &optional to every sublist. Fixes #605. --- src/lsp/loop.lsp | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/lsp/loop.lsp b/src/lsp/loop.lsp index c696c3e8..c4bffa13 100644 --- a/src/lsp/loop.lsp +++ b/src/lsp/loop.lsp @@ -659,8 +659,12 @@ 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 + (list* '&optional + (mapcar #'subst-gensyms-for-nil tree))))) (defun loop-build-destructuring-bindings (crocks forms) (if crocks From 8e2d78a4b21822a669a0a1f5a9ae27950ac956d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 17 Aug 2020 20:18:31 +0200 Subject: [PATCH 3/3] loop: destructuring: replace MAPCAR with a DO* loop Simple MAPCAR must be replaced by a slightly more complicated DO, because the list may not be a proper list. I want to dedicate this ballad to myself. This is a tale of a sorry quest To master pure code at the T guru's behest I enrolled in a class that appealing did seem For it promised to teach fine things like T3 and Scheme The first day went fine; we learned of cells And symbols and lists and functions as well Lisp I had mastered and excited was I For to master T3 my hackstincts did cry I sailed through the first week with no problems at all And I even said "closure" instead of "function call" Then said the master that ready were we To start real hacking instead of simple theory Will you, said he, write me a function please That in lists would associate values with keys I went home and turned on my trusty Apollo And wrote a function whose definition follows: (cdr (assq key a-list)) A one-liner I thought, fool that I was Just two simple calls without a COND clause But when I tried this function to run CDR didn't think that NIL was much fun So I tried again like the good King of yore And of code I easily generated some more: (cond ((assq key a-list) => cdr)) It got longer but purer, and it wasn't too bad But then COND ran out and that was quite sad Well, that isn't hard to fix, I was told Just write some more code, my son, be bold Being young, not even a moment did I pause I stifled my instincts and added a clause (cond ((assq key a-list) => cdr) (else nil)) Sometimes this worked and sometimes it broke I debugged and prayed and even had a stroke Many a guru tried valiantly to help But undefined datums their efforts did squelch. I returneth once more to the great sage of T For no way out of the dilemma I could see He said it was easy -- more lines must I fill with code, for FALSE was no longer NIL. (let ((val (assq key a-list))) (cond (val (cdr val)) (else nil))) You'd think by now I might be nearing the end Of my ballad which seems bad things to portend You'd think that we could all go home scot-free But COND eschewed VAL; it wanted #T So I went back to the master and appealed once again I said, pardon me, but now I'm really insane He said, no you're not really going out of your head Instead of just VAL, you must use NOT NULL instead (let ((val (assq key a-list))) (cond ((not (null? val)) (cdr val)) (else nil))) My song is over and I'm going home to bed With this ineffable feeling that I've been misled And just in case my point you have missed Somehow I preferred (CDR (ASSQ KEY A-LIST)) -- Ashwin Ram, "A Short Ballad Dedicated to Program Growth" --- src/lsp/loop.lsp | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/lsp/loop.lsp b/src/lsp/loop.lsp index c4bffa13..1bdee923 100644 --- a/src/lsp/loop.lsp +++ b/src/lsp/loop.lsp @@ -663,8 +663,15 @@ collected result will be returned as the value of the LOOP." (cons (subst-gensyms-for-nil (car tree)) (subst-gensyms-for-nil (cdr tree)))) (t - (list* '&optional - (mapcar #'subst-gensyms-for-nil tree))))) + (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