(eq (info :function :inlinep name) :notinline))))
;; This will get redefined in PCL boot.
-(declaim (notinline update-info-for-gf))
+(declaim (notinline maybe-update-info-for-gf))
(defun maybe-update-info-for-gf (name)
- (declare (ignorable name))
- (values))
+ (declare (ignore name))
+ nil)
+
+(defun maybe-defined-here (name where)
+ (if (and (eq :defined where)
+ (member name *fun-names-in-this-file* :test #'equal))
+ :defined-here
+ where))
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
;; complain about undefined functions.
(not latep))
(note-undefined-reference name :function))
- (make-global-var
- :kind :global-function
- :%source-name name
- :type (if (or (eq where :declared)
- (and (not latep)
- (or *derive-function-types*
- (eq where :defined-method)
- (and (not (fun-lexically-notinline-p name))
- (member name *fun-names-in-this-file*
- :test #'equal)))))
- (progn
- (maybe-update-info-for-gf name)
- (info :function :type name))
- (specifier-type 'function))
- :defined-type (if (eq where :defined)
- (info :function :type name)
- *universal-type*)
- :where-from where)))
+ (let ((ftype (info :function :type name))
+ (notinline (fun-lexically-notinline-p name)))
+ (make-global-var
+ :kind :global-function
+ :%source-name name
+ :type (if (or (eq where :declared)
+ (and (not latep)
+ (not notinline)
+ *derive-function-types*))
+ ftype
+ (specifier-type 'function))
+ :defined-type (if (and (not latep) (not notinline))
+ (or (maybe-update-info-for-gf name) ftype)
+ (specifier-type 'function))
+ :where-from (if notinline
+ where
+ (maybe-defined-here name where))))))
;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid?
;;; Drop 'em.
(inlinep (info :function :inlinep name)))
(setf (gethash name *free-funs*)
(if (or expansion inlinep)
- (make-defined-fun
- :%source-name name
- :inline-expansion expansion
- :inlinep inlinep
- :where-from (info :function :where-from name)
- :type (if (eq inlinep :notinline)
- (specifier-type 'function)
- (info :function :type name)))
+ (let ((where (info :function :where-from name)))
+ (make-defined-fun
+ :%source-name name
+ :inline-expansion expansion
+ :inlinep inlinep
+ :where-from (if (eq inlinep :notinline)
+ where
+ (maybe-defined-here name where))
+ :type (if (and (eq inlinep :notinline)
+ (neq where :declared))
+ (specifier-type 'function)
+ (info :function :type name))))
(find-global-fun name nil))))))))
;;; Return the LEAF structure for the lexically apparent function
(trail form))
(declare (fixnum pos))
(macrolet ((frob ()
- '(progn
+ `(progn
(when (atom subform) (return))
(let ((fm (car subform)))
- (if (consp fm)
- ;; If it's a cons, recurse
- (sub-find-source-paths fm (cons pos path))
- ;; Otherwise store the containing form. It's
- ;; not perfect, but better than nothing.
- (unless (zerop pos)
- (note-source-path subform pos path)))
+ (cond ((consp fm)
+ ;; If it's a cons, recurse.
+ (sub-find-source-paths fm (cons pos path)))
+ ((eq 'quote fm)
+ ;; Don't look into quoted constants.
+ (return))
+ ((not (zerop pos))
+ ;; Otherwise store the containing form. It's not
+ ;; perfect, but better than nothing.
+ (note-source-path subform pos path)))
(incf pos))
(setq subform (cdr subform))
(when (eq subform trail) (return)))))
;;; functional instead.
(defun reference-leaf (start next result leaf &optional (name '.anonymous.))
(declare (type ctran start next) (type (or lvar null) result) (type leaf leaf))
- (when (functional-p leaf)
- (assure-functional-live-p leaf))
+ (assure-leaf-live-p leaf)
(let* ((type (lexenv-find leaf type-restrictions))
(leaf (or (and (defined-fun-p leaf)
(not (eq (defined-fun-inlinep leaf)
:notinline))
(let ((functional (defined-fun-functional leaf)))
- (when (and functional
- (not (functional-kind functional))
- ;; Bug MISC.320: ir1-transform
- ;; can create a reference to a
- ;; inline-expanded function,
- ;; defined in another component.
- (not (and (lambda-p functional)
- (neq (lambda-component functional)
- *current-component*))))
+ (when (and functional (not (functional-kind functional)))
(maybe-reanalyze-functional functional))))
(when (and (lambda-p leaf)
(memq (functional-kind leaf)
;; CLHS 3.2.2.1.3 specifies that NOTINLINE
;; suppresses compiler-macros.
(not (fun-lexically-notinline-p cmacro-fun-name)))
- (let ((res (careful-expand-macro cmacro-fun form)))
+ (let ((res (careful-expand-macro cmacro-fun form t)))
(cond ((eq res form)
(ir1-convert-common-functoid start next result form op))
(t
;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
;;; errors which occur during the macroexpansion.
-(defun careful-expand-macro (fun form)
+(defun careful-expand-macro (fun form &optional cmacro)
(let (;; a hint I (WHN) wish I'd known earlier
(hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)"))
(flet (;; Return a string to use as a prefix in error reporting,
(*print-level* 3))
(format
nil
- #-sb-xc-host "(in macroexpansion of ~S)"
+ #-sb-xc-host "(in ~A of ~S)"
;; longer message to avoid ambiguity "Was it the xc host
;; or the cross-compiler which encountered the problem?"
- #+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
+ #+sb-xc-host "(in cross-compiler ~A of ~S)"
+ (if cmacro "compiler-macroexpansion" "macroexpansion")
form))))
(handler-bind ((style-warning (lambda (c)
(compiler-style-warn
(type leaf var))
(let* ((node (ir1-convert-combination start next result form var))
(fun-lvar (basic-combination-fun node))
- (type (leaf-type var))
- (defined-type (leaf-defined-type var)))
- (when (validate-call-type node type defined-type t)
+ (type (leaf-type var)))
+ (when (validate-call-type node type var t)
(setf (lvar-%derived-type fun-lvar)
(make-single-value-type type))
(setf (lvar-reoptimize fun-lvar) nil)))
projects / sbcl.git / blobdiff