From: William Harold Newman Date: Fri, 6 Apr 2001 18:08:11 +0000 (+0000) Subject: 0.6.11.33: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=de201aeb12169d0bd377eca4da6116c2797a66ad;p=sbcl.git 0.6.11.33: bug fixes from cmucl-imp.. ..duplicate keys in macro arg lists, Pierre Mai, 2001-03-30 ..SXHASH of strings with fill pointers, Tim Moore, 2001-03-29 (was actually already fixed in SBCL, but I added a test case or two to make sure that it stays fixed) added/enabled regression tests for SXHASH and PSXHASH Screwed-up lambda list syntax isn't a continuable error. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 40f5025..9446fad 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -670,6 +670,7 @@ retained, possibly temporariliy, because it might be used internally." "ANY/TYPE" "EVERY/TYPE" "TYPE-BOUND-NUMBER" "CONSTANTLY-T" "CONSTANTLY-NIL" "CONSTANTLY-0" + "PSXHASH" ;; ..and macros.. "COLLECT" diff --git a/src/code/parse-defmacro-errors.lisp b/src/code/parse-defmacro-errors.lisp index 271b668..cea6ca6 100644 --- a/src/code/parse-defmacro-errors.lisp +++ b/src/code/parse-defmacro-errors.lisp @@ -93,14 +93,16 @@ (:report (lambda (condition stream) (print-defmacro-ll-bind-error-intro condition stream) (format stream + ;; FIXME: These should probably just be three + ;; subclasses of the base class, so that we don't + ;; need to maintain the set of tags both here and + ;; implicitly wherever this macro is used. (ecase (defmacro-ll-broken-key-list-error-problem condition) (:dotted-list "dotted keyword/value list: ~S") (:odd-length "odd number of elements in keyword/value list: ~S") - (:duplicate - "duplicate keyword: ~S") (:unknown-keyword "~{unknown keyword: ~S; expected one of ~{~S~^, ~}~}")) (defmacro-ll-broken-key-list-error-info condition))))) diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index 395f5a4..8ee93ec 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -151,14 +151,11 @@ minimum (1+ minimum) maximum (1+ maximum))) ((eq now-processing :optionals) - (when (> (length var) 3) - (cerror "Ignore extra noise." - "more than variable, initform, and suppliedp ~ - in &optional binding: ~S" - var)) - (push-optional-binding (car var) (cadr var) (caddr var) - `(not (null ,path)) `(car ,path) - name error-kind error-fun) + (destructuring-bind (varname &optional initform supplied-p) + var + (push-optional-binding varname initform supplied-p + `(not (null ,path)) `(car ,path) + name error-kind error-fun)) (setq path `(cdr ,path) maximum (1+ maximum))) ((eq now-processing :keywords) @@ -275,14 +272,15 @@ ((symbolp value-var) (push-let-binding value-var path nil supplied-var init-form)) (t - (error "Illegal optional variable name: ~S" value-var)))) + (error "illegal optional variable name: ~S" value-var)))) (defun defmacro-error (problem kind name) - (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]." + (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" problem kind name)) -;;; Determine whether KEY-LIST is a valid list of keyword/value pairs. Do not -;;; signal the error directly, 'cause we don't know how it should be signaled. +;;; Determine whether KEY-LIST is a valid list of keyword/value pairs. +;;; Do not signal the error directly, 'cause we don't know how it +;;; should be signaled. (defun verify-keywords (key-list valid-keys allow-other-keys) (do ((already-processed nil) (unknown-keyword nil) @@ -297,8 +295,6 @@ (return (values :dotted-list key-list))) ((null (cdr remaining)) (return (values :odd-length key-list))) - ((member (car remaining) already-processed) - (return (values :duplicate (car remaining)))) ((or (eq (car remaining) :allow-other-keys) (member (car remaining) valid-keys)) (push (car remaining) already-processed)) diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index 318e21b..7f6f7b3 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -319,88 +319,3 @@ (mixf result (number-psxhash (realpart key))) (mixf result (number-psxhash (imagpart key))) result)))))) - -;;; SXHASH and PSXHASH should distribute hash values well over the -;;; space of possible values, so that collisions between the hash values -;;; of unequal objects should be very uncommon. -;;; -;;; FIXME: These tests should be enabled once the rest of the system is -;;; stable. (For now, I don't want to mess with things like making sure -;;; that bignums are hashed uniquely.) -;;;#!+sb-test -#+nil -(let* ((test-cases `((0 . 1) - (0 . 1) - (1 . 0) - ((1 . 0) (0 . 0)) - ((0 . 1) (0 . 0)) - ((0 . 0) (1 . 0)) - ((0 . 0) (0 . 1)) - #((1 . 0) (0 . 0)) - #((0 . 1) (0 . 0)) - #((0 . 0) (1 . 0)) - #((0 . 0) (0 . 1)) - #((1 . 0) (0 . 0)) - #((0 1) (0 0)) - #((0 0) (1 0)) - #((0 0) (0 1)) - #(#(1 0) (0 0)) - #(#(0 1) (0 0)) - #(#(0 0) (1 0)) - #(#(0 0) (0 1)) - #(#*00 #*10) - #(#(0 0) (0 1.0d0)) - #(#(-0.0d0 0) (1.0 0)) - ;; KLUDGE: Some multi-dimensional array test cases would - ;; be good here too, but currently SBCL isn't smart enough - ;; to dump them as literals, and I'm too lazy to make - ;; code to create them at run time. -- WHN 20000111 - 44 44.0 44.0d0 - 44 44.0 44.0d0 - -44 -44.0 -44.0d0 - 0 0.0 0.0d0 - -0 -0.0 -0.0d0 - -121 -121.0 -121.0d0 - 3/4 0.75 0.75d0 - -3/4 -0.75 -0.75d0 - 44.1 44.1d0 - 45 45.0 45.0d0 - ,(expt 2 33) ,(expt 2.0 33) ,(expt 2.0d0 33) - ,(- (expt 1/2 50)) ,(- (expt 0.5 50)) ,(- (expt 0.5d0 50)) - ,(- (expt 1/2 50)) ,(- (expt 0.5 50)) ,(- (expt 0.5d0 50)) - #c(1.0 2.0) #c(1 2.0) #c(1.5 -3/2) #c(3/2 -3/2) #c(0 1) - #c(1.0 2.0) #c(1 2.0) #c(1.5 -3/2) #c(3/2 -3/2) #c(0 1) - ,(make-hash-table) - ,(make-hash-table :test 'equal) - "abc" "ABC" "aBc" 'abc #(#\a #\b #\c) #(a b c) #("A" b c) - "abcc" - "" #* #() () (()) #(()) (#()) - "" #* #() () (()) #(()) (#()) - #\x #\X #\* - #\x #\X #\*))) - (dolist (i test-cases) - (unless (typep (sxhash i) '(and fixnum unsigned-byte)) - (error "bad SXHASH behavior for ~S" i)) - (unless (typep (psxhash i) '(and fixnum unsigned-byte)) - (error "bad PSXHASH behavior for ~S" i)) - (dolist (j test-cases) - (flet ((t->boolean (x) (if x t nil))) - ;; Note: It's possible that a change to the hashing algorithm could - ;; leave it correct but still cause this test to bomb by causing an - ;; unlucky random collision. That's not very likely (since there are - ;; (EXPT 2 29) possible hash values and only on the order of 100 test - ;; cases, but it's probably worth checking if you are getting a - ;; mystifying error from this test. - (unless (eq (t->boolean (equal i j)) - (t->boolean (= (sxhash i) (sxhash j)))) - (error "bad SXHASH behavior for ~S ~S" i j)) - (unless (eq (t->boolean (equalp i j)) - (t->boolean (= (psxhash i) (psxhash j)))) - (error "bad PSXHASH behavior for ~S ~S" i j)))))) - -;;; FIXME: Test that the the hash functions can deal with common cases without -;;; consing. -;(defun consless-test () -; (dotimes (j 100000) -; (dolist (i '("yo" #(1 2 3) #2A((1 2) (1 2)) (1 2 (3)) 1 1.0 1.0d0)) -; (psxhash i)))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d848bf6..155afd1 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -295,7 +295,8 @@ (won nil) (res (catch 'local-call-lossage (prog1 - (ir1-convert-lambda (functional-inline-expansion fun)) + (ir1-convert-lambda (functional-inline-expansion + fun)) (setq won t))))) (cond (won (change-ref-leaf ref res) @@ -602,33 +603,33 @@ ;;;; LET conversion ;;;; -;;;; Converting to a LET has differing significance to various parts of the -;;;; compiler: -;;;; -- The body of a LET is spliced in immediately after the corresponding -;;;; combination node, making the control transfer explicit and allowing -;;;; LETs to be mashed together into a single block. The value of the LET is -;;;; delivered directly to the original continuation for the call, -;;;; eliminating the need to propagate information from the dummy result -;;;; continuation. -;;;; -- As far as IR1 optimization is concerned, it is interesting in that -;;;; there is only one expression that the variable can be bound to, and -;;;; this is easily substitited for. -;;;; -- LETs are interesting to environment analysis and to the back end -;;;; because in most ways a LET can be considered to be "the same function" -;;;; as its home function. -;;;; -- LET conversion has dynamic scope implications, since control transfers -;;;; within the same environment are local. In a local control transfer, -;;;; cleanup code must be emitted to remove dynamic bindings that are no -;;;; longer in effect. - -;;; Set up the control transfer to the called lambda. We split the call -;;; block immediately after the call, and link the head of FUN to the call -;;; block. The successor block after splitting (where we return to) is -;;; returned. -;;; -;;; If the lambda is is a different component than the call, then we call -;;; JOIN-COMPONENTS. This only happens in block compilation before -;;; FIND-INITIAL-DFO. +;;;; Converting to a LET has differing significance to various parts +;;;; of the compiler: +;;;; -- The body of a LET is spliced in immediately after the +;;;; corresponding combination node, making the control transfer +;;;; explicit and allowing LETs to be mashed together into a single +;;;; block. The value of the LET is delivered directly to the +;;;; original continuation for the call,eliminating the need to +;;;; propagate information from the dummy result continuation. +;;;; -- As far as IR1 optimization is concerned, it is interesting in +;;;; that there is only one expression that the variable can be bound +;;;; to, and this is easily substitited for. +;;;; -- LETs are interesting to environment analysis and to the back +;;;; end because in most ways a LET can be considered to be "the +;;;; same function" as its home function. +;;;; -- LET conversion has dynamic scope implications, since control +;;;; transfers within the same environment are local. In a local +;;;; control transfer, cleanup code must be emitted to remove +;;;; dynamic bindings that are no longer in effect. + +;;; Set up the control transfer to the called lambda. We split the +;;; call block immediately after the call, and link the head of FUN to +;;; the call block. The successor block after splitting (where we +;;; return to) is returned. +;;; +;;; If the lambda is is a different component than the call, then we +;;; call JOIN-COMPONENTS. This only happens in block compilation +;;; before FIND-INITIAL-DFO. (defun insert-let-body (fun call) (declare (type clambda fun) (type basic-combination call)) (let* ((call-block (node-block call)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 0aeda7e..e28b656 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -27,5 +27,17 @@ (cons x y)) (assert (equal (cons 1 2) (newfangled-cons 'right-thing 2 'left-thing 1))) +;;; ANSI specifically says that duplicate keys are OK in lambda lists, +;;; with no special exception for macro lambda lists. (As reported by +;;; Pierre Mai on cmucl-imp 2001-03-30, Python didn't think so. The +;;; rest of the thread had some entertainment value, at least for me +;;; (WHN). The unbelievers were besmote and now even CMU CL will +;;; conform to the spec in this regard. Who needs diplomacy when you +;;; have brimstone?:-) +(defmacro ayup-duplicate-keys-are-ok-i-see-the-lite (&key k) + k) +(assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 112) 112)) +(assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 'x :k 'y) 'x)) + ;;; success (quit :unix-status 104) diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp new file mode 100644 index 0000000..4641dc4 --- /dev/null +++ b/tests/hash.impure.lisp @@ -0,0 +1,202 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +(defstruct foo) +(defstruct bar x y) + +;;; SXHASH and PSXHASH should distribute hash values well over the +;;; space of possible values, so that collisions between the hash +;;; values of unequal objects should be very uncommon. (Except of +;;; course the hash values must collide when the objects are EQUAL or +;;; EQUALP respectively!) +(locally + ;; In order to better test not-EQ-but-EQUAL and not-EQ-but-EQUALP, + ;; we'd like to suppress some optimizations. + (declare (notinline complex float coerce + - expt)) + (flet ((make-sxhash-subtests () + (list (cons 0 1) + (list 0 1) + (cons 1 0) + (cons (cons 1 0) (cons 0 0)) + (cons (list 1 0) (list 0 0)) + (list (cons 1 0) (list 0 0)) + (list (cons 0 1) (list 0 0)) + (list (cons 0 0) (cons 1 0)) + (list (cons 0 0) (cons 0 1)) + + 44 (float 44) (coerce 44 'double-float) + -44 (float -44) (coerce -44 'double-float) + 0 (float 0) (coerce 0 'double-float) + -0 (- (float 0)) (- (coerce 0 'double-float)) + -121 (float -121) (coerce -121 'double-float) + 3/4 (float 3/4) (coerce 3/4 'double-float) + -3/4 (float -3/4) (coerce -3/4 'double-float) + 45 (float 45) (coerce 45 'double-float) + 441/10 (float 441/10) (coerce (float 441/10) 'double-float) + + (expt 2 33) (expt 2.0 33) (expt 2.0d0 33) + (- (expt 1/2 50)) (- (expt 0.5 50)) (- (expt 0.5d0 50)) + (+ (expt 1/2 50)) (+ (expt 0.5 50)) (+ (expt 0.5d0 50)) + + (complex 1.0 2.0) (complex 1.0d0 2.0) + (complex 1.5 -3/2) (complex 1.5 -1.5d0) + + #\x #\X #\*)) + (make-psxhash-extra-subtests () + (list (copy-seq "") + (copy-seq #*) + (copy-seq #()) + (copy-seq ()) + (copy-seq '(())) + (copy-seq #(())) + (copy-seq '(#())) + (make-array 3 :fill-pointer 0) + (make-array 7 :fill-pointer 0 :element-type 'bit) + (make-array 8 :fill-pointer 0 :element-type 'character) + (vector (cons 1 0) (cons 0 0)) + (vector (cons 0 1) (cons 0 0)) + (vector (cons 0 0) (cons 1 0)) + (vector (cons 0 0) (cons 0 1)) + (vector (cons 1 0) (cons 0 0)) + (vector (cons 0 1) (cons 0 0)) + (vector (list 0 0) (cons 1 0)) + (vector (list 0 0) (list 0 1)) + (vector (vector 1 0) (list 0 0)) + (vector (vector 0 1) (list 0 0)) + (vector (vector 0 0) (list 1 0)) + (vector (vector 0 0) (list 0 1)) + (vector #*00 #*10) + (vector (vector 0 0) (list 0 1.0d0)) + (vector (vector -0.0d0 0) (list 1.0 0)) + (vector 1 0 1 0) + (vector 0 0 0) + (copy-seq #*1010) + (copy-seq #*000) + (replace (make-array 101 + :element-type 'bit + :fill-pointer 4) + #*1010) + (replace (make-array 14 + :element-type '(unsigned-byte 8) + :fill-pointer 3) + #*000) + (replace (make-array 14 + :element-type t + :fill-pointer 3) + #*000) + (copy-seq "abc") + (copy-seq "ABC") + (copy-seq "aBc") + (copy-seq "abcc") + (copy-seq "1001") + 'abc + (vector #\a #\b #\c) + (vector 'a 'b 'c) + (vector "A" 'b 'c) + (replace (make-array 14 + :element-type 'character + :fill-pointer 3) + "aBc") + (replace (make-array 11 + :element-type 'character + :fill-pointer 4) + "1001") + (replace (make-array 12 + :element-type 'bit + :fill-pointer 4) + #*1001) + (replace (make-array 13 + :element-type t + :fill-pointer 4) + "1001") + (replace (make-array 13 + :element-type t + :fill-pointer 4) + #*1001) + ;; FIXME: What about multi-dimensional arrays, hmm? + + (make-hash-table) + (make-hash-table :test 'equal) + + (make-foo) + (make-bar) + (make-bar :x (list 1)) + (make-bar :y (list 1)))) + (t->boolean (x) (if x t nil))) + (let* (;; Note: + ;; * The APPEND noise here is to help more strenuously test + ;; not-EQ-but-EQUAL and not-EQ-but-EQUALP cases. + ;; * It seems not to be worth the hassle testing SXHASH on + ;; values whose structure isn't understood by EQUAL, since + ;; we get too many false positives "SXHASHes are equal even + ;; though values aren't EQUAL, what a crummy hash function!" + ;; FIXME: Or am I misunderstanding the intent of the + ;; the SXHASH specification? Perhaps SXHASH is supposed to + ;; descend into the structure of objects even when EQUAL + ;; doesn't, in order to avoid hashing together things which + ;; are guaranteed not to be EQUAL? The definition of SXHASH + ;; seems to leave this completely unspecified: should + ;; "well-distributed" depend on substructure that EQUAL + ;; ignores? For our internal hash tables, the stricter + ;; descend-into-the-structure behavior might improve + ;; performance even though it's not specified by ANSI. But + ;; is it reasonable for users to expect it? Hmm.. + (sxhash-tests (append (make-sxhash-subtests) + (make-sxhash-subtests))) + (psxhash-tests (append sxhash-tests + (make-psxhash-extra-subtests) + (make-psxhash-extra-subtests)))) + ;; Check that SXHASH compiler transforms give the same results + ;; as the out-of-line version of SXHASH. + (let* ((fundef `(lambda () + (list ,@(mapcar (lambda (value) + `(sxhash ',value)) + sxhash-tests)))) + (fun (compile nil fundef))) + (assert (equal (funcall fun) + (mapcar #'sxhash sxhash-tests)))) + ;; Note: The tests for SXHASH-equality iff EQUAL and + ;; PSXHASH-equality iff EQUALP could fail because of an unlucky + ;; random collision. That's not very likely (since there are + ;; (EXPT 2 29) possible hash values and only on the order of 100 + ;; test cases, so even with the birthday paradox a collision has + ;; probability only (/ (EXPT 100 2) (EXPT 2 29)), but it's + ;; probably worth checking if you are getting a mystifying error + ;; from this test. (SXHASH values and PSXHASH values don't + ;; change from run to run, so the random chance of bogus failure + ;; happens once every time the code is changed in such a way + ;; that the SXHASH distribution changes, not once every time the + ;; tests are run.) + (dolist (i sxhash-tests) + (unless (typep (sxhash i) '(and fixnum unsigned-byte)) + (error "bad SXHASH behavior for ~S" i)) + (dolist (j sxhash-tests) + (unless (eq (t->boolean (equal i j)) + (t->boolean (= (sxhash i) (sxhash j)))) + ;; (If you get a surprising failure here, maybe you were + ;; just very unlucky; see the notes above.) + (error "bad SXHASH behavior for ~S ~S" i j)))) + #| + (dolist (i psxhash-tests) + (unless (typep (sb-int:psxhash i) '(and fixnum unsigned-byte)) + (error "bad PSXHASH behavior for ~S" i)) + (dolist (j psxhash-tests) + (unless (eq (t->boolean (equalp i j)) + (t->boolean (= (sb-int:psxhash i) (sb-int:psxhash j)))) + ;; (If you get a surprising failure here, maybe you were + ;; just very unlucky; see the notes above.) + (error "bad PSXHASH behavior for ~S ~S" i j)))) + |#))) + +;;; success +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index da5ccc5..298d226 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.32" +"0.6.11.33"