+ situations)
+ (intersection '(:load-toplevel load) situations)
+ (intersection '(:execute eval) situations)))
+
+
+;;; utilities for extracting COMPONENTs of FUNCTIONALs
+(defun functional-components (f)
+ (declare (type functional f))
+ (etypecase f
+ (clambda (list (lambda-component f)))
+ (optional-dispatch (let ((result nil))
+ (flet ((maybe-frob (maybe-clambda)
+ (when (and maybe-clambda
+ (promise-ready-p maybe-clambda))
+ (pushnew (lambda-component
+ (force maybe-clambda))
+ result))))
+ (map nil #'maybe-frob (optional-dispatch-entry-points f))
+ (maybe-frob (optional-dispatch-more-entry f))
+ (maybe-frob (optional-dispatch-main-entry f)))
+ result))))
+
+(defun make-functional-from-toplevel-lambda (lambda-expression
+ &key
+ name
+ (path
+ ;; I'd thought NIL should
+ ;; work, but it doesn't.
+ ;; -- WHN 2001-09-20
+ (missing-arg)))
+ (let* ((*current-path* path)
+ (component (make-empty-component))
+ (*current-component* component)
+ (debug-name-tail (or name (name-lambdalike lambda-expression)))
+ (source-name (or name '.anonymous.)))
+ (setf (component-name component) (debug-name 'initial-component debug-name-tail)
+ (component-kind component) :initial)
+ (let* ((locall-fun (let ((*allow-instrumenting* t))
+ (funcall #'ir1-convert-lambdalike
+ lambda-expression
+ :source-name source-name)))
+ ;; Convert the XEP using the policy of the real
+ ;; function. Otherwise the wrong policy will be used for
+ ;; deciding whether to type-check the parameters of the
+ ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS).
+ ;; -- JES, 2007-02-27
+ (*lexenv* (make-lexenv :policy (lexenv-policy
+ (functional-lexenv locall-fun))))
+ (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
+ :source-name source-name
+ :debug-name (debug-name 'tl-xep debug-name-tail)
+ :system-lambda t)))
+ (when name
+ (assert-global-function-definition-type name locall-fun))
+ (setf (functional-entry-fun fun) locall-fun
+ (functional-kind fun) :external
+ (functional-has-external-references-p locall-fun) t
+ (functional-has-external-references-p fun) t)
+ fun)))
+
+;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
+;;; description of the result.
+;;; * If *COMPILE-OBJECT* is a CORE-OBJECT, then write the function
+;;; into core and return the compiled FUNCTION value.
+;;; * If *COMPILE-OBJECT* is a fasl file, then write the function
+;;; into the fasl file and return a dump handle.
+;;;
+;;; If NAME is provided, then we try to use it as the name of the
+;;; function for debugging/diagnostic information.
+(defun %compile (lambda-expression
+ *compile-object*
+ &key
+ name
+ (path
+ ;; This magical idiom seems to be the appropriate
+ ;; path for compiling standalone LAMBDAs, judging
+ ;; from the CMU CL code and experiment, so it's a
+ ;; nice default for things where we don't have a
+ ;; real source path (as in e.g. inside CL:COMPILE).
+ '(original-source-start 0 0)))
+ (when name
+ (legal-fun-name-or-type-error name))
+ (let* ((*lexenv* (make-lexenv
+ :policy *policy*
+ :handled-conditions *handled-conditions*
+ :disabled-package-locks *disabled-package-locks*))
+ (*compiler-sset-counter* 0)
+ (fun (make-functional-from-toplevel-lambda lambda-expression
+ :name name
+ :path path)))
+
+ ;; FIXME: The compile-it code from here on is sort of a
+ ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
+ ;; better to find a way to share the code there; or
+ ;; alternatively, to use this code to replace the code there.
+ ;; (The second alternative might be pretty easy if we used
+ ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
+ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
+
+ (locall-analyze-clambdas-until-done (list fun))
+
+ (let ((components-from-dfo (find-initial-dfo (list fun))))
+ (dolist (component-from-dfo components-from-dfo)
+ (compile-component component-from-dfo)
+ (replace-toplevel-xeps component-from-dfo))
+
+ (let ((entry-table (etypecase *compile-object*
+ (fasl-output (fasl-output-entry-table
+ *compile-object*))
+ (core-object (core-object-entry-table
+ *compile-object*)))))
+ (multiple-value-bind (result found-p)
+ (gethash (leaf-info fun) entry-table)
+ (aver found-p)
+ (prog1
+ result
+ ;; KLUDGE: This code duplicates some other code in this
+ ;; file. In the great reorganzation, the flow of program
+ ;; logic changed from the original CMUCL model, and that
+ ;; path (as of sbcl-0.7.5 in SUB-COMPILE-FILE) was no
+ ;; longer followed for CORE-OBJECTS, leading to BUG
+ ;; 156. This place is transparently not the right one for
+ ;; this code, but I don't have a clear enough overview of
+ ;; the compiler to know how to rearrange it all so that
+ ;; this operation fits in nicely, and it was blocking
+ ;; reimplementation of (DECLAIM (INLINE FOO)) (MACROLET
+ ;; ((..)) (DEFUN FOO ...))
+ ;;
+ ;; FIXME: This KLUDGE doesn't solve all the problem in an
+ ;; ideal way, as (1) definitions typed in at the REPL
+ ;; without an INLINE declaration will give a NULL
+ ;; FUNCTION-LAMBDA-EXPRESSION (allowable, but not ideal)
+ ;; and (2) INLINE declarations will yield a
+ ;; FUNCTION-LAMBDA-EXPRESSION headed by
+ ;; SB-C:LAMBDA-WITH-LEXENV, even for null LEXENV. -- CSR,
+ ;; 2002-07-02
+ ;;
+ ;; (2) is probably fairly easy to fix -- it is, after all,
+ ;; a matter of list manipulation (or possibly of teaching
+ ;; CL:FUNCTION about SB-C:LAMBDA-WITH-LEXENV). (1) is
+ ;; significantly harder, as the association between
+ ;; function object and source is a tricky one.
+ ;;
+ ;; FUNCTION-LAMBDA-EXPRESSION "works" (i.e. returns a
+ ;; non-NULL list) when the function in question has been
+ ;; compiled by (COMPILE <x> '(LAMBDA ...)); it does not
+ ;; work when it has been compiled as part of the top-level
+ ;; EVAL strategy of compiling everything inside (LAMBDA ()
+ ;; ...). -- CSR, 2002-11-02
+ (when (core-object-p *compile-object*)
+ (fix-core-source-info *source-info* *compile-object* result))
+
+ (mapc #'clear-ir1-info components-from-dfo)
+ (clear-stuff)))))))
+
+(defun process-toplevel-cold-fset (name lambda-expression path)
+ (unless (producing-fasl-file)
+ (error "can't COLD-FSET except in a fasl file"))
+ (legal-fun-name-or-type-error name)
+ (fasl-dump-cold-fset name
+ (%compile lambda-expression
+ *compile-object*
+ :name name
+ :path path)
+ *compile-object*)
+ (values))