0.6.12.49:

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

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index affebfb..bc4202a 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -6,12 +6,13 @@
 ;;;; This code was modified by William Harold Newman beginning
 ;;;; 19981106, originally to conform to the new SBCL bootstrap package
 ;;;; system and then subsequently to address other cross-compiling
 ;;;; This code was modified by William Harold Newman beginning
 ;;;; 19981106, originally to conform to the new SBCL bootstrap package
 ;;;; system and then subsequently to address other cross-compiling

-;;;; bootstrap issues. Whether or not it then supported all the
-;;;; environments implied by the reader conditionals in the source
-;;;; code (e.g. #!+CLOE-RUNTIME) before that modification, it sure
-;;;; doesn't now: it might be appropriate for CMU-CL-derived systems
-;;;; in general but only claims to be appropriate for the particular
-;;;; branch I was working on.
+;;;; bootstrap issues, SBCLification (e.g. DECLARE used to check
+;;;; argument types), and other maintenance. Whether or not it then
+;;;; supported all the environments implied by the reader conditionals
+;;;; in the source code (e.g. #!+CLOE-RUNTIME) before that
+;;;; modification, it sure doesn't now. It might perhaps, by blind
+;;;; luck, be appropriate for some other CMU-CL-derived system, but
+;;;; really it only attempts to be appropriate for SBCL.

 
 ;;;; This software is derived from software originally released by the
 ;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and
 
 ;;;; This software is derived from software originally released by the
 ;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and

@@ -155,13 +156,13 @@
 \f
 ;;;; list collection macrology
 
 \f
 ;;;; list collection macrology
 

-(sb!kernel:defmacro-mundanely with-loop-list-collection-head
+(sb!int:defmacro-mundanely with-loop-list-collection-head

     ((head-var tail-var &optional user-head-var) &body body)
   (let ((l (and user-head-var (list (list user-head-var nil)))))
     `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
        ,@body)))
 
     ((head-var tail-var &optional user-head-var) &body body)
   (let ((l (and user-head-var (list (list user-head-var nil)))))
     `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
        ,@body)))
 

-(sb!kernel:defmacro-mundanely loop-collect-rplacd
+(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))
   (flet ((cdr-wrap (form n)
     (&environment env (head-var tail-var &optional user-head-var) form)
   (setq form (sb!xc:macroexpand form env))
   (flet ((cdr-wrap (form n)

@@ -207,7 +208,7 @@
                        (setq ,user-head-var (cdr ,head-var)))))
        answer))))
 
                        (setq ,user-head-var (cdr ,head-var)))))
        answer))))
 

