X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=726abee371efa80c84cf163e04b54fd368b8e3be;hb=f46b52e0ab5b5a8cdfd0ddabed9ff37a9876506e;hp=101a8df8978d9bd1f5cefb10c8f9ab37ad2bc401;hpb=5369caf4d418065012b96af0d29c74d7851c04ff;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 101a8df..726abee 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -87,11 +87,6 @@ ;;;; ;;;; 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. ;;;; list collection macrology @@ -103,7 +98,7 @@ (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 @@ -281,18 +276,10 @@ code to be loaded. 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. @@ -300,8 +287,7 @@ code to be loaded. (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) @@ -314,8 +300,6 @@ code to be loaded. :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) @@ -365,7 +349,7 @@ code to be loaded. (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)))) @@ -503,27 +487,21 @@ code to be loaded. ;;;; 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 "~@" - 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))) ;;;; 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)) @@ -679,7 +657,7 @@ code to be loaded. ;;@@@@ ???? (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))) @@ -725,7 +703,7 @@ code to be loaded. (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)))))))) @@ -922,11 +900,35 @@ 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)) - (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)))))) + ((sb!xc:typep #\x data-type) + #\x) + (t + nil))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. @@ -1021,16 +1023,15 @@ code to be loaded. (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))) @@ -1049,14 +1050,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 (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) @@ -1067,7 +1072,7 @@ code to be loaded. (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))) @@ -1158,7 +1163,6 @@ code to be loaded. (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)))) @@ -1166,9 +1170,8 @@ code to be loaded. (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)) @@ -1374,16 +1377,7 @@ code to be loaded. *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". ;;;; main iteration drivers @@ -1726,7 +1720,8 @@ code to be loaded. `(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 @@ -1737,7 +1732,8 @@ code to be loaded. 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")) @@ -1755,8 +1751,9 @@ code to be loaded. :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 @@ -1923,7 +1920,7 @@ code to be loaded. ;;;; 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)) @@ -1984,8 +1981,7 @@ code to be loaded. 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 @@ -2014,7 +2010,7 @@ code to be loaded. 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)))