(if (= (length vars) 1)
`(let ((,(car vars) ,value-form))
,@body)
- (let ((ignore (gensym)))
+ (let ((ignore (sb!xc:gensym)))
`(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)
&rest ,ignore)
(declare (ignore ,ignore))
#-sb-xc-host
(defun %defun (name def doc inline-lambda source-location)
- (declare (ignore source-location))
(declare (type function def))
(declare (type (or null simple-string) doc))
(aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN
(sb!c:%compiler-defun name inline-lambda nil)
(when (fboundp name)
(/show0 "redefining NAME in %DEFUN")
- (style-warn "redefining ~S in DEFUN" name))
+ (style-warn 'sb!kernel::redefinition-with-defun :name name
+ :old (fdefinition name) :new def
+ :new-location source-location))
(setf (sb!xc:fdefinition name) def)
(sb!c::note-name-defined name :function)
(type integer ,c))
,@body)))))
-(defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
+(defmacro-mundanely dolist ((var list &optional (result nil)) &body body &environment env)
;; We repeatedly bind the var instead of setting it so that we never
;; have to give the var an arbitrary value such as NIL (which might
;; conflict with a declaration). If there is a result form, we
;; since we don't want to use IGNORABLE on what might be a special
;; var.
(multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
- (let ((n-list (gensym "N-LIST"))
- (start (gensym "START")))
- `(block nil
- (let ((,n-list ,list))
- (tagbody
- ,start
- (unless (endp ,n-list)
- (let ((,var (car ,n-list)))
- ,@decls
- (setq ,n-list (cdr ,n-list))
- (tagbody ,@forms))
- (go ,start))))
- ,(if result
- `(let ((,var nil))
- ;; Filter out TYPE declarations (VAR gets bound to NIL,
- ;; and might have a conflicting type declaration) and
- ;; IGNORE (VAR might be ignored in the loop body, but
- ;; it's used in the result form).
- ,@(filter-dolist-declarations decls)
- ,var
- ,result)
- nil)))))
+ (let* ((n-list (gensym "N-LIST"))
+ (start (gensym "START"))
+ (tmp (gensym "TMP")))
+ (multiple-value-bind (clist members clist-ok)
+ (cond ((sb!xc:constantp list env)
+ (let ((value (constant-form-value list env)))
+ (multiple-value-bind (all dot) (list-members value)
+ (when dot
+ ;; Full warning is too much: the user may terminate the loop
+ ;; early enough. Contents are still right, though.
+ (style-warn "Dotted list ~S in DOLIST." value))
+ (values value all t))))
+ ((and (consp list) (eq 'list (car list))
+ (every (lambda (arg) (sb!xc:constantp arg env)) (cdr list)))
+ (let ((values (mapcar (lambda (arg) (constant-form-value arg env)) (cdr list))))
+ (values values values t)))
+ (t
+ (values nil nil nil)))
+ `(block nil
+ (let ((,n-list ,(if clist-ok (list 'quote clist) list)))
+ (tagbody
+ ,start
+ (unless (endp ,n-list)
+ (let* (,@(if clist-ok
+ `((,tmp (truly-the (member ,@members) (car ,n-list)))
+ (,var ,tmp))
+ `((,var (car ,n-list)))))
+ ,@decls
+ (setq ,n-list (cdr ,n-list))
+ (tagbody ,@forms))
+ (go ,start))))
+ ,(if result
+ `(let ((,var nil))
+ ;; Filter out TYPE declarations (VAR gets bound to NIL,
+ ;; and might have a conflicting type declaration) and
+ ;; IGNORE (VAR might be ignored in the loop body, but
+ ;; it's used in the result form).
+ ,@(filter-dolist-declarations decls)
+ ,var
+ ,result)
+ nil))))))
\f
;;;; conditions, handlers, restarts
(k '() (list* (cadr l) (car l) k)))
((or (null l) (not (member (car l) keys)))
(values (nreverse k) l)))))
- (let ((block-tag (gensym))
+ (let ((block-tag (sb!xc:gensym "BLOCK"))
(temp-var (gensym))
(data
(macrolet (;; KLUDGE: This started as an old DEFMACRO
&rest forms)
(cddr clause))
(list (car clause) ;name=0
- (gensym) ;tag=1
+ (sb!xc:gensym "TAG") ;tag=1
(transform-keywords :report report ;keywords=2
:interactive interactive
:test test)
(let* ((local-funs nil)
(mapped-bindings (mapcar (lambda (binding)
(destructuring-bind (type handler) binding
- (let (lambda-form)
+ (let ((lambda-form handler))
(if (and (consp handler)
- (or (prog1 (eq 'lambda (car handler))
- (setf lambda-form handler))
+ (or (eq 'lambda (car handler))
(and (eq 'function (car handler))
(consp (cdr handler))
- (consp (cadr handler))
- (prog1 (eq 'lambda (caadr handler))
- (setf lambda-form (cadr handler)))))
- ;; KLUDGE: DX-FLET doesn't handle non-required arguments yet.
- (not (intersection (second lambda-form) lambda-list-keywords)))
- (let ((name (gensym "LAMBDA")))
+ (let ((x (second handler)))
+ (and (consp x)
+ (eq 'lambda (car x))
+ (setf lambda-form x))))))
+ (let ((name (sb!xc:gensym "LAMBDA")))
(push `(,name ,@(cdr lambda-form)) local-funs)
(list type `(function ,name)))
binding))))
- bindings))
- (form-fun (gensym "FORM-FUN")))
- `(dx-flet (,@(reverse local-funs)
- (,form-fun () (progn ,form)))
+ bindings)))
+ `(dx-flet (,@(reverse local-funs))
(let ((*handler-clusters*
(cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
mapped-bindings))
*handler-clusters*)))
- (declare (dynamic-extent *handler-clusters*))
- (,form-fun)))))
+ (declare (truly-dynamic-extent *handler-clusters*))
+ (progn ,form)))))
(defmacro-mundanely handler-bind (bindings &body forms)
#!+sb-doc
(handler-case (return-from ,normal-return ,form)
,@(remove no-error-clause cases)))))))
(let* ((local-funs nil)
- (annotated-cases (mapcar (lambda (case)
- (let ((tag (gensym "TAG"))
- (fun (gensym "FUN")))
- (destructuring-bind (type ll &body body) case
- (push `(,fun ,ll ,@body) local-funs)
- (list tag type ll fun))))
- cases)))
+ (annotated-cases
+ (mapcar (lambda (case)
+ (with-unique-names (tag fun)
+ (destructuring-bind (type ll &body body) case
+ (push `(,fun ,ll ,@body) local-funs)
+ (list tag type ll fun))))
+ cases)))
(with-unique-names (block var form-fun)
`(dx-flet ((,form-fun ()
#!-x86 ,form
projects / sbcl.git / blobdiff