;;;; 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
\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)))
-(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)
(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)))
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)
(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))
(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))
(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))))
(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)
(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
(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
;;;; value accumulation: LIST
(defstruct (loop-collector
- (:copier nil)
- (:predicate nil))
+ (:copier nil)
+ (:predicate nil))
name
class
(history nil)
,specifically
,form)))))
\f
-;;;; 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)
,(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)
;;;; iteration paths
(defstruct (loop-path
- (:copier nil)
- (:predicate nil))
+ (:copier nil)
+ (:predicate nil))
names
preposition-groups
inclusive-permitted
(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)
||#
(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-))
(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
(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."
projects / sbcl.git / blobdiff