;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
;;; is the pointer to the current tail of the list, or NIL if the list
;;; is empty.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun collect-normal-expander (n-value fun forms)
`(progn
,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
;;; Is NAME a legal function name?
(defun legal-fun-name-p (name)
- (or (symbolp name)
- (and (consp name)
- ;; (SETF FOO)
- ;; (CLASS-PREDICATE FOO)
- (or (and (or (eq (car name) 'setf)
- (eq (car name) 'sb!pcl::class-predicate))
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))
- ;; (SLOT-ACCESSOR <CLASSNAME-OR-:GLOBAL>
- ;; <SLOT-NAME> [READER|WRITER|BOUNDP])
- (and (eq (car name) 'sb!pcl::slot-accessor)
- (consp (cdr name))
- (symbolp (cadr name))
- (consp (cddr name))
- (symbolp (caddr name))
- (consp (cdddr name))
- (member
- (cadddr name)
- '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp)))))))
+ (values (valid-function-name-p name)))
;;; Signal an error unless NAME is a legal function name.
(defun legal-fun-name-or-type-error (name)
(defun fun-name-block-name (fun-name)
(cond ((symbolp fun-name)
fun-name)
- ((and (consp fun-name)
- (legal-fun-name-p fun-name))
- (case (car fun-name)
- ((setf sb!pcl::class-predicate) (second fun-name))
- ((sb!pcl::slot-accessor) (third fun-name))))
+ ((consp fun-name)
+ (multiple-value-bind (legalp block-name)
+ (valid-function-name-p fun-name)
+ (if legalp
+ block-name
+ (error "not legal as a function name: ~S" fun-name))))
(t
(error "not legal as a function name: ~S" fun-name))))
:format-string "~@<~S ~_is not a ~_~S~:>"
:format-arguments (list value type)))
\f
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
-
;;; Return a function like FUN, but expecting its (two) arguments in
;;; the opposite order that FUN does.
(declaim (inline swapped-args-fun))