-(sb!kernel:defmacro-mundanely loop-collect-answer (head-var
+(sb!int:defmacro-mundanely loop-collect-answer (head-var

                                                   &optional user-head-var)
   (or user-head-var
       `(cdr ,head-var)))
                                                   &optional user-head-var)
   (or user-head-var
       `(cdr ,head-var)))

@@ -240,11 +241,8 @@ constructed.
   infinity-data)
 
 (defvar *loop-minimax-type-infinities-alist*
   infinity-data)
 
 (defvar *loop-minimax-type-infinities-alist*

-  ;; Note: In the portable loop.lisp, this had various
-  ;; conditional-on-*FEATURES* cases to support machines which had true
-  ;; floating infinity. Now that we're limited to CMU CL, this is irrelevant.
-  ;; FIXME: Or is it? What if we ever support infinity? Perhaps we should
-  ;; put in something conditional on SB-INFINITY or something?
+  ;; FIXME: Now that SBCL supports floating point infinities again, we
+  ;; should have floating point infinities here, as cmucl-2.4.8 did.

   '((fixnum most-positive-fixnum most-negative-fixnum)))
 
 (defun make-loop-minimax (answer-variable type)
   '((fixnum most-positive-fixnum most-negative-fixnum)))
 
 (defun make-loop-minimax (answer-variable type)

@@ -268,7 +266,7 @@ constructed.
          (loop-gentemp 'loop-maxmin-flag-)))
   operation)
 
          (loop-gentemp 'loop-maxmin-flag-)))
   operation)
 

-(sb!kernel:defmacro-mundanely with-minimax-value (lm &body body)
+(sb!int:defmacro-mundanely with-minimax-value (lm &body body)

   (let ((init (loop-typed-init (loop-minimax-type lm)))
        (which (car (loop-minimax-operations lm)))
        (infinity-data (loop-minimax-infinity-data lm))
   (let ((init (loop-typed-init (loop-minimax-type lm)))
        (which (car (loop-minimax-operations lm)))
        (infinity-data (loop-minimax-infinity-data lm))

@@ -287,9 +285,7 @@ constructed.
           (declare (type ,type ,answer-var ,temp-var))
           ,@body))))
 
           (declare (type ,type ,answer-var ,temp-var))
           ,@body))))
 

-(sb!kernel:defmacro-mundanely loop-accumulate-minimax-value (lm
-                                                            operation
-                                                            form)
+(sb!int:defmacro-mundanely loop-accumulate-minimax-value (lm operation form)

   (let* ((answer-var (loop-minimax-answer-variable lm))
         (temp-var (loop-minimax-temp-variable lm))
         (flag-var (loop-minimax-flag-variable lm))
   (let* ((answer-var (loop-minimax-answer-variable lm))
         (temp-var (loop-minimax-temp-variable lm))
         (flag-var (loop-minimax-flag-variable lm))

@@ -337,27 +333,27 @@ code to be loaded.
   (and (symbolp loop-token)
        (values (gethash (symbol-name loop-token) table))))
 
   (and (symbolp loop-token)
        (values (gethash (symbol-name loop-token) table))))
 

-(sb!kernel:defmacro-mundanely loop-store-table-data (symbol table datum)
+(sb!int:defmacro-mundanely loop-store-table-data (symbol table datum)

   `(setf (gethash (symbol-name ,symbol) ,table) ,datum))
 
 (defstruct (loop-universe
             (:copier nil)
             (:predicate nil))
   `(setf (gethash (symbol-name ,symbol) ,table) ,datum))
 
 (defstruct (loop-universe
             (:copier nil)
             (:predicate nil))

-  keywords            ; hash table, value = (fn-name . extra-data)
-  iteration-keywords     ; hash table, value = (fn-name . extra-data)
-  for-keywords    ; hash table, value = (fn-name . extra-data)
-  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,
-                        ; value = CL type spec
-  ansi            ; NIL, T, or :EXTENDED
+  keywords             ; hash table, value = (fn-name . extra-data)
+  iteration-keywords   ; hash table, value = (fn-name . extra-data)
+  for-keywords         ; hash table, value = (fn-name . extra-data)
+  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,
+                       ; 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)
   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")
+                 ((nil) "non-ANSI")

                  ((t) "ANSI")
                  ((t) "ANSI")

-                 (:extended "Extended-ANSI")
+                 (:extended "extended-ANSI")

                  (t (loop-universe-ansi u)))))
     (print-unreadable-object (u stream :type t)
       (write-string string stream))))
                  (t (loop-universe-ansi u)))))
     (print-unreadable-object (u stream :type t)
       (write-string string stream))))

