* Fix bug in RETURN clause of LOOP
... make RETURN be equivalent to DO (RETURN ...)
* cosmetic changes in constraint propagator;
* fix EVAL-WHEN and package problem in
compiler.impure-cload.test from the last commit.
(setq *loop-names* (list name))))
(defun loop-do-return ()
(setq *loop-names* (list name))))
(defun loop-do-return ()
- (loop-pseudo-body (loop-construct-return (loop-get-form))))
+ (loop-emit-body (loop-construct-return (loop-get-form))))
\f
;;;; value accumulation: LIST
\f
;;;; value accumulation: LIST
(when (eq (functional-kind fun) :let)
(loop with call = (continuation-dest
(node-cont (first (lambda-refs fun))))
(when (eq (functional-kind fun) :let)
(loop with call = (continuation-dest
(node-cont (first (lambda-refs fun))))
- for var in (lambda-vars fun)
- and val in (combination-args call)
- when (and val
- (lambda-var-constraints var)
- ;; if VAR has no SETs, type inference is
- ;; fully performed by IR1 optimizer
- (lambda-var-sets var))
- do (let* ((type (continuation-type val))
- (con (find-constraint 'typep var type nil)))
- (sset-adjoin con gen))))))
+ for var in (lambda-vars fun)
+ and val in (combination-args call)
+ when (and val
+ (lambda-var-constraints var)
+ ;; if VAR has no SETs, type inference is
+ ;; fully performed by IR1 optimizer
+ (lambda-var-sets var))
+ do (let* ((type (continuation-type val))
+ (con (find-constraint 'typep var type nil)))
+ (sset-adjoin con gen))))))
(ref
(let ((var (ok-ref-lambda-var node)))
(when var
(ref
(let ((var (ok-ref-lambda-var node)))
(when var
(con (find-constraint 'typep var atype nil)))
(sset-adjoin con gen)))))))
(cset
(con (find-constraint 'typep var atype nil)))
(sset-adjoin con gen)))))))
(cset
- (let ((var (set-var node)))
- (when (lambda-var-p var)
- (when set-preprocessor
- (funcall set-preprocessor var))
- (let ((cons (lambda-var-constraints var)))
- (when cons
- (sset-difference gen cons)
- (let* ((type (single-value-type (node-derived-type node)))
- (con (find-constraint 'typep var type nil)))
- (sset-adjoin con gen)))))))))
+ (binding* ((var (set-var node))
+ (nil (lambda-var-p var) :exit-if-null)
+ (cons (lambda-var-constraints var) :exit-if-null))
+ (when set-preprocessor
+ (funcall set-preprocessor var))
+ (sset-difference gen cons)
+ (let* ((type (single-value-type (node-derived-type node)))
+ (con (find-constraint 'typep var type nil)))
+ (sset-adjoin con gen))))))
(constraint-propagate-in-block
block (block-in block)
:ref-preprocessor (lambda (node cons)
(constraint-propagate-in-block
block (block-in block)
:ref-preprocessor (lambda (node cons)
- (let ((var (ref-leaf node)))
- (when (lambda-var-p var)
- (let ((con (lambda-var-constraints var)))
- (when con
- (constrain-ref-type node con cons))))))))
+ (let* ((var (ref-leaf node))
+ (con (lambda-var-constraints var)))
+ (constrain-ref-type node con cons)))))
;;; Give an empty constraints set to any var that doesn't have one and
;;; isn't a set closure var. Since a var that we previously rejected
;;; Give an empty constraints set to any var that doesn't have one and
;;; isn't a set closure var. Since a var that we previously rejected
-(load "assertoid.lisp")
-(use-package "ASSERTOID")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (load "assertoid.lisp")
+ (use-package "ASSERTOID"))
;;; bug 254: compiler falure
(defpackage :bug254 (:use :cl))
;;; bug 254: compiler falure
(defpackage :bug254 (:use :cl))
;;;
(defun bug233a (x)
(declare (optimize (speed 2) (safety 3)))
;;;
(defun bug233a (x)
(declare (optimize (speed 2) (safety 3)))
+;;; bug in LOOP, reported by ??? on c.l.l
+(flet ((foo (l)
+ (loop for x in l
+ when (symbolp x) return x
+ while (numberp x)
+ collect (list x))))
+ (assert (equal (foo '(1 2 #\a 3)) '((1) (2))))
+ (assert (equal (foo '(1 2 x 3)) 'x)))
+
;;; bug 282
;;;
;;; Verify type checking policy in full calls: the callee is supposed
;;; bug 282
;;;
;;; Verify type checking policy in full calls: the callee is supposed
;;; 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".)
;;; 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".)