(error "Vars is not a list of symbols: ~S" vars)))
(defmacro-mundanely multiple-value-setq (vars value-form)
- (cond ((null vars)
- ;; The ANSI spec says that the primary value of VALUE-FORM must be
- ;; returned. The general-case-handling code below doesn't do this
- ;; correctly in the special case when there are no vars bound, so we
- ;; handle this special case separately here.
- (let ((g (gensym)))
- `(multiple-value-bind (,g) ,value-form
- ,g)))
- ((list-of-symbols-p vars)
- (let ((temps (make-gensym-list (length vars))))
- `(multiple-value-bind ,temps ,value-form
- ,@(mapcar #'(lambda (var temp)
- `(setq ,var ,temp))
- vars temps)
- ,(car temps))))
- (t (error "Vars is not a list of symbols: ~S" vars))))
+ (unless (list-of-symbols-p vars)
+ (error "Vars is not a list of symbols: ~S" vars))
+ `(values (setf (values ,@vars) ,value-form)))
(defmacro-mundanely multiple-value-list (value-form)
`(multiple-value-call #'list ,value-form))
;;; COND defined in terms of IF
(defmacro-mundanely cond (&rest clauses)
(if (endp clauses)
- nil
- (let ((clause (first clauses)))
- (if (atom clause)
- (error "Cond clause is not a list: ~S" clause)
- (let ((test (first clause))
- (forms (rest clause)))
- (if (endp forms)
- (let ((n-result (gensym)))
- `(let ((,n-result ,test))
- (if ,n-result
- ,n-result
- (cond ,@(rest clauses)))))
- `(if ,test
- (progn ,@forms)
- (cond ,@(rest clauses)))))))))
+ nil
+ (let ((clause (first clauses)))
+ (if (atom clause)
+ (error "COND clause is not a list: ~S" clause)
+ (let ((test (first clause))
+ (forms (rest clause)))
+ (if (endp forms)
+ (let ((n-result (gensym)))
+ `(let ((,n-result ,test))
+ (if ,n-result
+ ,n-result
+ (cond ,@(rest clauses)))))
+ `(if ,test
+ (progn ,@forms)
+ (cond ,@(rest clauses)))))))))
;;; other things defined in terms of COND
(defmacro-mundanely when (test &body forms)
;; the only unsurprising choice.
(info :function :inline-expansion-designator name)))
-;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can
-;;; make a reasonably readable definition of DEFUN.
(defmacro-mundanely defun (&environment env name args &body body)
"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))
(multiple-value-bind (forms decls doc) (parse-body body)
- (let* ((lambda `(lambda ,args
- ,@decls
- (block ,(fun-name-block-name name)
- ,@forms)))
+ (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
+ (lambda-guts `(,args
+ ,@decls
+ (block ,(fun-name-block-name name)
+ ,@forms)))
+ (lambda `(lambda ,@lambda-guts))
+ #-sb-xc-host
+ (named-lambda `(named-lambda ,name ,@lambda-guts))
(inline-lambda
- (cond (;; Does the user not even want to inline?
- (not (inline-fun-name-p name))
- nil)
- (;; Does inlining look too hairy to handle?
- (not (sb!c:lambda-independent-of-lexenv-p lambda env))
- (sb!c:maybe-compiler-note
- "lexical environment too hairy, can't inline DEFUN ~S"
- name)
- nil)
- (t
- ;; FIXME: The only reason that we return
- ;; LAMBDA-WITH-LEXENV instead of returning bare
- ;; LAMBDA is to avoid modifying downstream code
- ;; which expects LAMBDA-WITH-LEXENV. But the code
- ;; here is the only code which feeds into the
- ;; downstream code, and the generality of the
- ;; interface is no longer used, so it'd make sense
- ;; to simplify the interface instead of using the
- ;; old general LAMBDA-WITH-LEXENV interface in this
- ;; simplified way.
- `(sb!c:lambda-with-lexenv
- nil nil nil ; i.e. no DECLS, no MACROS, no SYMMACS
- ,@(rest lambda))))))
+ (when (inline-fun-name-p name)
+ ;; we want to attempt to inline, so complain if we can't
+ (or (sb!c:maybe-inline-syntactic-closure lambda env)
+ (progn
+ (#+sb-xc-host warn
+ #-sb-xc-host sb!c:maybe-compiler-note
+ "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
(cold-fset ,name ,lambda)
;; where the compiled LAMBDA first appears. In
;; cross-compilation, we manipulate the
;; previously-statically-linked LAMBDA here.
- #-sb-xc-host ,lambda
+ #-sb-xc-host ,named-lambda
#+sb-xc-host (fdefinition ',name)
,doc)))))
#-sb-xc-host
(defun %defun (name def doc)
(declare (type function def))
(declare (type (or null simple-string doc)))
- (/show0 "entering %DEFUN, name (or block name) = ..")
- (/primitive-print (symbol-name (fun-name-block-name name)))
- (aver (legal-fun-name-p name))
+ (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN
(when (fboundp name)
- (/show0 "redefining NAME")
+ (/show0 "redefining NAME in %DEFUN")
(style-warn "redefining ~S in DEFUN" name))
- (/show0 "setting FDEFINITION")
(setf (sb!xc:fdefinition name) def)
+
+ ;; FIXME: I want to do this here (and fix bug 137), but until the
+ ;; breathtaking CMU CL function name architecture is converted into
+ ;; 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
;; FIXME: This should use shared SETF-name-parsing logic.
- (/show0 "setting FDOCUMENTATION")
(if (and (consp name) (eq (first name) 'setf))
(setf (fdocumentation (second name) 'setf) doc)
(setf (fdocumentation (the symbol name) 'function) doc)))
- (/show0 "leaving %DEFUN")
name)
\f
;;;; DEFVAR and DEFPARAMETER
`((unless (boundp ',var)
(setq ,var ,val))))
,@(when docp
- `((funcall #'(setf fdocumentation) ',doc ',var 'variable)))
+ `((setf (fdocumentation ',var 'variable) ',doc )))
',var))
(defmacro-mundanely defparameter (var val &optional (doc nil docp))
(declaim (special ,var))
(setq ,var ,val)
,@(when docp
- ;; FIXME: The various FUNCALL #'(SETF FDOCUMENTATION) and
- ;; other FUNCALL #'(SETF FOO) forms in the code should
- ;; unbogobootstrapized back to ordinary SETF forms.
- `((funcall #'(setf fdocumentation) ',doc ',var 'variable)))
+ `((setf (fdocumentation ',var 'variable) ',doc)))
',var))
\f
;;;; iteration constructs
-;;; (These macros are defined in terms of a function DO-DO-BODY which
+;;; (These macros are defined in terms of a function FROB-DO-BODY which
;;; is also used by SB!INT:DO-ANONYMOUS. Since these macros should not
;;; be loaded on the cross-compilation host, but SB!INT:DO-ANONYMOUS
-;;; and DO-DO-BODY should be, these macros can't conveniently be in
-;;; the same file as DO-DO-BODY.)
+;;; and FROB-DO-BODY should be, these macros can't conveniently be in
+;;; the same file as FROB-DO-BODY.)
(defmacro-mundanely do (varlist endlist &body body)
#!+sb-doc
"DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
are evaluated as a PROGN, with the result being the value of the DO. A block
named NIL is established around the entire expansion, allowing RETURN to be
used as an alternate exit mechanism."
- (do-do-body varlist endlist body 'let 'psetq 'do nil))
+ (frob-do-body varlist endlist body 'let 'psetq 'do nil))
(defmacro-mundanely do* (varlist endlist &body body)
#!+sb-doc
"DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
the Exit-Forms are evaluated as a PROGN, with the result being the value
of the DO. A block named NIL is established around the entire expansion,
allowing RETURN to be used as an laternate exit mechanism."
- (do-do-body varlist endlist body 'let* 'setq 'do* nil))
+ (frob-do-body varlist endlist body 'let* 'setq 'do* nil))
;;; DOTIMES and DOLIST could be defined more concisely using
;;; destructuring macro lambda lists or DESTRUCTURING-BIND, but then
;;; defined that it looks as though it's worth just implementing them
;;; ASAP, at the cost of being unable to use the standard
;;; destructuring mechanisms.
-(defmacro-mundanely dotimes (var-count-result &body body)
- (multiple-value-bind ; to roll our own destructuring
- (var count result)
- (apply (lambda (var count &optional (result nil))
- (values var count result))
- var-count-result)
- (cond ((numberp count)
- `(do ((,var 0 (1+ ,var)))
- ((>= ,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))))))
-(defmacro-mundanely dolist (var-list-result &body body)
- (multiple-value-bind ; to roll our own destructuring
- (var list result)
- (apply (lambda (var list &optional (result nil))
- (values var list result))
- var-list-result)
- ;; 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 introduce a gratuitous binding of the variable to NIL
- ;; without the declarations, then evaluate the result form in that
- ;; environment. We spuriously reference the gratuitous variable,
- ;; since since we don't want to use IGNORABLE on what might be a
- ;; special var.
+(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))
+ (t (let ((v1 (gensym)))
+ `(do ((,var 0 (1+ ,var)) (,v1 ,count))
+ ((>= ,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
+ ;; have to give the var an arbitrary value such as NIL (which might
+ ;; conflict with a declaration). If there is a result form, we
+ ;; introduce a gratuitous binding of the variable to NIL without the
+ ;; declarations, then evaluate the result form in that
+ ;; 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)))
- ,@body)))))
+ `(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))))))
\f
;;;; miscellaneous
(defmacro-mundanely psetq (&rest pairs)
#!+sb-doc
- "SETQ {var value}*
+ "PSETQ {var value}*
Set the variables to the values, like SETQ, except that assignments
happen in parallel, i.e. no assignments take place until all the
forms have been evaluated."
- ;; (This macro is used in the definition of DO, so we can't use DO in the
- ;; definition of this macro without getting into confusing bootstrap issues.)
- (prog ((lets nil)
- (setqs nil)
- (pairs pairs))
- :again
- (when (atom (cdr pairs))
- (return `(let ,(nreverse lets)
- (setq ,@(nreverse setqs))
- nil)))
- (let ((gen (gensym)))
- (setq lets (cons `(,gen ,(cadr pairs)) lets)
- setqs (list* gen (car pairs) setqs)
- pairs (cddr pairs)))
- (go :again)))
+ ;; Given the possibility of symbol-macros, we delegate to PSETF
+ ;; which knows how to deal with them, after checking that syntax is
+ ;; compatible with PSETQ.
+ (do ((pair pairs (cddr pair)))
+ ((endp pair) `(psetf ,@pairs))
+ (unless (symbolp (car pair))
+ (error 'simple-program-error
+ :format-control "variable ~S in PSETQ is not a SYMBOL"
+ :format-arguments (list (car pair))))))
(defmacro-mundanely lambda (&whole whole args &body body)
(declare (ignore args body))