Try to avoid global block name collision between defining macros.
authorJean-Claude Beaudoin <jean.claude.beaudoin@gmail.com>
Sat, 13 Jul 2013 10:35:37 +0000 (06:35 -0400)
committerJean-Claude Beaudoin <jean.claude.beaudoin@gmail.com>
Sat, 13 Jul 2013 10:35:37 +0000 (06:35 -0400)
src/lsp/predlib.lsp
src/lsp/setf.lsp

index 7c55db1..1550b15 100644 (file)
@@ -64,10 +64,11 @@ by (documentation 'NAME 'type)."
       `(define-when (:compile-toplevel :load-toplevel :execute)
          ,@(si::expand-set-documentation name 'type doc)
          (do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body)
-                     #'(si::LAMBDA-BLOCK ,name (,whole-var ,env-var)
+                     #'(si::LAMBDA (,whole-var ,env-var)
                          (declare (ignorable ,env-var))
                          (destructuring-bind ,lambda-list (if (consp ,whole-var) (cdr ,whole-var) nil)
-                           ,@body)))))))
+                           (block ,name
+                             ,@body))))))))
 
 
 ;;; Some DEFTYPE definitions.
@@ -794,7 +795,7 @@ if not possible."
             BIT-VECTOR SIMPLE-BIT-VECTOR)
            (concatenate type object))
           (t
-           (if (or (listp object) (vector object))
+           (if (or (listp object) (vectorp object))
                (concatenate type object)
                (error-coerce object type)))))
        ((eq (setq aux (first type)) 'COMPLEX)
@@ -813,7 +814,7 @@ if not possible."
         (unless (typep-in-env aux type nil)
           (error-coerce object type))
         aux)
-       ((or (listp object) (vector object))
+       ((or (listp object) (vectorp object))
         (concatenate type object))
        (t
         (error-coerce object type))))
index 7a0541b..be34d9a 100644 (file)
@@ -43,20 +43,22 @@ by (documentation 'SYMBOL 'setf)."
        (t
         (let* ((store (second rest))
                (args (first rest))
-               (body (cddr rest))
-               (doc (find-documentation body)))
+               (body+ (cddr rest))
+                )
+           (multiple-value-bind (decls body doc)
+               (process-declarations body+ t)
           (check-stores-number 'DEFSETF store 1)
           `(define-when (compile load eval)
-             (put-sysprop ',access-fn 'SETF-LAMBDA #'(si::lambda-block ,access-fn (,@store ,@args) ,@body))
+             (put-sysprop ',access-fn 'SETF-LAMBDA #'(lambda (,@store ,@args) (declare ,@decls) (block ,access-fn ,@body)))
              (rem-sysprop ',access-fn 'SETF-UPDATE-FN)
              (rem-sysprop ',access-fn 'SETF-METHOD)
              (rem-sysprop ',access-fn 'SETF-SYMBOL)
              ,@(si::expand-set-documentation access-fn 'setf doc)
-             ',access-fn)))))
+             ',access-fn))))))
 
 
 ;;; DEFINE-SETF-METHOD macro.
-(defmacro define-setf-expander (access-fn args &rest body)
+(defmacro define-setf-expander (access-fn args &rest body+)
   "Syntax: (define-setf-expander symbol defmacro-lambda-list {decl | doc}*
           {form}*)
 Defines the SETF-method for generalized-variables (SYMBOL ...).
@@ -84,15 +86,16 @@ by (DOCUMENTATION 'SYMBOL 'SETF)."
        (progn
          (setq env (gensym))
          (setq args (cons env args))
-         (push `(declare (ignore ,env)) body))))
+         (push `(declare (ignore ,env)) body+))))
+  (multiple-value-bind (decls body doc)
+      (process-declarations body+ t)
   `(define-when (compile load eval)
-     (put-sysprop ',access-fn 'SETF-METHOD #'(si::lambda-block ,access-fn ,args ,@body))
+     (put-sysprop ',access-fn 'SETF-METHOD #'(lambda ,args (declare ,@decls) (block ,access-fn ,@body)))
      (rem-sysprop ',access-fn 'SETF-LAMBDA)
      (rem-sysprop ',access-fn 'SETF-UPDATE-FN)
      (rem-sysprop ',access-fn 'SETF-SYMBOL)
-     ,@(si::expand-set-documentation access-fn 'setf
-                                    (find-documentation body))
-     ',access-fn))
+     ,@(si::expand-set-documentation access-fn 'setf doc)
+     ',access-fn)))
 
 
 ;;;; get-setf-expansion.