From: Daniel Kochmański <daniel@turtleware.eu>
Date: Tue, 18 Aug 2015 15:43:01 +0000 (+0200)
Subject: deftype: make maptree non-destructive
X-Git-Tag: ECL-16.0.0~1^2~25
X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=86f09e0c2bd4b66199a73faa0b9a519f3253080b;p=ecl.git

deftype: make maptree non-destructive

Thanks to that we traverse lambda-list tree only once.

Signed-off-by: Daniel Kochmański <daniel@turtleware.eu>
---

diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 9590a5e..27c817e 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -70,36 +70,41 @@ of the original type specifier.  When the symbol NAME is used as a
 type specifier, the expansion function is called with no argument.
 The doc-string DOC, if supplied, is saved as a TYPE doc and can be
 retrieved by (documentation 'NAME 'type)."
-  (setf lambda-list (copy-tree lambda-list))
+  (labels ((set-default (list*)
+             "Sets default value for optional arguments to *. Doesn't
+              modify arguments which happen to be in lambda-list
+              keywords."
+             (if (consp list*)
+                 (let ((variable (car list*)))
+                   (cons
+                    (if (and (symbolp variable)
+                             (not (member variable lambda-list-keywords)))
+                        `(,variable '*)
+                        variable)
+                    (set-default (cdr list*))))
+                 list*))
+           (verify-tree (elt)
+             "Vefrifies if ELT is the list containing optional arg."
+             (and (consp elt)
+                  (member (car elt)
+                          '(&key &optional))))
+           (maptree (function tree test)
+             "Applies FUNCTION to branches for which TEST resolves to
+              true. MAPTREE doesn't traverse this branch further. It
+              is correct in this context, because we can't create
+              nested lambda-list after both &key and &optional, since
+              it would be considered as default value or an error."
+             (cond ((funcall test tree)
+                    (funcall function tree))
+                   ((consp tree)
+                    (cons
+                     (maptree function (car tree) test)
+                     (maptree function (cdr tree) test)))
+                   (T tree))))
+    (setf lambda-list
+          (maptree #'set-default lambda-list #'verify-tree)))
   (multiple-value-bind (decls body documentation)
       (si::find-declarations body)
-    (labels                             ; add '* as default values
-        ((set-default (list*)
-           "Sets default value for optional arguments to *. Doesn't
-         modify arguments which happen to be in lambda-list-keywords."
-           (when (consp list*)
-             (let ((variable (car list*)))
-               (when (and (symbolp variable)
-                          (not (member variable lambda-list-keywords)))
-                 (setf (car list*) `(,variable '*))))
-             (set-default (cdr list*))))
-         (verify-tree (elt)
-           "Verifies if ELT is the list containing optional arguments."
-           (and (consp elt)
-                (member (car elt)
-                        '(&key &optional))))
-         (maptree (function tree test)
-           "Applies FUNCTION to branches for which TEST resolves to
-         true. MAPTREE doesn't traverse this branch further. It is
-         correct in this context, because we can't create nested
-         lambda-list after both &key and &optional, since it would be
-         considered as default value or an error."
-           (if (funcall test tree)
-               (funcall function tree)
-               (when (consp tree)
-                 (maptree function (car tree) test)
-                 (maptree function (cdr tree) test)))))
-      (maptree #'set-default lambda-list #'verify-tree))
     (multiple-value-bind (ppn whole dl arg-check ignorables)
         (destructure lambda-list nil)
       (declare (ignore ppn))