\f
;;;; various sequencing constructs
-(defmacro-mundanely prog (varlist &body body-decls)
- (multiple-value-bind (body decls) (parse-body body-decls nil)
- `(block nil
- (let ,varlist
- ,@decls
- (tagbody ,@body)))))
-
-(defmacro-mundanely prog* (varlist &body body-decls)
- (multiple-value-bind (body decls) (parse-body body-decls nil)
- `(block nil
- (let* ,varlist
- ,@decls
- (tagbody ,@body)))))
+(flet ((prog-expansion-from-let (varlist body-decls let)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
+ `(block nil
+ (,let ,varlist
+ ,@decls
+ (tagbody ,@body))))))
+ (defmacro-mundanely prog (varlist &body body-decls)
+ (prog-expansion-from-let varlist body-decls 'let))
+ (defmacro-mundanely prog* (varlist &body body-decls)
+ (prog-expansion-from-let varlist body-decls 'let*)))
(defmacro-mundanely prog1 (result &body body)
(let ((n-result (gensym)))
(or (sb!c:maybe-inline-syntactic-closure lambda env)
(progn
(#+sb-xc-host warn
- #-sb-xc-host sb!c:maybe-compiler-note
+ #-sb-xc-host sb!c:maybe-compiler-notify
"lexical environment too hairy, can't inline DEFUN ~S"
name)
nil)))))
(defmacro-mundanely dotimes ((var count &optional (result nil)) &body body)
(cond ((numberp count)
`(do ((,var 0 (1+ ,var)))
- ((>= ,var ,count) ,result)
- (declare (type unsigned-byte ,var))
- ,@body))
+ ((>= ,var ,count) ,result)
+ (declare (type unsigned-byte ,var))
+ ,@body))
(t (let ((v1 (gensym)))
`(do ((,var 0 (1+ ,var)) (,v1 ,count))
- ((>= ,var ,v1) ,result)
- (declare (type unsigned-byte ,var))
- ,@body)))))
+ ((>= ,var ,v1) ,result)
+ (declare (type unsigned-byte ,var))
+ ,@body)))))
(defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
;; We repeatedly bind the var instead of setting it so that we never
;; environment. We spuriously reference the gratuitous variable,
;; since we don't want to use IGNORABLE on what might be a special
;; var.
- (multiple-value-bind (forms decls) (parse-body body nil)
- (let ((n-list (gensym)))
- `(do* ((,n-list ,list (cdr ,n-list)))
- ((endp ,n-list)
- ,@(if result
- `((let ((,var nil))
- ,var
- ,result))
- '(nil)))
- (let ((,var (car ,n-list)))
- ,@decls
- (tagbody
- ,@forms))))))
+ (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))
+ ,var
+ ,result)
+ nil)))))
\f
;;;; conditions, handlers, restarts
,n-cond
(car *restart-clusters*)
,(if (eq name 'cerror)
- `(cerror ,(second expression) ,n-cond)
+ `(cerror ,(second exp) ,n-cond)
`(,name ,n-cond))))
expression))
expression)))
`(let ((,(caaddr annotated-case)
,var))
,@body))
- ((not (cdr body))
- (car body))
(t
- `(progn ,@body)))))))
+ `(locally ,@body)))))))
annotated-cases))))))))
\f
;;;; miscellaneous