IGNORE/IGNORABLE declarations should be acceptable for symbol
macros.
+278:
+ a.
+ (defun foo ()
+ (declare (optimize speed))
+ (loop for i of-type (integer 0) from 0 by 2 below 10
+ collect i))
+
+ uses generic arithmetic.
+
+ b. For the example above, the compiler does not issue a note.
DEFUNCT CATEGORIES OF BUGS
IR1-#:
new array subtypes UNSIGNED-BYTE 7, 15, 29, and 31 mandated by
obscure ANSI requirements
+changes in sbcl-0.8.4 relative to sbcl-0.8.3:
+ * fixed compiler performance when processing loops with a step >1;
+
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
down, it might impact TRACE. They both encapsulate functions, and
;; single-channel-simple-stream
(with-stream-class (single-channel-simple-stream stream)
(let ((ptr (sm buffpos stream)))
- (when (>= ptr (sm buffer-ptr stream))
+ (when (>= ptr (sm buf-len stream))
(setf ptr (sc-flush-buffer stream t)))
(add-stream-instance-flags stream :dirty)
(setf (sm buffpos stream) (1+ ptr))
((or (simple-array (unsigned-byte 8) (*))
(simple-array (signed-byte 8) (*)))
;; "write-vector" equivalent
- (error "implement me")
+ (simple-stream-dispatch stream
+ ;; single-channel-simple-stream
+ (with-stream-class (single-channel-simple-stream stream)
+ (loop with max-ptr = (sm buf-len stream)
+ with real-end = (or end (length seq))
+ for src-pos = start then (+ src-pos count)
+ for src-rest = (- real-end src-pos)
+ while (> src-rest 0) ; FIXME: this is non-ANSI
+ for ptr = (let ((ptr (sm buffpos stream)))
+ (if (>= ptr max-ptr)
+ (sc-flush-buffer stream t)
+ ptr))
+ for buf-rest = (- max-ptr ptr)
+ for count = (min buf-rest src-rest)
+ do (progn (add-stream-instance-flags stream :dirty)
+ (setf (sm buffpos stream) (+ ptr count))
+ (buffer-copy seq src-pos (sm buffer stream) ptr count))))
+ ;; dual-channel-simple-stream
+ (error "Implement me")
+ ;; string-simple-stream
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'stream
+ :format-control "Can't write-byte on string streams."
+ :format-arguments '()))
))))
(eval-when (:load-toplevel) (ensure-directories-exist *test-path*))
+;;; Non-destructive functional analog of REMF
+(defun remove-key (key list)
+ (loop for (current-key val . rest) on list by #'cddr
+ until (eql current-key key)
+ collect current-key into result
+ collect val into result
+ finally (return (nconc result rest))))
+
(defmacro with-test-file ((stream file &rest open-arguments
&key (delete-afterwards t)
initial-content
&allow-other-keys)
&body body)
- (remf open-arguments :delete-afterwards)
- (remf open-arguments :initial-content)
+ (setq open-arguments (remove-key :delete-afterwards open-arguments))
+ (setq open-arguments (remove-key :initial-content open-arguments))
(if initial-content
(let ((create-file-stream (gensym)))
`(progn
(string= content (read-line s))))
t)
+(deftest write-read-large-sc-2
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
+ (stream (make-instance 'file-simple-stream
+ :filename file :direction :output
+ :if-exists :overwrite
+ :if-does-not-exist :create))
+ (length (1+ (* 3 (device-buffer-length stream))))
+ (content (make-string length)))
+ (dotimes (i (length content))
+ (setf (aref content i) (code-char (random 256))))
+ (with-open-stream (s stream)
+ (write-string content s))
+ (with-test-file (s file :class 'file-simple-stream
+ :direction :input :if-does-not-exist :error)
+ (let ((seq (make-string length)))
+ #+nil (read-sequence seq s)
+ #-nil (dotimes (i length)
+ (setf (char seq i) (read-char s)))
+ (string= content seq))))
+ t)
+
+(deftest write-read-large-sc-3
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
+ (stream (make-instance 'file-simple-stream
+ :filename file :direction :output
+ :if-exists :overwrite
+ :if-does-not-exist :create))
+ (length (1+ (* 3 (device-buffer-length stream))))
+ (content (make-array length :element-type '(unsigned-byte 8))))
+ (dotimes (i (length content))
+ (setf (aref content i) (random 256)))
+ (with-open-stream (s stream)
+ (write-sequence content s))
+ (with-test-file (s file :class 'file-simple-stream
+ :direction :input :if-does-not-exist :error)
+ (let ((seq (make-array length :element-type '(unsigned-byte 8))))
+ #+nil (read-sequence seq s)
+ #-nil (dotimes (i length)
+ (setf (aref seq i) (read-byte s)))
+ (equalp content seq))))
+ t)
+
(deftest write-read-large-dc-1
;; Do write and read with more data than the buffer will hold
;; (dual-channel simple-stream; we only have socket streams atm)
;;; file-position-2 fails ONLY when called with
;;; (asdf:oos 'asdf:test-op :sb-simple-streams)
;;; TODO: Find out why
-#+nil
(deftest file-position-2
;; Test reading of file-position
(let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
(read-line s)))
"XooX"
T)
-
-
-
-
"NOT-DUMPED-AT-ALL"
"NUMERIC-CONTAGION" "NUMERIC-TYPE"
"NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP"
+ "NUMERIC-TYPE-EQUAL"
"NUMERIC-TYPE-FORMAT"
"NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P"
"OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR"
(!define-type-class number)
+(declaim (inline numeric-type-equal))
+(defun numeric-type-equal (type1 type2)
+ (and (eq (numeric-type-class type1) (numeric-type-class type2))
+ (eq (numeric-type-format type1) (numeric-type-format type2))
+ (eq (numeric-type-complexp type1) (numeric-type-complexp type2))))
+
(!define-type-method (number :simple-=) (type1 type2)
(values
- (and (eq (numeric-type-class type1) (numeric-type-class type2))
- (eq (numeric-type-format type1) (numeric-type-format type2))
- (eq (numeric-type-complexp type1) (numeric-type-complexp type2))
+ (and (numeric-type-equal type1 type2)
(equalp (numeric-type-low type1) (numeric-type-low type2))
(equalp (numeric-type-high type1) (numeric-type-high type2)))
t))
(declare (ignore sig))
(if (= x 0.0e0)
(values (float 0.0e0 original-x) 1)
- (let* ((ex (round (* exponent (log 2e0 10))))
+ (let* ((ex (locally (declare (optimize (safety 0)))
+ (the fixnum
+ (round (* exponent (log 2e0 10))))))
(x (if (minusp ex)
(if (float-denormalized-p x)
#!-long-float
(z y (* y m))
(ex ex (1- ex)))
((>= z 0.1e0)
- (values (float z original-x) ex))))))))))
+ (values (float z original-x) ex))
+ (declare (long-float m) (integer ex))))
+ (declare (long-float d))))))))
(eval-when (:compile-toplevel :execute)
(setf *read-default-float-format* 'single-float))
\f
;; algorithms, but we're not pushing them hard enough here for them
;; to be cryptographically strong.)
(let* ((xy (+ (* x 3) y)))
- (declare (type (unsigned-byte 32) xy))
- (the (and fixnum unsigned-byte)
- (logand most-positive-fixnum
- (logxor 441516657
- xy
- (the fixnum (ash xy -5)))))))
+ (logand most-positive-fixnum
+ (logxor 441516657
+ xy
+ (ash xy -5)))))
\f
;;;; hashing strings
;;;;
(and (ref-p first)
(eq (ref-leaf first) var))))
:exit-if-null)
- (step-type (continuation-type (second +-args))))
+ (step-type (continuation-type (second +-args)))
+ (set-type (continuation-type (set-value set))))
(when (and (numeric-type-p initial-type)
(numeric-type-p step-type)
- (eq (numeric-type-class initial-type)
- (numeric-type-class step-type))
- (eq (numeric-type-format initial-type)
- (numeric-type-format step-type))
- (eq (numeric-type-complexp initial-type)
- (numeric-type-complexp step-type)))
+ (numeric-type-equal initial-type step-type))
(multiple-value-bind (low high)
(cond ((csubtypep step-type (specifier-type '(real 0 *)))
- (values (numeric-type-low initial-type) nil))
+ (values (numeric-type-low initial-type)
+ (when (and (numeric-type-p set-type)
+ (numeric-type-equal set-type initial-type))
+ (numeric-type-high set-type))))
((csubtypep step-type (specifier-type '(real * 0)))
- (values nil (numeric-type-high initial-type)))
+ (values (when (and (numeric-type-p set-type)
+ (numeric-type-equal set-type initial-type))
+ (numeric-type-low set-type))
+ (numeric-type-high initial-type)))
(t
(values nil nil)))
(modified-numeric-type initial-type
(setf (node-reoptimize set) nil))))
(let ((res (res)))
(awhen (maybe-infer-iteration-var-type var initial-type)
- (setq res (type-intersection res it)))
+ (setq res it))
(propagate-to-refs var res)))
(values))
(format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
(format t "/MESSAGE=~S~%" (continuation-value message))
(give-up-ir1-transform "not a real transform"))
- (defun /report-continuation (&rest rest)
- (declare (ignore rest))))
+ (defun /report-continuation (x message)
+ (declare (ignore x message))))
(setf (aref x 4) 'b)
x))))
#(a a a a b a a a a a))))
+
+;;; this is not a check for a bug, but rather a test of compiler
+;;; quality
+(dolist (type '((integer 0 *) ; upper bound
+ (real (-1) *)
+ float ; class
+ (real * (-10)) ; lower bound
+ ))
+ (assert (nth-value
+ 1 (compile nil
+ `(lambda (n)
+ (declare (optimize (speed 3) (compilation-speed 0)))
+ (loop for i from 1 to (the (integer -17 10) n) by 2
+ collect (when (> (random 10) 5)
+ (the ,type (- i 11)))))))))
;;; with something arbitrary in the fourth field, is used for CVS
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
-"0.8.3.1"
+"0.8.3.2"
projects / sbcl.git / commitdiff