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.
: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
(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)
;; (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))))
(index index)
(step (reduce #'* dims))
(count 0))
- (loop
+ (loop
(pprint-pop)
(output-guts stream index dims)
(when (= (incf count) dim)
;;; 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)))))))
(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)
(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)))
;; 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
;;; 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)
;;; 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"