Plaster

(defun process-toplevel-defun (form stream compile-time-too) (declare (ignore stream)) (note-toplevel-form form) (let* ((name (second form)) (block-name (fdefinition-block-name name)) (lambda-list (third form)) (body (nthcdr 3 form))) (jvm::with-saved-compiler-policy (multiple-value-bind (body decls doc) (parse-body body) (let* ((expr `(lambda ,lambda-list ,@decls (block ,block-name ,@body))) (saved-class-number *class-number*) (classfile (next-classfile)) (internal-compiler-errors nil) (result (with-open-file (f classfile :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (handler-bind ((internal-compiler-error #'(lambda (e) (push e internal-compiler-errors) (continue)))) (report-error (jvm:compile-defun name expr *compile-file-environment* classfile f nil))))) (compiled-function (if (not internal-compiler-errors) (verify-load classfile) nil))) (declare (ignore result)) (cond ((and (not internal-compiler-errors) compiled-function) (when compile-time-too (eval form)) (let ((sym (if (consp name) (second name) name))) (setf form `(progn (sys:put ',sym 'sys::source (cl:cons '((:function ,name) ,(namestring *source*) ,*source-position*) (cl:get ',sym 'sys::source nil))) (sys:fset ',name (sys::get-fasl-function *fasl-loader* ,saved-class-number) ,*source-position* ',lambda-list ,doc))))) (t (compiler-warn "Unable to compile function ~A. Using interpreted form instead.~%" name) (when internal-compiler-errors (dolist (e internal-compiler-errors) (format *error-output* "; ~A~%" e))) (let ((precompiled-function (precompiler:precompile-form expr nil *compile-file-environment*))) (setf form `(sys:fset ',name ,precompiled-function ,*source-position* ',lambda-list ,doc))) (when compile-time-too (eval form))))) (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) ;; FIXME Need to support SETF functions too! (setf (inline-expansion name) (jvm::generate-inline-expansion block-name lambda-list (append decls body))) (output-form `(cl:setf (inline-expansion ',name) ',(inline-expansion name)))))) (push name jvm::*functions-defined-in-current-file*) (note-name-defined name) (push name *toplevel-functions*) (when (and (consp name) (or (eq 'setf (first name)) (eq 'cl:setf (first name)))) (push (second name) *toplevel-setf-functions*)) ;; If NAME is not fbound, provide a dummy definition so that ;; getSymbolFunctionOrDie() will succeed when we try to verify that ;; functions defined later in the same file can be loaded correctly. (unless (fboundp name) (setf (fdefinition name) #'dummy) (push name *fbound-names*))) form)