- (case (car thing)
- ((lambda)
- (reference-leaf start
- cont
- (ir1-convert-lambda thing
- :debug-name (debug-namify
- "#'~S" thing))))
- ((setf)
- (let ((var (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var)))
- ((instance-lambda)
- (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
- :debug-name (debug-namify "#'~S"
- thing))))
- (setf (getf (functional-plist res) :fin-function) t)
- (reference-leaf start cont res)))
- (t
- (compiler-error "~S is not a legal function name." thing)))
- (let ((var (find-lexically-apparent-fun
- thing "as the argument to FUNCTION")))
- (reference-leaf start cont var))))
-
-;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)),
-;;; except that the value of NAME is passed to the compiler for use in
-;;; creation of debug information for the resulting function.
-;;;
-;;; NAME can be a legal function name or some arbitrary other thing.
-;;;
-;;; If NAME is a legal function name, then the caller should be
-;;; planning to set (FDEFINITION NAME) to the created function.
-;;; (Otherwise the debug names will be inconsistent and thus
-;;; unnecessarily confusing.)
-;;;
-;;; Arbitrary other things are appropriate for naming things which are
-;;; not the FDEFINITION of NAME. E.g.
-;;; NAME = (:FLET FOO BAR)
-;;; for the FLET function in
-;;; (DEFUN BAR (X)
-;;; (FLET ((FOO (Y) (+ X Y)))
-;;; FOO))
-;;; or
-;;; NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T))
-;;; for the function used to implement
-;;; (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
-(def-ir1-translator named-lambda ((name &rest rest) start cont)
- (reference-leaf start
- cont
- (if (legal-fun-name-p name)
- (ir1-convert-lambda `(lambda ,@rest)
- :source-name name)
- (ir1-convert-lambda `(lambda ,@rest)
- :debug-name name))))
+ (cond
+ ((member (car thing)
+ '(lambda named-lambda instance-lambda lambda-with-lexenv))
+ (values (ir1-convert-lambdalike
+ thing
+ :debug-name (name-lambdalike thing))
+ t))
+ ((legal-fun-name-p thing)
+ (values (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")
+ nil))
+ (t
+ (compiler-error "~S is not a legal function name." thing)))
+ (values (find-lexically-apparent-fun
+ thing "as the argument to FUNCTION")
+ nil)))
+
+(def-ir1-translator %%allocate-closures ((&rest leaves) start next result)
+ (aver (eq result 'nil))
+ (let ((lambdas leaves))
+ (ir1-convert start next result `(%allocate-closures ',lambdas))
+ (let ((allocator (node-dest (ctran-next start))))
+ (dolist (lambda lambdas)
+ (setf (functional-allocator lambda) allocator)))))
+
+(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body)
+ `(multiple-value-bind (,leaf allocate-p)
+ (if ,global-function
+ (find-global-fun ,thing t)
+ (fun-name-leaf ,thing))
+ (if allocate-p
+ (let ((.new-start. (make-ctran)))
+ (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf))
+ (let ((,start .new-start.))
+ ,@body))
+ (locally
+ ,@body))))
+
+(def-ir1-translator function ((thing) start next result)
+ #!+sb-doc
+ "FUNCTION name
+
+Return the lexically apparent definition of the function NAME. NAME may also
+be a lambda expression."
+ (with-fun-name-leaf (leaf thing start)
+ (reference-leaf start next result leaf)))
+
+;;; Like FUNCTION, but ignores local definitions and inline
+;;; expansions, and doesn't nag about undefined functions.
+;;; Used for optimizing things like (FUNCALL 'FOO).
+(def-ir1-translator global-function ((thing) start next result)
+ (with-fun-name-leaf (leaf thing start :global-function t)
+ (reference-leaf start next result leaf)))
+
+(defun constant-global-fun-name (thing)
+ (let ((constantp (sb!xc:constantp thing)))
+ (when constantp
+ (let ((name (constant-form-value thing)))
+ (when (legal-fun-name-p name)
+ name)))))
+
+(defun lvar-constant-global-fun-name (lvar)
+ (when (constant-lvar-p lvar)
+ (let ((name (lvar-value lvar)))
+ (when (legal-fun-name-p name)
+ name))))
+
+(defun ensure-source-fun-form (source &optional give-up)
+ (let ((op (when (consp source) (car source))))
+ (cond ((eq op '%coerce-callable-to-fun)
+ (ensure-source-fun-form (second source)))
+ ((member op '(function global-function lambda named-lambda))
+ (values source nil))
+ (t
+ (let ((cname (constant-global-fun-name source)))
+ (if cname
+ (values `(global-function ,cname) nil)
+ (values `(%coerce-callable-to-fun ,source) give-up)))))))
+
+(defun ensure-lvar-fun-form (lvar lvar-name &optional give-up)
+ (aver (and lvar-name (symbolp lvar-name)))
+ (if (csubtypep (lvar-type lvar) (specifier-type 'function))
+ lvar-name
+ (let ((cname (lvar-constant-global-fun-name lvar)))
+ (cond (cname
+ `(global-function ,cname))
+ (give-up
+ (give-up-ir1-transform give-up))
+ (t
+ `(%coerce-callable-to-fun ,lvar-name))))))