Changeset 11901


Ignore:
Timestamp:
05/20/09 20:17:30 (9 years ago)
Author:
ehuelsmann
Message:

In an effort to understand what's going on:
Consolidate GET-LAMBDA-TO-COMPILE, %JVM-COMPILE,
JVM-COMPILE and JVM-COMPILE-PACKAGE.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r11898 r11901  
    83518351            (terpri *error-output*))))))
    83528352
    8353 (defun get-lambda-to-compile (thing)
    8354   (if (and (consp thing)
    8355            (eq (%car thing) 'LAMBDA))
    8356       thing
    8357       (multiple-value-bind (lambda-expression environment)
    8358           (function-lambda-expression (if (typep thing 'standard-generic-function)
    8359                                           (mop::funcallable-instance-function thing)
    8360                                           thing))
    8361         (unless lambda-expression
    8362           (error "Can't find a definition for ~S." thing))
    8363         (values lambda-expression environment))))
    8364 
    8365 (defun %jvm-compile (name definition)
     8353(defun %jvm-compile (name definition expr env)
     8354  (let* (compiled-function
     8355         (tempfile (make-temp-file)))
     8356    (with-compilation-unit ()
     8357      (with-saved-compiler-policy
     8358        (unwind-protect
     8359             (setf compiled-function
     8360                   (load-compiled-function
     8361                    (compile-defun name expr env tempfile))))
     8362        (delete-file tempfile)))
     8363    (when (and name (functionp compiled-function))
     8364      (sys::%set-lambda-name compiled-function name)
     8365      (sys:set-call-count compiled-function (sys:call-count definition))
     8366      (sys::%set-arglist compiled-function (sys::arglist definition))
     8367      (let ((*warn-on-redefinition* nil))
     8368        (cond ((typep definition 'standard-generic-function)
     8369               (mop:set-funcallable-instance-function definition compiled-function))
     8370              (t
     8371               (setf (fdefinition name)
     8372                     (if (macro-function name)
     8373                         (make-macro name compiled-function)
     8374                         compiled-function))))))
     8375    (or name compiled-function)))
     8376
     8377(defun jvm-compile (name &optional definition)
    83668378  (unless definition
    8367     (resolve name)
     8379    (resolve name) ;; Make sure the symbol has been resolved by the autoloader
    83688380    (setf definition (fdefinition name)))
    83698381  (when (compiled-function-p definition)
    8370     (return-from %jvm-compile (values name nil nil)))
    8371   (multiple-value-bind (expr env)
    8372       (get-lambda-to-compile definition)
    8373     (let* ((*package* (if (and name (symbol-package name))
    8374                           (symbol-package name)
    8375                           *package*))
    8376            compiled-function
    8377            (warnings-p nil)
    8378            (failure-p nil))
    8379       (with-compilation-unit ()
    8380         (with-saved-compiler-policy
    8381           (let* ((tempfile (make-temp-file)))
    8382             (unwind-protect
    8383                  (setf compiled-function
    8384                        (load-compiled-function
    8385                         (handler-bind ((style-warning
    8386                                         #'(lambda (c)
    8387                                             (declare (ignore c))
    8388                                             (setf warnings-p t)
    8389                                             nil))
    8390                                        ((or warning
    8391                                             compiler-error)
    8392                                         #'(lambda (c)
    8393                                             (declare (ignore c))
    8394                                             (setf warnings-p t
    8395                                                   failure-p t)
    8396                                             nil)))
    8397                           (compile-defun name expr env tempfile))))
    8398               (delete-file tempfile))))
    8399         (when (and name (functionp compiled-function))
    8400           (sys::%set-lambda-name compiled-function name)
    8401           (sys:set-call-count compiled-function (sys:call-count definition))
    8402           (sys::%set-arglist compiled-function (sys::arglist definition))
    8403           (let ((*warn-on-redefinition* nil))
    8404             (cond ((typep definition 'standard-generic-function)
    8405                    (mop:set-funcallable-instance-function definition compiled-function))
    8406                   (t
    8407                    (setf (fdefinition name)
    8408                          (if (macro-function name)
    8409                              (make-macro name compiled-function)
    8410                              compiled-function)))))))
    8411       (values (or name compiled-function) warnings-p failure-p))))
    8412 
    8413 (defun jvm-compile (name &optional definition)
    8414   (if *catch-errors*
    8415       (handler-case
    8416           (%jvm-compile name definition)
    8417         (compiler-unsupported-feature-error
    8418          (c)
    8419          (fresh-line)
    8420          (sys::%format t "; UNSUPPORTED FEATURE: ~A~%" c)
    8421          (if name
    8422              (sys::%format t "; Unable to compile ~S.~%" name)
    8423              (sys::%format t "; Unable to compile top-level form.~%"))
    8424          (precompiler::precompile name definition)))
    8425       (%jvm-compile name definition)))
     8382    (return-from jvm-compile (values name nil nil)))
     8383  (let ((catch-errors *catch-errors*)
     8384        (warnings-p nil)
     8385        (failure-p nil)
     8386        (*package* (or (and name (symbol-package name)) *package*))
     8387        (expression definition)
     8388        environment)
     8389    (unless (and (consp definition) (eq (car definition) 'LAMBDA))
     8390      (when (typep definition 'standard-generic-function)
     8391        (setf definition (mop::funcallable-instance-function definition)))
     8392      (multiple-value-setq
     8393          (expression environment)
     8394        (function-lambda-expression definition)))
     8395    (unless expression
     8396      (error "Can't find a definition for ~S." definition))
     8397    (handler-bind
     8398        ((compiler-unsupported-feature-error
     8399          #'(lambda (c)
     8400              (when catch-errors
     8401                (fresh-line)
     8402                (sys::%format t "; UNSUPPORTED FEATURE: ~A~%" c)
     8403                (sys::%format t "; Unable to compile ~S.~%"
     8404                              (or name "top-level form"))
     8405                (precompiler::precompile name definition)
     8406                t)))
     8407         (style-warning
     8408          #'(lambda (c) (declare (ignore c))
     8409              (setf warnings-p t) nil))
     8410         ((or warning compiler-error)
     8411          #'(lambda (c) (declare (ignore c))
     8412              (setf warnings-p t
     8413                    failure-p t)
     8414              nil)))
     8415      (values (%jvm-compile name definition expression environment)
     8416              warnings-p failure-p))))
    84268417
    84278418(defun jvm-compile-package (package-designator)
     
    84328423        (when (fboundp sym)
    84338424          (unless (or (special-operator-p sym) (macro-function sym))
    8434             ;; Force autoload to be resolved.
    8435             (resolve sym)
    8436             (let ((f (fdefinition sym)))
    8437               (unless (compiled-function-p f)
    8438                 (jvm-compile sym)))))))
     8425            (jvm-compile sym)))))
    84398426  t)
    84408427
Note: See TracChangeset for help on using the changeset viewer.