From 27af0fb82b513ad08f16ce72f6f5a001835e3519 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 15 Sep 2009 21:40:05 +0000 Subject: [PATCH] 1.0.31.11: better handling of vector types in LOOP This is really 1.0.26.12 in a fixed form. * LOOP-DECLARE-VAR calls LOOP-TYPED-INIT iff there is no explicit initialization form, and when it does call it, the type is constructed from the result using TYPE-OF. * LOOP-TYPED-INIT knows how to construct zero-length vectors for all reasonable vector types (ones expressible with an ARRAY-TYPE.) * LOOP-MAKE-VAR informs LOOP-DECLARE-VAR about user-provided initialization. --- src/code/loop.lisp | 57 +++++++++++++++++++++++++++++++--------------------- version.lisp-expr | 2 +- 2 files changed, 35 insertions(+), 24 deletions(-) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 6b9a43a..e2df9b8 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -916,23 +916,32 @@ code to be loaded. ;;;; loop types (defun loop-typed-init (data-type &optional step-var-p) - (when (and data-type (sb!xc:subtypep data-type 'number)) - (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)))))) + (cond ((null data-type) + nil) + ((sb!xc:subtypep data-type 'number) + (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))))) + ((sb!xc:subtypep data-type 'vector) + (let ((ctype (sb!kernel:specifier-type data-type))) + (when (sb!kernel:array-type-p ctype) + (let ((etype (sb!kernel:array-type-element-type ctype))) + (make-array 0 :element-type (sb!kernel:type-specifier etype)))))) + (t + nil))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. @@ -1036,7 +1045,7 @@ code to be loaded. (loop-error "duplicated variable ~S in a LOOP binding" name)) (unless (symbolp name) (loop-error "bad variable ~S somewhere in LOOP" name)) - (loop-declare-var name dtype step-var-p) + (loop-declare-var name dtype step-var-p initialization) ;; We use ASSOC on this list to check for duplications (above), ;; so don't optimize out this list: (push (list name (or initialization (loop-typed-init dtype step-var-p))) @@ -1055,16 +1064,18 @@ code to be loaded. (loop-make-var (cdr name) nil tcdr)))) name) -(defun loop-declare-var (name dtype &optional step-var-p) +(defun loop-declare-var (name dtype &optional step-var-p initialization) (cond ((or (null name) (null dtype) (eq dtype t)) nil) ((symbolp name) (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 - `(or (member ,init) ,dtype))))) + (let ((dtype (if initialization + dtype + (let ((init (loop-typed-init dtype step-var-p))) + (if (sb!xc:typep init dtype) + dtype + `(or ,(type-of init) ,dtype)))))) (push `(type ,dtype ,name) *loop-declarations*)))) ((consp name) (cond ((consp dtype) diff --git a/version.lisp-expr b/version.lisp-expr index a6e43bc..10f5633 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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".) -"1.0.31.10" +"1.0.31.11" -- 1.7.10.4