X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=bc4202af5e9e842fd6067ba7bbaae4cda776d24a;hb=3bd7a97d1b11a2b0aee086ef211cae807f3dfc35;hp=b1ef79ac88d87fa9d748138aea8b0a5d3bbeed29;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index b1ef79a..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 @@ -913,16 +909,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 +1194,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 +1303,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 +1315,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 +1575,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 +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."