+ ;; Binding *POLICY* is pretty much of a hack, since it
+ ;; causes LOCALLY to "capture" enclosed proclamations. It
+ ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the
+ ;; value of *POLICY* as the policy. The need for this hack
+ ;; is due to the quirk that there is no way to represent in
+ ;; a POLICY that an optimize quality came from the default.
+ ;;
+ ;; FIXME: Ideally, something should be done so that DECLAIM
+ ;; inside LOCALLY works OK. Failing that, at least we could
+ ;; issue a warning instead of silently screwing up.
+ (*policy* (lexenv-policy *lexenv*)))
+ (process-toplevel-progn forms path compile-time-too))))
+
+;;; Parse an EVAL-WHEN situations list, returning three flags,
+;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
+;;; the types of situations present in the list.
+(defun parse-eval-when-situations (situations)
+ (when (or (not (listp situations))
+ (set-difference situations
+ '(:compile-toplevel
+ compile
+ :load-toplevel
+ load
+ :execute
+ eval)))
+ (compiler-error "bad EVAL-WHEN situation list: ~S" situations))
+ (let ((deprecated-names (intersection situations '(compile load eval))))
+ (when deprecated-names
+ (style-warn "using deprecated EVAL-WHEN situation names~{ ~S~}"
+ deprecated-names)))
+ (values (intersection '(:compile-toplevel compile)
+ 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))
+ (labels ((frob (clambda)
+ (pushnew (lambda-component clambda)
+ result))
+ (maybe-frob (maybe-clambda)
+ (when maybe-clambda
+ (frob maybe-clambda))))
+ (mapc #'frob (optional-dispatch-entry-points f))
+ (maybe-frob (optional-dispatch-more-entry f))
+ (maybe-frob (optional-dispatch-main-entry f)))))))
+
+(defun make-functional-from-toplevel-lambda (definition
+ &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))
+ (setf (component-name component)
+ (debug-namify "~S initial component" name))
+ (setf (component-kind component) :initial)
+ (let* ((locall-fun (ir1-convert-lambda
+ definition
+ :debug-name (debug-namify "top level local call ~S"
+ name)))
+ (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
+ :source-name (or name '.anonymous.)
+ :debug-name (unless name
+ "top level form"))))
+ (setf (functional-entry-fun fun) locall-fun
+ (functional-kind fun) :external
+ (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*))
+ (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))
+
+ (multiple-value-bind (components-from-dfo top-components hairy-top)
+ (find-initial-dfo (list fun))
+
+ (let ((*all-components* (append components-from-dfo top-components)))
+ ;; FIXME: This is more monkey see monkey do based on CMU CL
+ ;; code. If anyone figures out why to only prescan HAIRY-TOP
+ ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or
+ ;; some other combination of results from FIND-INITIAL-VALUES,
+ ;; it'd be good to explain it.
+ (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top)
+ (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components)
+ (dolist (component-from-dfo components-from-dfo)
+ (compile-component component-from-dfo)
+ (replace-toplevel-xeps component-from-dfo)))
+
+ (prog1
+ (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)
+ 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
+ (when (core-object-p *compile-object*)
+ (fix-core-source-info *source-info* *compile-object*))
+
+ (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))
+
+;;; Process a top level FORM with the specified source PATH.
+;;; * If this is a magic top level form, then do stuff.