(setq constant-value (eval new-form)))
(when (and constantp expected-type)
(unless (sb!xc:typep constant-value expected-type)
- (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
+ (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)))
;; CLTL2, removed from ANSI standard) we could set these
;; values flexibly. Without DECLARATION-INFORMATION, we have
;; to set them to constants.
+ ;;
+ ;; except FIXME: we've lost all pretence of portability,
+ ;; considering this instead an internal implementation, so
+ ;; we're free to couple to our own representation of the
+ ;; environment.
(speed 1)
(space 1))
(+ 40 (* (- speed space) 10))))
((loop-tequal prep :below) (setq dir ':up)))
(setq limit-given t)
(multiple-value-setq (form limit-constantp limit-value)
- (loop-constant-fold-if-possible form indexv-type))
+ (loop-constant-fold-if-possible form `(and ,indexv-type real)))
(setq endform (if limit-constantp
`',limit-value
(loop-make-var
- (gensym "LOOP-LIMIT-") form indexv-type))))
+ (gensym "LOOP-LIMIT-") form
+ `(and ,indexv-type real)))))
(:by
- (multiple-value-setq (form stepby-constantp stepby)
- (loop-constant-fold-if-possible form indexv-type))
- (unless stepby-constantp
- (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
- form
- indexv-type)))
+ (multiple-value-setq (form stepby-constantp stepby)
+ (loop-constant-fold-if-possible form `(and ,indexv-type (real (0)))))
+ (unless stepby-constantp
+ (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
+ form
+ `(and ,indexv-type (real (0))))))
(t (loop-error
- "~S invalid preposition in sequencing or sequence path;~@
- maybe invalid prepositions were specified in iteration path descriptor?"
+ "~S invalid preposition in sequencing or sequence path;~@
+ 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"))
(when (and sequence-variable (not sequencep))
(loop-error "missing OF or IN phrase in sequence path"))
;; Now fill in the defaults.
- (unless start-given
- (loop-make-iteration-var
- indexv
- (setq start-constantp t
- start-value (or (loop-typed-init indexv-type) 0))
- indexv-type))
+ (if start-given
+ (when limit-given
+ ;; if both start and limit are given, they had better both
+ ;; be REAL. We already enforce the REALness of LIMIT,
+ ;; above; here's the KLUDGE to enforce the type of START.
+ (flet ((type-declaration-of (x)
+ (and (eq (car x) 'type) (caddr x))))
+ (let ((decl (find indexv *loop-declarations*
+ :key #'type-declaration-of))
+ (%decl (find indexv *loop-declarations*
+ :key #'type-declaration-of
+ :from-end t)))
+ (sb!int:aver (eq decl %decl))
+ (setf (cadr decl)
+ `(and real ,(cadr decl))))))
+ ;; default start
+ (loop-make-iteration-var
+ indexv
+ (setq start-constantp t
+ start-value (or (loop-typed-init indexv-type) 0))
+ `(and ,indexv-type real)))
(cond ((member dir '(nil :up))
(when (or limit-given default-top)
(unless limit-given
(setq step-hack
`(,variable ,step-hack)))
(let ((first-test test) (remaining-tests test))
- (when (and stepby-constantp start-constantp limit-constantp)
+ (when (and stepby-constantp start-constantp limit-constantp
+ (realp start-value) (realp limit-value))
(when (setq first-test
(funcall (symbol-function testfn)
start-value
(defun loop-for-arithmetic (var val data-type kwd)
(loop-sequencer
- var (loop-check-data-type data-type 'real)
+ var (loop-check-data-type data-type 'number)
nil nil nil nil nil nil
(loop-collect-prepositional-phrases
'((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
# returned unless we exit through the intended explicit "test
# successful" path.
tenfour () {
- if [ $? = 104 ]; then
+ if [ $1 = 104 ]; then
echo ok
else
- echo test failed, expected 104 return code, got $?
+ echo test failed, expected 104 return code, got $1
exit 1
fi
}
fi
done
echo " (sb-ext:quit :unix-status 104)) ; Return status=success."
-) | $SBCL ; tenfour
+) | $SBCL ; tenfour $?
# *.impure.lisp files are Lisp code with side effects (e.g. doing
# DEFSTRUCT or DEFTYPE or DEFVAR, or messing with the read table).
for f in *.impure.lisp; do
if [ -f $f ]; then
echo //running $f test
- echo "(load \"$f\")" | $SBCL ; tenfour
+ echo "(load \"$f\")" | $SBCL ; tenfour $?
fi
done
for f in *.test.sh; do
if [ -f $f ]; then
echo //running $f test
- sh $f "$SBCL"; tenfour
+ sh $f "$SBCL"; tenfour $?
fi
done
for f in *.assertoids; do
if [ -f $f ]; then
echo //running $f test
- echo "(load \"$f\")" | $SBCL --eval '(load "assertoid.lisp")' ; tenfour
+ echo "(load \"$f\")" | $SBCL --eval '(load "assertoid.lisp")' ; tenfour $?
fi
done
# to LOAD them all into the same Lisp.)
if [ -f $f ]; then
echo //running $f test
- $SBCL <<EOF ; tenfour
+ $SBCL <<EOF ; tenfour $?
(compile-file "$f")
(progn
(unwind-protect
for f in *.impure-cload.lisp; do
if [ -f $f ]; then
echo //running $f test
- $SBCL <<EOF ; tenfour
+ $SBCL <<EOF ; tenfour $?
(compile-file "$f")
(progn
(unwind-protect
projects / sbcl.git / commitdiff