X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=3ac743c44c67d6dae80a12c564ae52d266c138e3;hb=4cf50b1896b25f5337e7c258b0b560da00d47993;hp=b1ef79ac88d87fa9d748138aea8b0a5d3bbeed29;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index b1ef79a..3ac743c 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 @@ -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) @@ -343,21 +341,21 @@ code to be loaded. (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 +367,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) @@ -913,16 +911,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) - ;; It's a "miscellaneous" toplevel LOOP keyword (do, - ;; collect, named, etc.) + ;; It's a "miscellaneous" toplevel LOOP keyword (DO, + ;; COLLECT, NAMED, etc.) (apply (symbol-function (first tem)) (rest tem))) ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) (loop-hack-iteration tem)) ((loop-tmember keyword '(and else)) - ;; Alternative is to ignore it, ie let it go around to - ;; the next keyword... + ;; The alternative is to ignore it, i.e. let it go + ;; around to the next keyword... (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." keyword (car *loop-source-code*) @@ -1198,8 +1196,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; value accumulation: LIST (defstruct (loop-collector - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) name class (history nil) @@ -1307,9 +1305,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ,specifically ,form))))) -;;;; value accumulation: aggregate booleans +;;;; value accumulation: aggregate booleans -;;; ALWAYS and NEVER +;;; handling the ALWAYS and NEVER loop keywords ;;; ;;; Under ANSI these are not permitted to appear under conditionalization. (defun loop-do-always (restrictive negate) @@ -1319,7 +1317,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ,(loop-construct-return nil))) (loop-emit-final-value t))) -;;; THEREIS +;;; handling the THEREIS loop keyword ;;; ;;; Under ANSI this is not permitted to appear under conditionalization. (defun loop-do-thereis (restrictive) @@ -1579,8 +1577,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; iteration paths (defstruct (loop-path - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) names preposition-groups inclusive-permitted @@ -1589,8 +1587,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 +1867,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 +1999,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