`(let ((,(car vars) ,value-form))
,@body)
(let ((ignore (gensym)))
- `(multiple-value-call #'(lambda (&optional ,@vars &rest ,ignore)
+ `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)
+ &rest ,ignore)
(declare (ignore ,ignore))
,@body)
,value-form)))
\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)))
"Define a function at top level."
#+sb-xc-host
(unless (symbol-package (fun-name-block-name name))
- (warn "DEFUN of uninterned symbol ~S (tricky for GENESIS)" name))
+ (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name))
(multiple-value-bind (forms decls doc) (parse-body body)
(let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
(lambda-guts `(,args
(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)))))
`(progn
-
- ;; In cross-compilation of toplevel DEFUNs, we arrange
- ;; for the LAMBDA to be statically linked by GENESIS.
- ;;
- ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
- ;; here instead of LAMBDA. The reason is historical:
- ;; COLD-FSET was written before NAMED-LAMBDA, and has special
- ;; logic of its own to notify the compiler about NAME.
- #+sb-xc-host
+ ;; In cross-compilation of toplevel DEFUNs, we arrange for
+ ;; the LAMBDA to be statically linked by GENESIS.
+ ;;
+ ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
+ ;; here instead of LAMBDA. The reason is historical:
+ ;; COLD-FSET was written before NAMED-LAMBDA, and has special
+ ;; logic of its own to notify the compiler about NAME.
+ #+sb-xc-host
(cold-fset ,name ,lambda)
+
+ (eval-when (:compile-toplevel)
+ (sb!c:%compiler-defun ',name ',inline-lambda t))
+ (eval-when (:load-toplevel :execute)
+ (%defun ',name
+ ;; In normal compilation (not for cold load) this is
+ ;; where the compiled LAMBDA first appears. In
+ ;; cross-compilation, we manipulate the
+ ;; previously-statically-linked LAMBDA here.
+ #-sb-xc-host ,named-lambda
+ #+sb-xc-host (fdefinition ',name)
+ ,doc
+ ',inline-lambda))))))
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c:%compiler-defun ',name ',inline-lambda))
-
- (%defun ',name
- ;; In normal compilation (not for cold load) this is
- ;; where the compiled LAMBDA first appears. In
- ;; cross-compilation, we manipulate the
- ;; previously-statically-linked LAMBDA here.
- #-sb-xc-host ,named-lambda
- #+sb-xc-host (fdefinition ',name)
- ,doc)))))
#-sb-xc-host
-(defun %defun (name def doc)
+(defun %defun (name def doc inline-lambda)
(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))
;; something sane, (1) doing so doesn't really fix the bug, and
;; (2) doing probably isn't even really safe.
#+nil (setf (%fun-name def) name)
-
+
(when doc
(setf (fdocumentation name 'function) doc))
name)
value, the old value is not clobbered. The third argument is an optional
documentation string for the variable."
`(progn
- (declaim (special ,var))
- ,@(when valp
- `((unless (boundp ',var)
- (set ',var ,val))))
- ,@(when docp
- `((setf (fdocumentation ',var 'variable) ',doc )))
- ',var))
+ (eval-when (:compile-toplevel)
+ (%compiler-defvar ',var))
+ (eval-when (:load-toplevel :execute)
+ (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp))))
(defmacro-mundanely defparameter (var val &optional (doc nil docp))
#!+sb-doc
previous value. The third argument is an optional documentation
string for the parameter."
`(progn
- (declaim (special ,var))
- (set ',var ,val)
- ,@(when docp
- `((setf (fdocumentation ',var 'variable) ',doc)))
- ',var))
+ (eval-when (:compile-toplevel)
+ (%compiler-defvar ',var))
+ (eval-when (:load-toplevel :execute)
+ (%defparameter ',var ,val ,doc ',docp))))
+
+(defun %compiler-defvar (var)
+ (sb!xc:proclaim `(special ,var)))
+
+#-sb-xc-host
+(defun %defvar (var val valp doc docp)
+ (%compiler-defvar var)
+ (when valp
+ (unless (boundp var)
+ (set var val)))
+ (when docp
+ (setf (fdocumentation var 'variable) doc))
+ var)
+
+#-sb-xc-host
+(defun %defparameter (var val doc docp)
+ (%compiler-defvar var)
+ (set var val)
+ (when docp
+ (setf (fdocumentation var 'variable) doc))
+ var)
\f
;;;; iteration constructs
(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
(defmacro-mundanely with-condition-restarts
(condition-form restarts-form &body body)
#!+sb-doc
- "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
- Evaluates the Forms in a dynamic environment where the restarts in the list
- Restarts-Form are associated with the condition returned by Condition-Form.
+ "Evaluates the BODY in a dynamic environment where the restarts in the list
+ RESTARTS-FORM are associated with the condition returned by CONDITION-FORM.
This allows FIND-RESTART, etc., to recognize restarts that are not related
to the error currently being debugged. See also RESTART-CASE."
(let ((n-cond (gensym)))
binding
:test #'eq))
(warn "Unnamed restart does not have a ~
- report function: ~S"
+ report function: ~S"
binding))
`(make-restart :name ',(car binding)
:function ,(cadr binding)
,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
;; functions appearing in fundamental defining
;; macro expansions:
%compiler-deftype
+ %compiler-defvar
%defun
%defsetf
+ %defparameter
+ %defvar
sb!c:%compiler-defun
sb!c::%define-symbol-macro
sb!c::%defconstant
projects / sbcl.git / blobdiff