1.0.48.28: make TRULY-THE macroexpandable

[sbcl.git] / src / code / loop.lisp

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 9ffa2c0..e4ad5e9 100644 (file)
--- 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
 ;;;;
 ;;;; 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
 
 \f
 ;;;; 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)
 
 (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
   (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
   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
                        ; 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)
 (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.
 
 ;;; 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
 
 (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)
   (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)
       :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)
       :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)))
                                  (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))))
                                       (cons x nil)))
                                (cdr val))
                        `(,val))))

@@ -673,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)
     ;;@@@@ ???? (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)))
                          (if expanded-p
                              (estimate-code-size-1 new-form env)
                              1)))

@@ -719,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)
                           (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))))))))
                           (if expanded-p
                               (estimate-code-size-1 new-form env)
                               (f 3))))))))

@@ -916,11 +900,33 @@ code to be loaded.
 ;;;; loop types
 
 (defun loop-typed-init (data-type &optional step-var-p)
 ;;;; 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.
 
 (defun loop-optional-type (&optional variable)
   ;; No variable specified implies that no destructuring is permissible.

@@ -1015,16 +1021,15 @@ code to be loaded.
   (cond ((null name)
          (setq name (gensym "LOOP-IGNORE-"))
          (push (list name initialization) *loop-vars*)
   (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))
         ((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)))
          ;; 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)))

@@ -1043,14 +1048,18 @@ code to be loaded.
              (loop-make-var (cdr name) nil tcdr))))
   name)
 
              (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)
   (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)
              (push `(type ,dtype ,name) *loop-declarations*))))
         ((consp name)
          (cond ((consp dtype)

@@ -1152,7 +1161,6 @@ code to be loaded.
 
 (defun loop-get-collection-info (collector class default-type)
   (let ((form (loop-get-form))
 
 (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))))
         (name (when (loop-tequal (car *loop-source-code*) 'into)
                 (loop-pop-source)
                 (loop-pop-source))))

@@ -1160,9 +1168,8 @@ code to be loaded.
       (loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
     (unless name
       (loop-disallow-aggregate-booleans))
       (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))
                        :key #'loop-collector-name)))
       (cond ((not cruft)
              (when (and name (loop-var-p name))

@@ -1368,16 +1375,7 @@ code to be loaded.
                      *loop-after-body*))
         (loop-bind-block)
         (return nil))
                      *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
 
 \f
 ;;;; main iteration drivers
 

@@ -1720,7 +1718,8 @@ code to be loaded.
                                  `(and ,indexv-type real)))))
            (:by
             (multiple-value-setq (form stepby-constantp stepby)
                                  `(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
             (unless stepby-constantp
               (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
                  form

@@ -1731,7 +1730,8 @@ code to be loaded.
               maybe invalid prepositions were specified in iteration path descriptor?"
                  prep)))
          (when (and odir dir (not (eq dir odir)))
               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"))
          (setq odir dir))
        (when (and sequence-variable (not sequencep))
          (loop-error "missing OF or IN phrase in sequence path"))

@@ -1749,8 +1749,9 @@ code to be loaded.
                                   :key #'type-declaration-of
                                   :from-end t)))
                  (sb!int:aver (eq decl %decl))
                                   :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
            ;; default start
            ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
            ;; symbol for indexv if it is NIL. See also the comment in

@@ -1917,7 +1918,7 @@ code to be loaded.
 \f
 ;;;; ANSI LOOP
 
 \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))
   (let ((w (make-standard-loop-universe
              :keywords '((named (loop-do-named))
                          (initially (loop-do-initially))

@@ -1978,8 +1979,7 @@ code to be loaded.
                              simple-bit-vector simple-string simple-vector
                              single-float standard-char stream string
                              base-char symbol t vector)
                              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
     (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
                    :preposition-groups '((:of :in))
                    :inclusive-permitted nil

@@ -2008,7 +2008,7 @@ code to be loaded.
     w))
 
 (defparameter *loop-ansi-universe*
     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)))
 
 (defun loop-standard-expansion (keywords-and-forms environment universe)
   (if (and keywords-and-forms (symbolp (car keywords-and-forms)))