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.
"ANY/TYPE" "EVERY/TYPE"
"TYPE-BOUND-NUMBER"
"CONSTANTLY-T" "CONSTANTLY-NIL" "CONSTANTLY-0"
+ "PSXHASH"
;; ..and macros..
"COLLECT"
(: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)))))
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)
((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)
(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))
(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))))
(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)
\f
;;;; 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))
(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)
--- /dev/null
+;;;; 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)
;;; 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"
projects / sbcl.git / commitdiff