0.8.1.33:

        * Fixed bug 263: coerce logical block affixes to
          SIMPLE-STRING;
        * COMPLEX-= type method: don't reparse totally unknown type
          specifier;
        * !DEF-BOOLEAN-ATTRIBUTES: create an attributes to list
          decoder;
        * FUN-INFO: print attributes;
        * optimizer for ARRAY-HEADER-P: reimplement as DERIVE-TYPE.

diff --git a/BUGS b/BUGS
index 9d6ce58..7586950 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1067,6 +1067,25 @@ WORKAROUND:
 
   Urgh... It's time to write IR1-copier.
 
+262:
+  In 0.8.1.32:
+
+    * (ensure-generic-function 'foo)
+    #<STANDARD-GENERIC-FUNCTION FOO (0)>
+    * (defmethod foo (x) x)
+    debugger invoked on condition of type SIMPLE-ERROR:
+      The generic function #<STANDARD-GENERIC-FUNCTION FOO (0)> takes 0 required
+      arguments; was asked to find a method with specializers (#<BUILT-IN-CLASS T>)
+
+  AMOP seems to say that it should work (first ADD-METHOD initializes
+  GF lambda list).
+
+263:
+  :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
+  PPRINT-LOGICAL-BLOCK may be complex strings.
+
+  (fixed in 0.8.1.33)
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 048b61a..bbb75ba 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -139,8 +139,6 @@
                      :rest rest
                      :allowp allowp))
 
-;;; FIXME: ANSI VALUES has a short form (without lambda list
-;;; keywords), which should be translated into a long one.
 (defun make-values-type (&key (args nil argsp)
                          required optional rest allowp)
   (if argsp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index cd1a796..296d88c 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1183,7 +1183,12 @@
   (values nil nil))
 
 (!define-type-method (hairy :complex-=) (type1 type2)
-  (if (unknown-type-p type2)
+  (if (and (unknown-type-p type2)
+           (let* ((specifier2 (unknown-type-specifier type2))
+                  (name2 (if (consp specifier2)
+                             (car specifier2)
+                             specifier2)))
+             (info :type :kind name2)))
       (let ((type2 (specifier-type (unknown-type-specifier type2))))
         (if (unknown-type-p type2)
             (values nil nil)

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index af346a5..d17ccfc 100644 (file)
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -314,16 +314,17 @@
   ;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
   ;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
   ;; and might end up being NIL.)
-  (declare (type (or null string prefix)))
+  (declare (type (or null string) prefix))
   ;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
   ;; trivial, so it should always be a string.)
   (declare (type string suffix))
   (when prefix
+    (setq prefix (coerce prefix 'simple-string))
     (pretty-sout stream prefix 0 (length prefix)))
   (let* ((pending-blocks (pretty-stream-pending-blocks stream))
         (start (enqueue stream block-start
                         :prefix (and per-line-p prefix)
-                        :suffix suffix
+                        :suffix (coerce suffix 'simple-string)
                         :depth (length pending-blocks))))
     (setf (pretty-stream-pending-blocks stream)
          (cons start pending-blocks))))
@@ -1006,7 +1007,7 @@
                                (index index)
                                (step (reduce #'* dims))
                                (count 0))
-                          (loop                                
+                          (loop
                             (pprint-pop)
                             (output-guts stream index dims)
                             (when (= (incf count) dim)

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index f9a4947..76e6f48 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -833,16 +833,17 @@
 ;;; value?
 \f
 ;;; Pick off some constant cases.
-(deftransform array-header-p ((array) (array))
+(defoptimizer (array-header-p derive-type) ((array))
   (let ((type (continuation-type array)))
-    (unless (array-type-p type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions type)))
-      (cond ((csubtypep type (specifier-type '(simple-array * (*))))
-            ;; no array header
-            nil)
-           ((and (listp dims) (/= (length dims) 1))
-            ;; multi-dimensional array, will have a header
-            t)
-           (t
-            (give-up-ir1-transform))))))
+    (cond ((not (array-type-p type))
+           nil)
+          (t
+           (let ((dims (array-type-dimensions type)))
+             (cond ((csubtypep type (specifier-type '(simple-array * (*))))
+                    ;; no array header
+                    (specifier-type 'null))
+                   ((and (listp dims) (/= (length dims) 1))
+                    ;; multi-dimensional array, will have a header
+                    (specifier-type '(eql t)))
+                   (t
+                    nil)))))))

diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp
index 001c669..bd35c93 100644 (file)
--- a/src/compiler/knownfun.lisp
+++ b/src/compiler/knownfun.lisp
@@ -116,6 +116,8 @@
   (predicate-type nil :type (or ctype null)))
 
 (defprinter (fun-info)
+  (attributes :test (not (zerop attributes))
+              :prin1 (decode-ir1-attributes attributes))
   (transforms :test transforms)
   (derive-type :test derive-type)
   (optimizer :test optimizer)

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index d105f77..dd15d8c 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -161,7 +161,8 @@
   (def!macro !def-boolean-attribute (name &rest attribute-names)
 
     (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
-         (test-name (symbolicate name "-ATTRIBUTEP")))
+         (test-name (symbolicate name "-ATTRIBUTEP"))
+          (decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES")))
       (collect ((alist))
         (do ((mask 1 (ash mask 1))
             (names attribute-names (cdr names)))
@@ -186,7 +187,11 @@
           ;; building the xc and when building the target compiler.
           (!def-boolean-attribute-setter ,test-name
                                          ,translations-name
-                                         ,@attribute-names)))))
+                                         ,@attribute-names)
+           (defun ,decoder-name (attributes)
+             (loop for (name . mask) in ,translations-name
+                   when (logtest mask attributes)
+                     collect name))))))
 
   ;; It seems to be difficult to express in DEF!MACRO machinery what
   ;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just

diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp
index 216c9e0..ee1f91a 100644 (file)
--- a/tests/pprint.impure.lisp
+++ b/tests/pprint.impure.lisp
@@ -67,5 +67,27 @@
 ;;; way to make an automated test:
 ;;;  (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
 
+;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
+;;; PPRINT-LOGICAL-BLOCK may be complex strings
+(let ((list '(1 2 3))
+      (prefix (make-array 2
+                          :element-type 'character
+                          :displaced-to ";x"
+                          :fill-pointer 1))
+      (suffix (make-array 2
+                          :element-type 'character
+                          :displaced-to ">xy"
+                          :displaced-index-offset 1
+                          :fill-pointer 1)))
+  (assert (equal (with-output-to-string (s)
+                   (pprint-logical-block (s list
+                                            :per-line-prefix prefix
+                                            :suffix suffix)
+                     (format s "~{~W~^~:@_~}" list)))
+                 (format nil ";1~%~
+                              ;2~%~
+                              ;3x"))))
+
+
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 38c70fc..4606f8f 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.1.32"
+"0.8.1.33"