Changeset 13489


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

Code duplication refactoring.

File:
1 edited

Legend:

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

    r13488 r13489  
    40284028    (emit-move-from-stack target)))
    40294029
    4030 (defun compile-and-write-to-stream (compiland &optional stream)
    4031   "Creates a class file associated with `compiland`, writing it
    4032 either to stream or the pathname of the class file if `stream' is NIL."
    4033   (let* ((pathname (funcall *pathnames-generator*))
    4034          (class-file (make-abcl-class-file :pathname pathname)))
     4030
     4031(defun compile-local-function (local-function)
     4032  (let* ((compiland (local-function-compiland local-function))
     4033         (pathname (funcall *pathnames-generator*))
     4034         (class-file (make-abcl-class-file :pathname pathname))
     4035         (stream (unless *file-compilation*
     4036                   (sys::%make-byte-array-output-stream))))
    40354037    (setf (compiland-class-file compiland) class-file)
    40364038    (with-open-stream (f (or stream
     
    40424044          (with-saved-compiler-policy
    40434045              (p2-compiland compiland)
    4044             (finish-class (compiland-class-file compiland) f)))))))
    4045 
    4046 (defknown p2-flet-process-compiland (t) t)
    4047 (defun p2-flet-process-compiland (local-function)
    4048   (let* ((compiland (local-function-compiland local-function)))
    4049     (cond (*file-compilation*
    4050            (compile-and-write-to-stream compiland))
    4051           (t
    4052            (with-open-stream (stream (sys::%make-byte-array-output-stream))
    4053              (compile-and-write-to-stream compiland stream)
    4054              (let ((bytes (sys::%get-output-stream-bytes stream)))
    4055                (sys::put-memory-function *memory-class-loader*
    4056                                          (class-name-internal
    4057                                           (abcl-class-file-class-name
    4058                                            (compiland-class-file compiland)))
    4059                    bytes)))))))
    4060 
    4061 (defknown p2-labels-process-compiland (t) t)
    4062 (defun p2-labels-process-compiland (local-function)
    4063   (let* ((compiland (local-function-compiland local-function)))
    4064     (cond
    4065       (*file-compilation*
    4066        (compile-and-write-to-stream compiland))
    4067       (t
    4068        (with-open-stream (stream (sys::%make-byte-array-output-stream))
    4069          (compile-and-write-to-stream compiland stream)
    4070          (let* ((bytes (sys::%get-output-stream-bytes stream)))
    4071            (sys::put-memory-function *memory-class-loader*
    4072                                      (class-name-internal
    4073                                       (abcl-class-file-class-name
    4074                                        (compiland-class-file compiland)))
    4075                                      bytes)))))))
     4046            (finish-class (compiland-class-file compiland) f)))))
     4047    (when stream
     4048      (let ((bytes (sys::%get-output-stream-bytes stream)))
     4049        (sys::put-memory-function *memory-class-loader*
     4050                                  (class-name-internal
     4051                                   (abcl-class-file-class-name
     4052                                    (compiland-class-file compiland)))
     4053                                  bytes)))))
    40764054
    40774055(defknown p2-flet-node (t t t) t)
     
    40834061         (body (cddr form)))
    40844062    (dolist (local-function local-functions)
    4085       (p2-flet-process-compiland local-function))
     4063      (compile-local-function local-function))
    40864064    (dolist (local-function local-functions)
    40874065      (push local-function *local-functions*))
     
    41014079      (push local-function *local-functions*))
    41024080    (dolist (local-function local-functions)
    4103       (p2-labels-process-compiland local-function))
     4081      (compile-local-function local-function))
    41044082    (dolist (special (labels-free-specials block))
    41054083      (push special *visible-variables*))
     
    41084086
    41094087(defun p2-lambda (local-function target)
    4110   (let ((compiland (local-function-compiland local-function)))
    4111     (cond (*file-compilation*
    4112            (compile-and-write-to-stream compiland)
    4113            (multiple-value-bind
    4114                  (class field)
    4115                (local-function-class-and-field local-function)
    4116              (emit-getstatic class field +lisp-object+)))
    4117           (t
    4118            (with-open-stream (stream (sys::%make-byte-array-output-stream))
    4119              (compile-and-write-to-stream compiland stream)
    4120              (let ((bytes (sys::%get-output-stream-bytes stream)))
    4121                (sys::put-memory-function *memory-class-loader*
    4122                                          (class-name-internal
    4123                                           (abcl-class-file-class-name
    4124                                            (compiland-class-file compiland)))
    4125                                          bytes)
    4126                (multiple-value-bind
    4127                      (class field)
    4128                    (local-function-class-and-field local-function)
    4129                  (emit-getstatic class field +lisp-object+))))))
    4130     (cond ((null *closure-variables*))  ; Nothing to do.
    4131           ((compiland-closure-register *current-compiland*)
    4132            (duplicate-closure-array *current-compiland*)
    4133            (emit-invokestatic +lisp+ "makeCompiledClosure"
    4134                               (list +lisp-object+ +closure-binding-array+)
    4135                               +lisp-object+))
    4136                                         ; Stack: compiled-closure
    4137           (t
    4138            (aver nil)))) ;; Shouldn't happen.
    4139 
     4088  (compile-local-function local-function)
     4089  (multiple-value-bind
     4090        (class field)
     4091      (local-function-class-and-field local-function)
     4092    (emit-getstatic class field +lisp-object+))
     4093  (when (compiland-closure-register *current-compiland*)
     4094    (duplicate-closure-array *current-compiland*)
     4095    (emit-invokestatic +lisp+ "makeCompiledClosure"
     4096                       (list +lisp-object+ +closure-binding-array+)
     4097                       +lisp-object+))
    41404098  (emit-move-from-stack target))
    41414099
Note: See TracChangeset for help on using the changeset viewer.