X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Floop.lisp;h=bc4202af5e9e842fd6067ba7bbaae4cda776d24a;hb=3bd7a97d1b11a2b0aee086ef211cae807f3dfc35;hp=affebfb46dabe5b3984b1d63ede31b878aa1aff6;hpb=cbaa1997bb097a55d108df592ac3b7eb4a703fff;p=sbcl.git

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index affebfb..bc4202a 100644
--- 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
-;;;; 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
@@ -155,13 +156,13 @@
 
 ;;;; 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)))
 
-(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)
@@ -207,7 +208,7 @@
 			(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)))
@@ -240,11 +241,8 @@ constructed.
   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)
@@ -268,7 +266,7 @@ constructed.
 	  (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))
@@ -287,9 +285,7 @@ constructed.
 	   (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))
@@ -337,27 +333,27 @@ code to be loaded.
   (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))
-  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)
-		  ((nil) "Non-ANSI")
+		  ((nil) "non-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))))
@@ -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)
-  (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)
@@ -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"))
 
-(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
@@ -620,7 +616,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
 	(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
@@ -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)
-  (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)
@@ -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
-				       &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))))
-	 (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-))
@@ -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
-		   :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
-		   :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
@@ -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))))))
 
-(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*))
 
-(sb!kernel:defmacro-mundanely loop-finish ()
+(sb!int:defmacro-mundanely loop-finish ()
   #!+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."