From: Daniel Kochmański <daniel@turtleware.eu>
Date: Wed, 19 Aug 2015 14:02:38 +0000 (+0200)
Subject: destructure: improve context handling
X-Git-Tag: ECL-16.0.0~1^2~16
X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=606d444cbdb2603cf21eff210634a8f2c13e3417;p=ecl.git

destructure: improve context handling

Add handling of arbitrary context as case clause

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

diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp
index f80fb64..08629df 100644
--- a/src/lsp/defmacro.lsp
+++ b/src/lsp/defmacro.lsp
@@ -88,15 +88,21 @@
                *current-form*))
       (error "Too few arguments supplied to a inlined lambda form.")))
 
-(defun sys::destructure (vl macro &aux (basis-form (gensym)) (destructure-symbols (list basis-form)))
+(defun sys::destructure (vl context &aux
+                                      (basis-form (gensym))
+                                      (destructure-symbols (list basis-form)))
   (declare (special *dl* *arg-check*))
   (labels ((tempsym ()
              (let ((x (gensym)))
                (push x destructure-symbols)
                x))
-           (dm-vl (vl whole macro)
+           (dm-vl (vl whole context)
              (multiple-value-bind (reqs opts rest key-flag keys allow-other-keys auxs)
-                 (si::process-lambda-list vl (if macro 'macro 'destructuring-bind))
+                 (si::process-lambda-list
+                  vl (case context
+                       ((defmacro define-compiler-macro)
+                        'macro)
+                       (otherwise 'destructuring-bind)))
                (let* ((pointer (tempsym))
                       (cons-pointer `(truly-the cons ,pointer))
                       (unsafe-car `(car ,cons-pointer))
@@ -106,15 +112,15 @@
                       (ppn (+ (length reqs) (first opts)))
                       all-keywords)
                  ;; In macros, eliminate the name of the macro from the list
-                 (dm-v pointer (if macro
-                                   ;; Special handling if define-compiler-macro called this
-                                   (if (eq macro 'define-compiler-macro)
-                                       `(if (and (eq (car ,whole) 'cl:funcall)
-                                                 (eq (caadr ,whole) 'cl:function))
-                                             (cddr (truly-the cons ,whole))
-                                             (cdr (truly-the cons ,whole)))
-                                       `(cdr (truly-the cons ,whole)))
-                                   whole))
+                 (dm-v pointer (case context
+                                 (define-compiler-macro
+                                  `(if (and (eq (car ,whole) 'cl:funcall)
+                                            (eq (caadr ,whole) 'cl:function))
+                                       (cddr (truly-the cons ,whole))
+                                       (cdr (truly-the cons ,whole))))
+                                 (defmacro
+                                     `(cdr (truly-the cons ,whole)))
+                                 (otherwise whole)))
                  (dolist (v (cdr reqs))
                    (dm-v v `(progn
                               (if (null ,pointer)
@@ -195,7 +201,7 @@
             ((symbolp vl)
              (setq vl (list '&rest vl)))
             (t (error "The destructuring-lambda-list ~s is not a list." vl)))
-      (values (dm-vl vl whole macro) whole
+      (values (dm-vl vl whole context) whole
               (nreverse *dl*)
               *arg-check*
               destructure-symbols))))
diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 27c817e..4584d0b 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -106,7 +106,7 @@ retrieved by (documentation 'NAME 'type)."
   (multiple-value-bind (decls body documentation)
       (si::find-declarations body)
     (multiple-value-bind (ppn whole dl arg-check ignorables)
-        (destructure lambda-list nil)
+        (destructure lambda-list 'deftype)
       (declare (ignore ppn))
       (let ((function `#'(ext::lambda-block ,name (,whole &aux ,@dl)
                                             (declare (ignorable ,@ignorables))