From 2768ed83de59354b21ea61de3dea358c53d1ae05 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Wed, 16 Jul 2003 06:59:41 +0000 Subject: [PATCH] 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. --- BUGS | 19 +++++++++++++++++++ src/code/early-type.lisp | 2 -- src/code/late-type.lisp | 7 ++++++- src/code/pprint.lisp | 7 ++++--- src/compiler/array-tran.lisp | 25 +++++++++++++------------ src/compiler/knownfun.lisp | 2 ++ src/compiler/macros.lisp | 9 +++++++-- tests/pprint.impure.lisp | 22 ++++++++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 74 insertions(+), 21 deletions(-) diff --git a/BUGS b/BUGS index 9d6ce58..7586950 100644 --- 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) + # + * (defmethod foo (x) x) + debugger invoked on condition of type SIMPLE-ERROR: + The generic function # takes 0 required + arguments; was asked to find a method with specializers (#) + + 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 --- 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 --- 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 --- 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 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -833,16 +833,17 @@ ;;; value? ;;; 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4