;;;; code analysis stuff
(defun loop-constant-fold-if-possible (form &optional expected-type)
- (let ((new-form form) (constantp nil) (constant-value nil))
- (when (setq constantp (constantp new-form))
- (setq constant-value (eval new-form)))
+ (let* ((constantp (sb!xc:constantp form))
+ (value (and constantp (sb!int:constant-form-value form))))
(when (and constantp expected-type)
- (unless (sb!xc:typep constant-value expected-type)
+ (unless (sb!xc:typep value expected-type)
(loop-warn "~@<The form ~S evaluated to ~S, which was not of ~
the anticipated type ~S.~:@>"
- form constant-value expected-type)
- (setq constantp nil constant-value nil)))
- (values new-form constantp constant-value)))
-
-(defun loop-constantp (form)
- (constantp form))
+ form value expected-type)
+ (setq constantp nil value nil)))
+ (values form constantp value)))
\f
;;;; LOOP iteration optimization
-(defvar *loop-duplicate-code*
- nil)
+(defvar *loop-duplicate-code* nil)
-(defvar *loop-iteration-flag-var*
- (make-symbol "LOOP-NOT-FIRST-TIME"))
+(defvar *loop-iteration-flag-var* (make-symbol "LOOP-NOT-FIRST-TIME"))
(defun loop-code-duplication-threshold (env)
(declare (ignore env))
(defun loop-typed-init (data-type &optional step-var-p)
(when (and data-type (sb!xc:subtypep data-type 'number))
- (if (or (sb!xc:subtypep data-type 'float)
- (sb!xc:subtypep data-type '(complex float)))
- (coerce (if step-var-p 1 0) data-type)
- (if step-var-p 1 0))))
+ (let ((init (if step-var-p 1 0)))
+ (flet ((like (&rest types)
+ (coerce init (find-if (lambda (type)
+ (sb!xc:subtypep data-type type))
+ types))))
+ (cond ((sb!xc:subtypep data-type 'float)
+ (like 'single-float 'double-float
+ 'short-float 'long-float 'float))
+ ((sb!xc:subtypep data-type '(complex float))
+ (like '(complex single-float)
+ '(complex double-float)
+ '(complex short-float)
+ '(complex long-float)
+ '(complex float)))
+ (t
+ init))))))
(defun loop-optional-type (&optional variable)
;; No variable specified implies that no destructuring is permissible.
(defun loop-declare-var (name dtype &optional step-var-p)
(cond ((or (null name) (null dtype) (eq dtype t)) nil)
((symbolp name)
- (unless (sb!xc:subtypep t dtype)
+ (unless (or (sb!xc:subtypep t dtype)
+ (and (eq (find-package :cl) (symbol-package name))
+ (eq :special (sb!int:info :variable :kind name))))
(let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
(if (sb!xc:typep init dtype)
dtype
(t (error "invalid LOOP variable passed in: ~S" name))))
(defun loop-maybe-bind-form (form data-type)
- (if (loop-constantp form)
+ (if (constantp form)
form
(loop-make-var (gensym "LOOP-BIND-") form data-type)))
\f
`(and ,indexv-type real)))))
(:by
(multiple-value-setq (form stepby-constantp stepby)
- (loop-constant-fold-if-possible form `(and ,indexv-type (real (0)))))
+ (loop-constant-fold-if-possible form
+ `(and ,indexv-type (real (0)))))
(unless stepby-constantp
(loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
form
maybe invalid prepositions were specified in iteration path descriptor?"
prep)))
(when (and odir dir (not (eq dir odir)))
- (loop-error "conflicting stepping directions in LOOP sequencing path"))
+ (loop-error
+ "conflicting stepping directions in LOOP sequencing path"))
(setq odir dir))
(when (and sequence-variable (not sequencep))
(loop-error "missing OF or IN phrase in sequence path"))
:key #'type-declaration-of
:from-end t)))
(sb!int:aver (eq decl %decl))
- (setf (cadr decl)
- `(and real ,(cadr decl))))))
+ (when decl
+ (setf (cadr decl)
+ `(and real ,(cadr decl)))))))
;; default start
;; DUPLICATE KLUDGE: loop-make-var generates a temporary
;; symbol for indexv if it is NIL. See also the comment in