From: Christophe Rhodes Date: Mon, 16 Dec 2002 16:21:49 +0000 (+0000) Subject: 0.7.10.20: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=fcde5281a74cb29e21550f4f979ad6356f149ab9;p=sbcl.git 0.7.10.20: Fix bug 222 (as per APD sbcl-devel 2002-12-11) ... define the macro in the correct (restricted) lexical context. Fix bug in COERCE [e.g. (COERCE 2 '(SINGLE-FLOAT 3.0 4.0))] ... when converting to a real type, don't be so lenient if the original datum is a rational. Define improved DERIVE-TYPE-OPTIMIZER for COERCE ... for constant RESULT-TYPE arguments, write a branch that understands complex canonicalization ... leave in old branch for ARRAY-ELEMENT-TYPE return types Write DERIVE-TYPE-OPTIMIZER for COMPILE ... (COMPILE NIL ) returns an object of type FUNCTION --- diff --git a/BUGS b/BUGS index cc65d1f..8d43fb9 100644 --- a/BUGS +++ b/BUGS @@ -1206,19 +1206,6 @@ WORKAROUND: arguments, but it could be tricky to check result types of PROG1, IF etc. -222: "environment problems in PCL" - Evaluating - - (symbol-macrolet ((x 1)) - (defmethod foo (z) - (macrolet ((ml (form) `(progn ,form ,x))) - (ml (print x))))) - - causes - - debugger invoked on condition of type UNBOUND-VARIABLE: - The variable X is unbound. - 223: "(SETF FDEFINITION) and #' semantics broken for wrappers" Although this (defun foo (x) diff --git a/NEWS b/NEWS index fcd3ece..88626ff 100644 --- a/NEWS +++ b/NEWS @@ -1444,6 +1444,14 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: (thanks to Dag-Erling Smorgrav) * fixed bug 219: DEFINE-COMPILER-MACRO no longer has compile-time effect when it is not in a toplevel context. + * fixed bug 222: DEFMETHOD and SYMBOL-MACROLET interactions now + stand a better chance of being correct. (thanks to Gerd + Moellmann) + * fixed bug in COERCE, which now signals an error on coercing a + rational to a bounded real type which excludes the expected + answer. + * the compiler is now able to derive types more accurately from the + COERCE and COMPILE functions. * fixed some more bugs revealed by Paul Dietz' test suite: ** As required by ANSI, LOOP now disallows anonymous collection clauses such as COLLECT I in conjunction with aggregate boolean diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 576aba5..ab0d667 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -150,46 +150,63 @@ :format-arguments (list object))) (eval `#',object)) ((numberp object) - (let ((res - (cond - ((csubtypep type (specifier-type 'single-float)) - (%single-float object)) - ((csubtypep type (specifier-type 'double-float)) - (%double-float object)) - #!+long-float - ((csubtypep type (specifier-type 'long-float)) - (%long-float object)) - ((csubtypep type (specifier-type 'float)) - (%single-float object)) - ((csubtypep type (specifier-type '(complex single-float))) - (complex (%single-float (realpart object)) - (%single-float (imagpart object)))) - ((csubtypep type (specifier-type '(complex double-float))) - (complex (%double-float (realpart object)) - (%double-float (imagpart object)))) - #!+long-float - ((csubtypep type (specifier-type '(complex long-float))) - (complex (%long-float (realpart object)) - (%long-float (imagpart object)))) - ((and (typep object 'rational) - (csubtypep type (specifier-type '(complex float)))) - ;; Perhaps somewhat surprisingly, ANSI specifies - ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT, not - ;; dispatching on *READ-DEFAULT-FLOAT-FORMAT*. By - ;; analogy, we do the same for complex numbers. -- - ;; CSR, 2002-08-06 - (complex (%single-float object))) - ((csubtypep type (specifier-type 'complex)) - (complex object)) - (t - (coerce-error))))) - ;; If RES has the wrong type, that means that rule of canonical - ;; representation for complex rationals was invoked. According to - ;; the Hyperspec, (coerce 7/2 'complex) returns 7/2. Thus, if the - ;; object was a rational, there is no error here. - (unless (or (typep res output-type-spec) (rationalp object)) - (coerce-error)) - res)) + (cond + ((csubtypep type (specifier-type 'single-float)) + (let ((res (%single-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + ((csubtypep type (specifier-type 'double-float)) + (let ((res (%double-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + #!+long-float + ((csubtypep type (specifier-type 'long-float)) + (let ((res (%long-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + ((csubtypep type (specifier-type 'float)) + (let ((res (%single-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + (t + (let ((res + (cond + ((csubtypep type (specifier-type '(complex single-float))) + (complex (%single-float (realpart object)) + (%single-float (imagpart object)))) + ((csubtypep type (specifier-type '(complex double-float))) + (complex (%double-float (realpart object)) + (%double-float (imagpart object)))) + #!+long-float + ((csubtypep type (specifier-type '(complex long-float))) + (complex (%long-float (realpart object)) + (%long-float (imagpart object)))) + ((and (typep object 'rational) + (csubtypep type (specifier-type '(complex float)))) + ;; Perhaps somewhat surprisingly, ANSI specifies + ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT, + ;; not dispatching on + ;; *READ-DEFAULT-FLOAT-FORMAT*. By analogy, we + ;; do the same for complex numbers. -- CSR, + ;; 2002-08-06 + (complex (%single-float object))) + ((csubtypep type (specifier-type 'complex)) + (complex object)) + (t + (coerce-error))))) + ;; If RES has the wrong type, that means that rule of + ;; canonical representation for complex rationals was + ;; invoked. According to the Hyperspec, (coerce 7/2 + ;; 'complex) returns 7/2. Thus, if the object was a + ;; rational, there is no error here. + (unless (or (typep res output-type-spec) + (rationalp object)) + (coerce-error)) + res)))) ((csubtypep type (specifier-type 'list)) (if (vectorp object) (cond ((type= type (specifier-type 'list)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index f3b1b5a..4852080 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -35,7 +35,9 @@ ;; FIXME: It's actually not clear that COERCE on non-NUMBER types ;; is FOLDABLE at all. Check this. (movable #-sb-xc-host foldable) - :derive-type (result-type-specifier-nth-arg 2)) + ;; :DERIVE-TYPE RESULT-TYPE-SPEC-NTH-ARG 2 ? Nope... (COERCE 1 'COMPLEX) + ;; returns REAL/INTEGER, not COMPLEX. + ) (defknown list-to-vector* (list type-specifier) vector) (defknown vector-to-vector* (vector type-specifier) vector) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ce2374f..bdcbec7 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3236,83 +3236,158 @@ nil))) (defoptimizer (coerce derive-type) ((value type)) - (let ((value-type (continuation-type value)) - (type-type (continuation-type type))) - (labels - ((good-cons-type-p (cons-type) - ;; Make sure the cons-type we're looking at is something - ;; we're prepared to handle which is basically something - ;; that array-element-type can return. - (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) - (null (first (member-type-members cons-type)))) - (let ((car-type (cons-type-car-type cons-type))) - (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members car-type))) - (numberp (first (first (member-type-members - car-type)))))) - (good-cons-type-p (cons-type-cdr-type cons-type)))))) - (unconsify-type (good-cons-type) - ;; Convert the "printed" respresentation of a cons - ;; specifier into a type specifier. That is, the specifier - ;; (cons (eql signed-byte) (cons (eql 16) null)) is - ;; converted to (signed-byte 16). - (cond ((or (null good-cons-type) - (eq good-cons-type 'null)) - nil) - ((and (eq (first good-cons-type) 'cons) - (eq (first (second good-cons-type)) 'member)) - `(,(second (second good-cons-type)) - ,@(unconsify-type (caddr good-cons-type)))))) - (coerceable-p (c-type) - ;; Can the value be coerced to the given type? Coerce is - ;; complicated, so we don't handle every possible case - ;; here---just the most common and easiest cases: - ;; - ;; o Any real can be coerced to a float type. - ;; o Any number can be coerced to a complex single/double-float. - ;; o An integer can be coerced to an integer. - (let ((coerced-type c-type)) - (or (and (subtypep coerced-type 'float) - (csubtypep value-type (specifier-type 'real))) - (and (subtypep coerced-type - '(or (complex single-float) - (complex double-float))) - (csubtypep value-type (specifier-type 'number))) - (and (subtypep coerced-type 'integer) - (csubtypep value-type (specifier-type 'integer)))))) - (process-types (type) - ;; FIXME: - ;; This needs some work because we should be able to derive - ;; the resulting type better than just the type arg of - ;; coerce. That is, if x is (integer 10 20), the (coerce x - ;; 'double-float) should say (double-float 10d0 20d0) - ;; instead of just double-float. - (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) - ((and (cons-type-p type) - (good-cons-type-p type)) - (let ((c-type (unconsify-type (type-specifier type)))) - (if (coerceable-p c-type) - (specifier-type c-type) - *universal-type*))) - (t - *universal-type*)))) - (cond ((union-type-p type-type) - (apply #'type-union (mapcar #'process-types - (union-type-types type-type)))) - ((or (member-type-p type-type) - (cons-type-p type-type)) - (process-types type-type)) - (t - *universal-type*))))) + (cond + ((constant-continuation-p type) + ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2), + ;; but dealing with the niggle that complex canonicalization gets + ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of + ;; type COMPLEX. + (let* ((specifier (continuation-value type)) + (result-typeoid (careful-specifier-type specifier))) + (cond + ((csubtypep result-typeoid (specifier-type 'number)) + ;; the difficult case: we have to cope with ANSI 12.1.5.3 + ;; Rule of Canonical Representation for Complex Rationals, + ;; which is a truly nasty delivery to field. + (cond + ((csubtypep result-typeoid (specifier-type 'real)) + ;; cleverness required here: it would be nice to deduce + ;; that something of type (INTEGER 2 3) coerced to type + ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0). + ;; FLOAT gets its own clause because it's implemented as + ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE + ;; logic below. + result-typeoid) + ((and (numeric-type-p result-typeoid) + (eq (numeric-type-complexp result-typeoid) :real)) + ;; FIXME: is this clause (a) necessary or (b) useful? + result-typeoid) + ((or (csubtypep result-typeoid + (specifier-type '(complex single-float))) + (csubtypep result-typeoid + (specifier-type '(complex double-float))) + #!+long-float + (csubtypep result-typeoid + (specifier-type '(complex long-float)))) + ;; float complex types are never canonicalized. + result-typeoid) + (t + ;; if it's not a REAL, or a COMPLEX FLOAToid, it's + ;; probably just a COMPLEX or equivalent. So, in that + ;; case, we will return a complex or an object of the + ;; provided type if it's rational: + (type-union result-typeoid + (type-intersection (continuation-type value) + (specifier-type 'rational)))))) + (t result-typeoid)))) + (t + ;; OK, the result-type argument isn't constant. However, there + ;; are common uses where we can still do better than just + ;; *UNIVERSAL-TYPE*: e.g. (COERCE X (ARRAY-ELEMENT-TYPE Y)), + ;; where Y is of a known type. See messages on cmucl-imp + ;; 2001-02-14 and sbcl-devel 2002-12-12. We only worry here + ;; about types that can be returned by (ARRAY-ELEMENT-TYPE Y), on + ;; the basis that it's unlikely that other uses are both + ;; time-critical and get to this branch of the COND (non-constant + ;; second argument to COERCE). -- CSR, 2002-12-16 + (let ((value-type (continuation-type value)) + (type-type (continuation-type type))) + (labels + ((good-cons-type-p (cons-type) + ;; Make sure the cons-type we're looking at is something + ;; we're prepared to handle which is basically something + ;; that array-element-type can return. + (or (and (member-type-p cons-type) + (null (rest (member-type-members cons-type))) + (null (first (member-type-members cons-type)))) + (let ((car-type (cons-type-car-type cons-type))) + (and (member-type-p car-type) + (null (rest (member-type-members car-type))) + (or (symbolp (first (member-type-members car-type))) + (numberp (first (member-type-members car-type))) + (and (listp (first (member-type-members + car-type))) + (numberp (first (first (member-type-members + car-type)))))) + (good-cons-type-p (cons-type-cdr-type cons-type)))))) + (unconsify-type (good-cons-type) + ;; Convert the "printed" respresentation of a cons + ;; specifier into a type specifier. That is, the + ;; specifier (CONS (EQL SIGNED-BYTE) (CONS (EQL 16) + ;; NULL)) is converted to (SIGNED-BYTE 16). + (cond ((or (null good-cons-type) + (eq good-cons-type 'null)) + nil) + ((and (eq (first good-cons-type) 'cons) + (eq (first (second good-cons-type)) 'member)) + `(,(second (second good-cons-type)) + ,@(unconsify-type (caddr good-cons-type)))))) + (coerceable-p (c-type) + ;; Can the value be coerced to the given type? Coerce is + ;; complicated, so we don't handle every possible case + ;; here---just the most common and easiest cases: + ;; + ;; * Any REAL can be coerced to a FLOAT type. + ;; * Any NUMBER can be coerced to a (COMPLEX + ;; SINGLE/DOUBLE-FLOAT). + ;; + ;; FIXME I: we should also be able to deal with characters + ;; here. + ;; + ;; FIXME II: I'm not sure that anything is necessary + ;; here, at least while COMPLEX is not a specialized + ;; array element type in the system. Reasoning: if + ;; something cannot be coerced to the requested type, an + ;; error will be raised (and so any downstream compiled + ;; code on the assumption of the returned type is + ;; unreachable). If something can, then it will be of + ;; the requested type, because (by assumption) COMPLEX + ;; (and other difficult types like (COMPLEX INTEGER) + ;; aren't specialized types. + (let ((coerced-type c-type)) + (or (and (subtypep coerced-type 'float) + (csubtypep value-type (specifier-type 'real))) + (and (subtypep coerced-type + '(or (complex single-float) + (complex double-float))) + (csubtypep value-type (specifier-type 'number)))))) + (process-types (type) + ;; FIXME: This needs some work because we should be able + ;; to derive the resulting type better than just the + ;; type arg of coerce. That is, if X is (INTEGER 10 + ;; 20), then (COERCE X 'DOUBLE-FLOAT) should say + ;; (DOUBLE-FLOAT 10d0 20d0) instead of just + ;; double-float. + (cond ((member-type-p type) + (let ((members (member-type-members type))) + (if (every #'coerceable-p members) + (specifier-type `(or ,@members)) + *universal-type*))) + ((and (cons-type-p type) + (good-cons-type-p type)) + (let ((c-type (unconsify-type (type-specifier type)))) + (if (coerceable-p c-type) + (specifier-type c-type) + *universal-type*))) + (t + *universal-type*)))) + (cond ((union-type-p type-type) + (apply #'type-union (mapcar #'process-types + (union-type-types type-type)))) + ((or (member-type-p type-type) + (cons-type-p type-type)) + (process-types type-type)) + (t + *universal-type*))))))) + +(defoptimizer (compile derive-type) ((nameoid function)) + (when (csubtypep (continuation-type nameoid) + (specifier-type 'null)) + (specifier-type 'function))) +;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving +;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE +;;; optimizer, above). (defoptimizer (array-element-type derive-type) ((array)) (let ((array-type (continuation-type array))) (labels ((consify (list) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 210c4e0..7430d6f 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -101,8 +101,9 @@ ;;; So, now we hide our bits of interest in the walker-info slot in ;;; our new BOGO-FUN. ;;; -;;; MACROEXPAND-1 is the only SBCL function that gets called with the -;;; constructed environment argument. +;;; MACROEXPAND-1 and SB-INT:EVAL-IN-LEXENV are the only SBCL +;;; functions that get called with the constructed environment +;;; argument. (/show "walk.lisp 108") @@ -195,15 +196,17 @@ (push (list (car mac) (convert-macro-to-lambda (cadr mac) (cddr mac) + ,old-env (string (car mac)))) ,macros)))) (with-augmented-environment (,new-env ,old-env :functions ,functions :macros ,macros) ,@body)))) -(defun convert-macro-to-lambda (llist body &optional (name "dummy macro")) +(defun convert-macro-to-lambda (llist body env &optional (name "dummy macro")) (let ((gensym (make-symbol name))) - (eval `(defmacro ,gensym ,llist ,@body)) + (eval-in-lexenv `(defmacro ,gensym ,llist ,@body) + (sb-c::make-restricted-lexenv env)) (macro-function gensym))) ;;;; the actual walker @@ -263,7 +266,7 @@ (defun variable-symbol-macro-p (var env) (let ((entry (member var (env-lexical-variables env) :key #'car))) - (when (eq (cadar entry) :macro) + (when (eq (cadar entry) 'sb-sys:macro) entry))) (defvar *var-declarations* '(special)) @@ -844,7 +847,7 @@ :lexical-variables (append (mapcar (lambda (binding) `(,(car binding) - :macro . ,(cadr binding))) + sb-sys:macro . ,(cadr binding))) bindings) (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings diff --git a/tests/arith.impure.lisp b/tests/arith.impure.lisp index 11b1009..e45ab9f 100644 --- a/tests/arith.impure.lisp +++ b/tests/arith.impure.lisp @@ -68,4 +68,4 @@ (assert (raises-error? (coerce (expt 10 1000) 'single-float) type-error)) -(sb-ext:quit :unix-status 104) \ No newline at end of file +(sb-ext:quit :unix-status 104) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 03a3ee0..9041c40 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -491,5 +491,32 @@ (assert (equal *d-m-c-args-test* '("unlock" "object-lock" "lock" "object-lock"))) +;;; The walker (on which DEFMETHOD depended) didn't know how to handle +;;; SYMBOL-MACROLET properly. In fact, as of sbcl-0.7.10.20 it still +;;; doesn't, but it does well enough to compile the following without +;;; error (the problems remain in asking for a complete macroexpansion +;;; of an arbitrary form). +(symbol-macrolet ((x 1)) + (defmethod bug222 (z) + (macrolet ((frob (form) `(progn ,form ,x))) + (frob (print x))))) +(assert (= (bug222 t) 1)) + +;;; also, a test case to guard against bogus environment hacking: +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq bug222-b 3)) +;;; this should at the least compile: +(let ((bug222-b 1)) + (defmethod bug222-b (z stream) + (macrolet ((frob (form) `(progn ,form ,bug222-b))) + (frob (format stream "~D~%" bug222-b))))) +;;; and it would be nice (though not specified by ANSI) if the answer +;;; were as follows: +(let ((x (make-string-output-stream))) + ;; not specified by ANSI + (assert (= (bug222-b t x) 3)) + ;; specified. + (assert (char= (char (get-output-stream-string x) 0) #\1))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index f024d7b..d1f84f0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.10.19" +"0.7.10.20"