Changeset 12907


Ignore:
Timestamp:
08/29/10 22:13:30 (11 years ago)
Author:
ehuelsmann
Message:

Remove WITH-TEMP-CLASS-FILE: it's been long unused.
Integrate CLASS-FILE and STREAM creation into COMPILE-AND-WRITE-TO-STREAM
(which now probably should be renamed) to clean up boiler plate from
its callers.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/generic-class-file/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12905 r12907  
    37893789    (emit-move-from-stack target)))
    37903790
    3791 (defun compile-and-write-to-stream (class-file compiland stream)
    3792   (setf (compiland-class-file compiland) class-file)
    3793   (with-class-file class-file
    3794     (let ((*current-compiland* compiland))
    3795       (with-saved-compiler-policy
    3796         (p2-compiland compiland)
    3797 ;;        (finalize-class-file (compiland-class-file compiland))
    3798         (finish-class (compiland-class-file compiland) stream)))))
    3799 
    3800 (defmacro with-temp-class-file (pathname class-file lambda-list &body body)
    3801   `(let* ((,pathname (make-temp-file))
    3802     (,class-file (make-abcl-class-file :pathname ,pathname
    3803                                              :lambda-list ,lambda-list)))
    3804      (unwind-protect
    3805     (progn ,@body)
    3806        (delete-file pathname))))
     3791(defun compile-and-write-to-stream (compiland &optional stream)
     3792  "Creates a class file associated with `compiland`, writing it
     3793either to stream or the pathname of the class file if `stream' is NIL."
     3794  (let* ((pathname (funcall *pathnames-generator*))
     3795         (class-file (make-abcl-class-file
     3796                      :pathname pathname
     3797                      :lambda-list
     3798                      (cadr (compiland-lambda-expression compiland)))))
     3799    (setf (compiland-class-file compiland) class-file)
     3800    (with-open-stream (f (or stream
     3801                             (open pathname :direction :output
     3802                                   :element-type '(unsigned-byte 8)
     3803                                   :if-exists :supersede)))
     3804      (with-class-file class-file
     3805        (let ((*current-compiland* compiland))
     3806          (with-saved-compiler-policy
     3807              (p2-compiland compiland)
     3808            ;;        (finalize-class-file (compiland-class-file compiland))
     3809            (finish-class (compiland-class-file compiland) f)))))))
    38073810
    38083811(defknown p2-flet-process-compiland (t) t)
    38093812(defun p2-flet-process-compiland (local-function)
    3810   (let* ((compiland (local-function-compiland local-function))
    3811          (lambda-list (cadr (compiland-lambda-expression compiland))))
     3813  (let* ((compiland (local-function-compiland local-function)))
    38123814    (cond (*file-compilation*
    3813            (let* ((pathname (funcall *pathnames-generator*))
    3814                   (class-file (make-abcl-class-file :pathname pathname
    3815                                                     :lambda-list lambda-list)))
    3816              (with-open-class-file (f class-file)
    3817                (compile-and-write-to-stream class-file compiland f))
    3818              (setf (local-function-class-file local-function) class-file)))
     3815           (compile-and-write-to-stream compiland)
     3816           (setf (local-function-class-file local-function)
     3817                 (compiland-class-file compiland)))
    38193818          (t
    3820            (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
    3821              (with-open-stream (stream (sys::%make-byte-array-output-stream))
    3822                (compile-and-write-to-stream class-file compiland stream)
    3823                (setf (local-function-class-file local-function) class-file)
    3824                (setf (local-function-function local-function)
    3825                      (load-compiled-function
    3826                       (sys::%get-output-stream-bytes stream)))))))))
     3819           (with-open-stream (stream (sys::%make-byte-array-output-stream))
     3820             (compile-and-write-to-stream compiland stream)
     3821             (setf (local-function-class-file local-function)
     3822                   (compiland-class-file compiland))
     3823             (setf (local-function-function local-function)
     3824                   (load-compiled-function
     3825                    (sys::%get-output-stream-bytes stream))))))))
    38273826
    38283827(defun emit-make-compiled-closure-for-labels
     
    38423841(defknown p2-labels-process-compiland (t) t)
    38433842(defun p2-labels-process-compiland (local-function)
    3844   (let* ((compiland (local-function-compiland local-function))
    3845          (lambda-list (cadr (compiland-lambda-expression compiland))))
     3843  (let* ((compiland (local-function-compiland local-function)))
    38463844    (cond (*file-compilation*
    3847            (let* ((pathname (funcall *pathnames-generator*))
    3848                   (class-file (make-abcl-class-file :pathname pathname
    3849                                                     :lambda-list lambda-list)))
    3850              (with-open-class-file (f class-file)
    3851                (compile-and-write-to-stream class-file compiland f))
    3852              (setf (local-function-class-file local-function) class-file)
    3853              (let ((g (declare-local-function local-function)))
     3845           (compile-and-write-to-stream compiland)
     3846           (setf (local-function-class-file local-function)
     3847                 (compiland-class-file compiland))
     3848           (let ((g (declare-local-function local-function)))
     3849             (emit-make-compiled-closure-for-labels
     3850              local-function compiland g)))
     3851          (t
     3852           (with-open-stream (stream (sys::%make-byte-array-output-stream))
     3853             (compile-and-write-to-stream compiland stream)
     3854             (setf (local-function-class-file local-function)
     3855                   (compiland-class-file compiland))
     3856             (let ((g (declare-object
     3857                       (load-compiled-function
     3858                        (sys::%get-output-stream-bytes stream)))))
    38543859               (emit-make-compiled-closure-for-labels
    3855                 local-function compiland g))))
    3856           (t
    3857            (let ((class-file (make-abcl-class-file :lambda-list lambda-list)))
    3858              (with-open-stream (stream (sys::%make-byte-array-output-stream))
    3859                (compile-and-write-to-stream class-file compiland stream)
    3860                (setf (local-function-class-file local-function) class-file)
    3861                (let ((g (declare-object
    3862                          (load-compiled-function
    3863                           (sys::%get-output-stream-bytes stream)))))
    3864                  (emit-make-compiled-closure-for-labels
    3865                   local-function compiland g))))))))
     3860                local-function compiland g)))))))
    38663861
    38673862(defknown p2-flet-node (t t t) t)
     
    39043899
    39053900(defun p2-lambda (compiland target)
    3906   (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
    3907     (aver (null (compiland-class-file compiland)))
    3908     (cond (*file-compilation*
    3909            (let ((class-file (make-abcl-class-file
    3910                                 :pathname (funcall *pathnames-generator*)
    3911                                 :lambda-list lambda-list)))
    3912        (with-open-class-file (f class-file)
    3913          (compile-and-write-to-stream class-file compiland f))
    3914              (emit-getstatic *this-class*
    3915                    (declare-local-function (make-local-function :class-file
    3916                                                                 class-file))
    3917                    +lisp-object+)))
    3918           (t
    3919            (with-open-stream (stream (sys::%make-byte-array-output-stream))
    3920              (compile-and-write-to-stream (make-abcl-class-file :lambda-list
    3921                                                                 lambda-list)
    3922                                           compiland stream)
    3923              (emit-load-externalized-object (load-compiled-function
    3924                                     (sys::%get-output-stream-bytes stream))))))
    3925     (cond ((null *closure-variables*))  ; Nothing to do.
    3926           ((compiland-closure-register *current-compiland*)
    3927            (duplicate-closure-array *current-compiland*)
    3928            (emit-invokestatic +lisp+ "makeCompiledClosure"
    3929                               (list +lisp-object+ +closure-binding-array+)
    3930                               +lisp-object+))
     3901  (aver (null (compiland-class-file compiland)))
     3902  (cond (*file-compilation*
     3903         (compile-and-write-to-stream compiland)
     3904         (emit-getstatic *this-class*
     3905                         (declare-local-function
     3906                          (make-local-function
     3907                           :class-file (compiland-class-file compiland)))
     3908                         +lisp-object+))
     3909        (t
     3910         (with-open-stream (stream (sys::%make-byte-array-output-stream))
     3911           (compile-and-write-to-stream compiland stream)
     3912           (emit-load-externalized-object (load-compiled-function
     3913                                           (sys::%get-output-stream-bytes stream))))))
     3914  (cond ((null *closure-variables*))    ; Nothing to do.
     3915        ((compiland-closure-register *current-compiland*)
     3916         (duplicate-closure-array *current-compiland*)
     3917         (emit-invokestatic +lisp+ "makeCompiledClosure"
     3918                            (list +lisp-object+ +closure-binding-array+)
     3919                            +lisp-object+))
    39313920                                        ; Stack: compiled-closure
    3932           (t
    3933            (aver nil))) ;; Shouldn't happen.
    3934     (emit-move-from-stack target)))
     3921        (t
     3922         (aver nil))) ;; Shouldn't happen.
     3923
     3924  (emit-move-from-stack target))
    39353925
    39363926(defknown p2-function (t t t) t)
     
    67946784(defmacro with-open-class-file ((var class-file) &body body)
    67956785  `(with-open-file (,var (abcl-class-file-pathname ,class-file)
    6796       :direction :output
    6797       :element-type '(unsigned-byte 8)
    6798       :if-exists :supersede)
     6786                        :direction :output
     6787                        :element-type '(unsigned-byte 8)
     6788                        :if-exists :supersede)
    67996789     ,@body))
    68006790
Note: See TracChangeset for help on using the changeset viewer.