run-program: Improve argument escaping on WIN32.

[sbcl.git] / src / pcl / ctor.lisp

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index e360052..31fc178 100644 (file)
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -152,7 +152,21 @@
           (ctor-function-name ctor))))
 
 (defun make-ctor-function-name (class-name initargs safe-code-p)
-  (list* 'ctor class-name safe-code-p initargs))
+  (labels ((arg-name (x)
+             (typecase x
+               ;; this list of types might look arbitrary but it is
+               ;; exactly the set of types descended into by EQUAL,
+               ;; which is the predicate used by globaldb to test for
+               ;; name equality.
+               (list (gensym "LIST-INITARG-"))
+               (string (gensym "STRING-INITARG-"))
+               (bit-vector (gensym "BIT-VECTOR-INITARG-"))
+               (pathname (gensym "PATHNAME-INITARG-"))
+               (t x)))
+           (munge (list)
+             (let ((*gensym-counter* 0))
+               (mapcar #'arg-name list))))
+    (list* 'ctor class-name safe-code-p (munge initargs))))
 
 ;;; Keep this a separate function for testing.
 (defun ensure-ctor (function-name class-name initargs safe-code-p)
@@ -545,7 +559,7 @@
                                 '(:instance :class)))
                       (class-slots class))
                (not maybe-invalid-initargs)
-               (not (nonstandard-primary-method-p
+               (not (hairy-around-or-nonstandard-primary-method-p
                      ii-methods *the-system-ii-method*))
                (not (around-or-nonstandard-primary-method-p
                      si-methods *the-system-si-method*)))
@@ -569,14 +583,16 @@
         when (null qualifiers) do
           (setq primary-checked-p t)))
 
-(defun nonstandard-primary-method-p
+(defun hairy-around-or-nonstandard-primary-method-p
     (methods &optional standard-method)
   (loop with primary-checked-p = nil
         for method in methods
         as qualifiers = (if (consp method)
                             (early-method-qualifiers method)
                             (safe-method-qualifiers method))
-        when (or (and (null qualifiers)
+        when (or (and (eq :around (car qualifiers))
+                      (not (simple-next-method-call-p method)))
+              (and (null qualifiers)
                       (not primary-checked-p)
                       (not (null standard-method))
                       (not (eq standard-method method))))
@@ -588,7 +604,7 @@
   (declare (ignore ii-methods si-methods))
   (let ((class (ctor-class ctor))
         (lambda-list (make-ctor-parameter-list ctor))
-        (initargs (quote-plist-keys (ctor-initargs ctor))))
+        (initargs (ctor-initargs ctor)))
     (if use-make-instance
         `(lambda ,lambda-list
            (declare #.*optimize-speed*)
@@ -596,13 +612,13 @@
            ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
            ;; compilation of the constructor, hence avoiding the
            ;; possibility of endless recursion.
-           (make-instance ,class ,@initargs))
+           (make-instance ,class ,@(quote-plist-keys initargs)))
         (let ((defaults (class-default-initargs class)))
           (when defaults
             (setf initargs (ctor-default-initargs initargs defaults)))
           `(lambda ,lambda-list
              (declare #.*optimize-speed*)
-             (fast-make-instance ,class ,@initargs))))))
+             (fast-make-instance ,class ,@(quote-plist-keys initargs)))))))
 
 ;;; Not as good as the real optimizing generator, but faster than going
 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
@@ -868,8 +884,8 @@
                                             ,value-form))))
                              (not-boundp-form ()
                                (if (member slotd sbuc-slots :test #'eq)
-                                   `(slot-boundp-using-class
-                                     ,class .instance. ,slotd)
+                                   `(not (slot-boundp-using-class
+                                          ,class .instance. ,slotd))
                                    `(eq (clos-slots-ref .slots. ,i)
                                         +slot-unbound+))))
                         (ecase kind