;;;;
;;;; KLUDGE: In SBCL, we only really use variant (1), and any generality
;;;; for the other variants is wasted. -- WHN 20000121
-
-;;;; FIXME: the STEP-FUNCTION stuff in the code seems to've been
-;;;; intended to support code which was conditionalized with
-;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been
-;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too.
\f
;;;; list collection macrology
(sb!int:defmacro-mundanely loop-collect-rplacd
(&environment env (head-var tail-var &optional user-head-var) form)
- (setq form (sb!xc:macroexpand form env))
+ (setq form (sb!int:%macroexpand form env))
(flet ((cdr-wrap (form n)
(declare (fixnum n))
(do () ((<= n 4) (setq form `(,(case n
path-keywords ; hash table, value = (fn-name . extra-data)
type-symbols ; hash table of type SYMBOLS, test EQ,
; value = CL type specifier
- type-keywords ; hash table of type STRINGS, test EQUAL,
+ type-keywords) ; hash table of type STRINGS, test EQUAL,
; value = CL type spec
- ansi ; NIL, T, or :EXTENDED
- implicit-for-required) ; see loop-hack-iteration
(sb!int:def!method print-object ((u loop-universe) stream)
- (let ((string (case (loop-universe-ansi u)
- ((nil) "non-ANSI")
- ((t) "ANSI")
- (:extended "extended-ANSI")
- (t (loop-universe-ansi u)))))
- (print-unreadable-object (u stream :type t)
- (write-string string stream))))
+ (print-unreadable-object (u stream :type t :identity t)))
;;; This is the "current" loop context in use when we are expanding a
;;; loop. It gets bound on each invocation of LOOP.
(defun make-standard-loop-universe (&key keywords for-keywords
iteration-keywords path-keywords
- type-keywords type-symbols ansi)
- (declare (type (member nil t :extended) ansi))
+ type-keywords type-symbols)
(flet ((maketable (entries)
(let* ((size (length entries))
(ht (make-hash-table :size (if (< size 10) 10 size)
:for-keywords (maketable for-keywords)
:iteration-keywords (maketable iteration-keywords)
:path-keywords (maketable path-keywords)
- :ansi ansi
- :implicit-for-required (not (null ansi))
:type-keywords (maketable type-keywords)
:type-symbols (let* ((size (length type-symbols))
(ht (make-hash-table :size (if (< size 10) 10 size)
(and (consp x)
(or (not (eq (car x) 'car))
(not (symbolp (cadr x)))
- (not (symbolp (setq x (sb!xc:macroexpand x env)))))
+ (not (symbolp (setq x (sb!int:%macroexpand x env)))))
(cons x nil)))
(cdr val))
`(,val))))
;;@@@@ ???? (declare (function list-size (list) fixnum))
(cond ((constantp x) 1)
((symbolp x) (multiple-value-bind (new-form expanded-p)
- (sb!xc:macroexpand-1 x env)
+ (sb!int:%macroexpand-1 x env)
(if expanded-p
(estimate-code-size-1 new-form env)
1)))
(member fn *estimate-code-size-punt*))
(throw 'estimate-code-size nil))
(t (multiple-value-bind (new-form expanded-p)
- (sb!xc:macroexpand-1 x env)
+ (sb!int:%macroexpand-1 x env)
(if expanded-p
(estimate-code-size-1 new-form env)
(f 3))))))))
;;;; loop types
(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))))
+ (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:type-*-to-t
+ (sb!kernel:array-type-specialized-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.
(cond ((null name)
(setq name (gensym "LOOP-IGNORE-"))
(push (list name initialization) *loop-vars*)
- (if (null initialization)
- (push `(ignore ,name) *loop-declarations*)
- (loop-declare-var name dtype)))
+ (push `(ignore ,name) *loop-declarations*)
+ (loop-declare-var name dtype))
((atom name)
(when (or (assoc name *loop-vars*)
(loop-var-p name))
(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)))
(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 (sb!xc:subtypep t dtype)
- (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
- (if (sb!xc:typep init dtype)
- dtype
- `(or (member ,init) ,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 (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)
(defun loop-get-collection-info (collector class default-type)
(let ((form (loop-get-form))
- (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
(name (when (loop-tequal (car *loop-source-code*) 'into)
(loop-pop-source)
(loop-pop-source))))
(loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
(unless name
(loop-disallow-aggregate-booleans))
- (unless dtype
- (setq dtype (or (loop-optional-type) default-type)))
- (let ((cruft (find (the symbol name) *loop-collection-cruft*
+ (let ((dtype (or (loop-optional-type) default-type))
+ (cruft (find (the symbol name) *loop-collection-cruft*
:key #'loop-collector-name)))
(cond ((not cruft)
(when (and name (loop-var-p name))
*loop-after-body*))
(loop-bind-block)
(return nil))
- (loop-pop-source) ; Flush the "AND".
- (when (and (not (loop-universe-implicit-for-required *loop-universe*))
- (setq tem
- (loop-lookup-keyword
- (car *loop-source-code*)
- (loop-universe-iteration-keywords *loop-universe*))))
- ;; The latest ANSI clarification is that the FOR/AS after the AND must
- ;; NOT be supplied.
- (loop-pop-source)
- (setq entry tem)))))
+ (loop-pop-source)))) ; Flush the "AND".
\f
;;;; main iteration drivers
`(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
\f
;;;; ANSI LOOP
-(defun make-ansi-loop-universe (extended-p)
+(defun make-ansi-loop-universe ()
(let ((w (make-standard-loop-universe
:keywords '((named (loop-do-named))
(initially (loop-do-initially))
simple-bit-vector simple-string simple-vector
single-float standard-char stream string
base-char symbol t vector)
- :type-keywords nil
- :ansi (if extended-p :extended t))))
+ :type-keywords nil)))
(add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
w))
(defparameter *loop-ansi-universe*
- (make-ansi-loop-universe nil))
+ (make-ansi-loop-universe))
(defun loop-standard-expansion (keywords-and-forms environment universe)
(if (and keywords-and-forms (symbolp (car keywords-and-forms)))
projects / sbcl.git / blobdiff