@@ -369,7 +365,7 @@ code to be loaded.
 (defun make-standard-loop-universe (&key keywords for-keywords
                                         iteration-keywords path-keywords
                                         type-keywords type-symbols ansi)
 (defun make-standard-loop-universe (&key keywords for-keywords
                                         iteration-keywords path-keywords
                                         type-keywords type-symbols ansi)

-  (check-type ansi (member nil t :extended))
+  (declare (type (member nil t :extended) ansi))

   (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)

@@ -421,7 +417,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 (defvar *loop-desetq-temporary*
        (make-symbol "LOOP-DESETQ-TEMP"))
 
 (defvar *loop-desetq-temporary*
        (make-symbol "LOOP-DESETQ-TEMP"))
 

-(sb!kernel:defmacro-mundanely loop-really-desetq (&environment env
+(sb!int:defmacro-mundanely loop-really-desetq (&environment env

                                                  &rest var-val-pairs)
   (labels ((find-non-null (var)
             ;; see whether there's any non-null thing here
                                                  &rest var-val-pairs)
   (labels ((find-non-null (var)
             ;; see whether there's any non-null thing here

@@ -620,7 +616,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
        (space 1))
     (+ 40 (* (- speed space) 10))))
 
        (space 1))
     (+ 40 (* (- speed space) 10))))
 

-(sb!kernel:defmacro-mundanely loop-body (&environment env
+(sb!int:defmacro-mundanely loop-body (&environment env

                                         prologue
                                         before-loop
                                         main-body
                                         prologue
                                         before-loop
                                         main-body

@@ -1589,8 +1585,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 
 (defun add-loop-path (names function universe
                      &key preposition-groups inclusive-permitted user-data)
 
 (defun add-loop-path (names function universe
                      &key preposition-groups inclusive-permitted user-data)

-  (unless (listp names) (setq names (list names)))
-  (check-type universe loop-universe)
+  (declare (type loop-universe universe))
+  (unless (listp names)
+    (setq names (list names)))

   (let ((ht (loop-universe-path-keywords universe))
        (lp (make-loop-path
              :names (mapcar #'symbol-name names)
   (let ((ht (loop-universe-path-keywords universe))
        (lp (make-loop-path
              :names (mapcar #'symbol-name names)

@@ -1868,10 +1865,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 ||#
 
 (defun loop-hash-table-iteration-path (variable data-type prep-phrases
 ||#
 
 (defun loop-hash-table-iteration-path (variable data-type prep-phrases

-                                      &key which)
-  (check-type which (member hash-key hash-value))
+                                      &key (which (required-argument)))
+  (declare (type (member :hash-key :hash-value) which))

   (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
   (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))

-        (loop-error "Too many prepositions!"))
+        (loop-error "too many prepositions!"))

        ((null prep-phrases)
         (loop-error "missing OF or IN in ~S iteration path")))
   (let ((ht-var (loop-gentemp 'loop-hashtab-))
        ((null prep-phrases)
         (loop-error "missing OF or IN in ~S iteration path")))
   (let ((ht-var (loop-gentemp 'loop-hashtab-))

@@ -2000,11 +1997,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
     (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

-                  :user-data '(:which hash-key))
+                  :user-data '(:which :hash-key))

     (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
                   :preposition-groups '((:of :in))
                   :inclusive-permitted nil
     (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
                   :preposition-groups '((:of :in))
                   :inclusive-permitted nil

-                  :user-data '(:which hash-value))
+                  :user-data '(:which :hash-value))

     (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
                   :preposition-groups '((:of :in))
                   :inclusive-permitted nil
     (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
                   :preposition-groups '((:of :in))
                   :inclusive-permitted nil

@@ -2032,12 +2029,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
     (let ((tag (gensym)))
       `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
 
     (let ((tag (gensym)))
       `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
 

-(sb!kernel:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
+(sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms)

   (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
 
   (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
 

-(sb!kernel:defmacro-mundanely loop-finish ()
+(sb!int:defmacro-mundanely loop-finish ()

   #!+sb-doc
   #!+sb-doc

-  "Causes the iteration to terminate \"normally\", the same as implicit
+  "Cause the iteration to terminate \"normally\", the same as implicit

 termination by an iteration driving clause, or by use of WHILE or
 UNTIL -- the epilogue code (if any) will be run, and any implicitly
 collected result will be returned as the value of the LOOP."
 termination by an iteration driving clause, or by use of WHILE or
 UNTIL -- the epilogue code (if any) will be run, and any implicitly
 collected result will be returned as the value of the LOOP."