`(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)))
(defmacro-mundanely multiple-value-setq (vars value-form)
(unless (list-of-symbols-p vars)
(error "Vars is not a list of symbols: ~S" vars))
- `(values (setf (values ,@vars) ,value-form)))
+ ;; MULTIPLE-VALUE-SETQ is required to always return just the primary
+ ;; value of the value-from, even if there are no vars. (SETF VALUES)
+ ;; in turn is required to return as many values as there are
+ ;; value-places, hence this:
+ (if vars
+ `(values (setf (values ,@vars) ,value-form))
+ `(values ,value-form)))
(defmacro-mundanely multiple-value-list (value-form)
`(multiple-value-call #'list ,value-form))
"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
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
(declare (type unsigned-byte ,var))
,@body)))))
+(defun filter-dolist-declarations (decls)
+ (mapcar (lambda (decl)
+ `(declare ,@(remove-if
+ (lambda (clause)
+ (and (consp clause)
+ (or (eq (car clause) 'type)
+ (eq (car clause) 'ignore))))
+ (cdr decl))))
+ decls))
+
(defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
;; 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
(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)))))
(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)
;; 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