(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))
,n-result
(cond ,@more))))
(if (eq t test)
- `(progn ,@forms)
+ ;; THE to perserve non-toplevelness for FOO in
+ ;; (COND (T (FOO)))
+ `(the t (progn ,@forms))
`(if ,test
(progn ,@forms)
,(when more `(cond ,@more))))))))))
(defmacro-mundanely and (&rest forms)
(cond ((endp forms) t)
- ((endp (rest forms)) (first forms))
+ ((endp (rest forms))
+ ;; Preserve non-toplevelness of the form!
+ `(the t ,(first forms)))
(t
`(if ,(first forms)
(and ,@(rest forms))
(defmacro-mundanely or (&rest forms)
(cond ((endp forms) nil)
- ((endp (rest forms)) (first forms))
+ ((endp (rest forms))
+ ;; Preserve non-toplevelness of the form!
+ `(the t ,(first forms)))
(t
(let ((n-result (gensym)))
`(let ((,n-result ,(first forms)))
(defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
#!+sb-doc
- "Define a global variable at top level. Declare the variable
+ "Define a special variable at top level. Declare the variable
SPECIAL and, optionally, initialize it. If the variable already has a
value, the old value is not clobbered. The third argument is an optional
documentation string for the variable."
(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)
(and (consp x)
(eq 'lambda (car x))
(setf lambda-form x))))))
- (let ((name (gensym "LAMBDA")))
+ (let ((name (sb!xc:gensym "LAMBDA")))
(push `(,name ,@(cdr lambda-form)) local-funs)
(list type `(function ,name)))
binding))))
(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