(compiler-error "The variable ~S occurs more than once in the lambda list."
name))
(let ((kind (info :variable :kind name)))
- (when (or (keywordp name) (eq kind :constant))
- (compiler-error "The name of the lambda variable ~S is already in use to name a constant."
- name))
+ (cond ((or (keywordp name) (eq kind :constant))
+ (compiler-error "The name of the lambda variable ~S is already in use to name a constant."
+ name))
+ ((eq :global kind)
+ (compiler-error "The name of the lambda variable ~S is already in use to name a global variable."
+ name)))
(cond ((eq kind :special)
(let ((specvar (find-free-var name)))
(make-lambda-var :%source-name name
(setf debug-name (name-lambdalike form)))
(multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
(make-lambda-vars (cadr form))
- (multiple-value-bind (forms decls) (parse-body (cddr form))
+ (multiple-value-bind (forms decls doc) (parse-body (cddr form))
(binding* (((*lexenv* result-type post-binding-lexenv)
(process-decls decls (append aux-vars vars) nil
:binding-form-p t))
:system-lambda system-lambda)))))
(setf (functional-inline-expansion res) form)
(setf (functional-arg-documentation res) (cadr form))
+ (setf (functional-documentation res) doc)
(when (boundp '*lambda-conversions*)
;; KLUDGE: Not counting TL-XEPs is a lie, of course, but
;; keeps things less confusing to users of TIME, where this
;;; previous references.
(defun get-defined-fun (name)
(proclaim-as-fun-name name)
- (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
- (note-name-defined name :function)
- (cond ((not (defined-fun-p found))
- (aver (not (info :function :inlinep name)))
- (let* ((where-from (leaf-where-from found))
- (res (make-defined-fun
- :%source-name name
- :where-from (if (eq where-from :declared)
- :declared :defined)
- :type (leaf-type found))))
- (substitute-leaf res found)
- (setf (gethash name *free-funs*) res)))
- ;; If *FREE-FUNS* has a previously converted definition
- ;; for this name, then blow it away and try again.
- ((defined-fun-functionals found)
- (remhash name *free-funs*)
- (get-defined-fun name))
- (t found))))
+ (when (boundp '*free-funs*)
+ (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")))
+ (note-name-defined name :function)
+ (cond ((not (defined-fun-p found))
+ (aver (not (info :function :inlinep name)))
+ (let* ((where-from (leaf-where-from found))
+ (res (make-defined-fun
+ :%source-name name
+ :where-from (if (eq where-from :declared)
+ :declared :defined)
+ :type (leaf-type found))))
+ (substitute-leaf res found)
+ (setf (gethash name *free-funs*) res)))
+ ;; If *FREE-FUNS* has a previously converted definition
+ ;; for this name, then blow it away and try again.
+ ((defined-fun-functionals found)
+ (remhash name *free-funs*)
+ (get-defined-fun name))
+ (t found)))))
;;; Check a new global function definition for consistency with
;;; previous declaration or definition, and assert argument/result
(setf (functional-inlinep fun) inlinep)
(assert-new-definition var fun)
(setf (defined-fun-inline-expansion var) expansion)
+ ;; Associate VAR with the FUN -- and in case of an optional dispatch
+ ;; with the various entry-points. This allows XREF to know where the
+ ;; inline CLAMBDA comes from.
+ (flet ((note-inlining (f)
+ (typecase f
+ (functional
+ (setf (functional-inline-expanded f) var))
+ (cons
+ ;; Delayed entry-point.
+ (if (car f)
+ (setf (functional-inline-expanded (cdr f)) var)
+ (let ((old-thunk (cdr f)))
+ (setf (cdr f) (lambda ()
+ (let ((g (funcall old-thunk)))
+ (setf (functional-inline-expanded g) var)
+ g)))))))))
+ (note-inlining fun)
+ (when (optional-dispatch-p fun)
+ (note-inlining (optional-dispatch-main-entry fun))
+ (note-inlining (optional-dispatch-more-entry fun))
+ (mapc #'note-inlining (optional-dispatch-entry-points fun))))
;; substitute for any old references
(unless (or (not *block-compile*)
(and info
(defun %compiler-defun (name lambda-with-lexenv compile-toplevel)
(let ((defined-fun nil)) ; will be set below if we're in the compiler
(when compile-toplevel
- ;; better be in the compiler
- (aver (boundp '*lexenv*))
- (remhash name *free-funs*)
(setf defined-fun (get-defined-fun name))
- (aver (fasl-output-p *compile-object*))
- (if (member name *fun-names-in-this-file* :test #'equal)
- (warn 'duplicate-definition :name name)
- (push name *fun-names-in-this-file*)))
+ (when (boundp '*lexenv*)
+ (remhash name *free-funs*)
+ (aver (fasl-output-p *compile-object*))
+ (if (member name *fun-names-in-this-file* :test #'equal)
+ (warn 'duplicate-definition :name name)
+ (push name *fun-names-in-this-file*))))
(become-defined-fun-name name)