Ignore:
Timestamp:
06/07/10 18:30:36 (11 years ago)
Author:
astalla
Message:

less-reflection branch merged with trunk. verify-load temporarily disabled.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r12650 r12742  
    4141(defvar *output-file-pathname*)
    4242
     43(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
     44  (sanitize-class-name (pathname-name output-file-pathname)))
     45
     46(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
     47  (%format nil "~A_0" (base-classname output-file-pathname)))
     48
    4349(declaim (ftype (function (t) t) compute-classfile-name))
    4450(defun compute-classfile-name (n &optional (output-file-pathname
     
    4652  "Computes the name of the class file associated with number `n'."
    4753  (let ((name
    48          (%format nil "~A-~D"
    49                   (substitute #\_ #\.
    50                               (pathname-name output-file-pathname)) n)))
     54         (sanitize-class-name
     55    (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
    5156    (namestring (merge-pathnames (make-pathname :name name :type "cls")
    5257                                 output-file-pathname))))
     58
     59(defun sanitize-class-name (name)
     60  (let ((name (copy-seq name)))
     61    (dotimes (i (length name))
     62      (declare (type fixnum i))
     63      (when (or (char= (char name i) #\-)
     64    (char= (char name i) #\.)
     65    (char= (char name i) #\Space))
     66        (setf (char name i) #\_)))
     67    name))
     68 
    5369
    5470(declaim (ftype (function () t) next-classfile-name))
     
    7086(declaim (ftype (function (t) t) verify-load))
    7187(defun verify-load (classfile)
    72   (if (> *safety* 0)
    73     (and classfile
     88  #|(if (> *safety* 0)
     89      (and classfile
    7490         (let ((*load-truename* *output-file-pathname*))
    7591           (report-error
    7692            (load-compiled-function classfile))))
    77     t))
     93    t)|#
     94  (declare (ignore classfile))
     95  t)
    7896
    7997(declaim (ftype (function (t) t) process-defconstant))
     
    145163                 (let* ((expr `(lambda ,lambda-list
    146164                                 ,@decls (block ,block-name ,@body)))
     165      (saved-class-number *class-number*)
    147166                        (classfile (next-classfile-name))
    148167                        (internal-compiler-errors nil)
     
    169188                      (setf form
    170189                            `(fset ',name
    171                                    (proxy-preloaded-function ',name ,(file-namestring classfile))
     190           (sys::get-fasl-function *fasl-loader*
     191                 ,saved-class-number)
    172192                                   ,*source-position*
    173193                                   ',lambda-list
     
    226246             (eval form)
    227247             (let* ((expr (function-lambda-expression (macro-function name)))
     248        (saved-class-number *class-number*)
    228249                    (classfile (next-classfile-name)))
    229250         (with-open-file
     
    242263                             `(put ',name 'macroexpand-macro
    243264                                   (make-macro ',name
    244                                                (proxy-preloaded-function
    245                                                 '(macro-function ,name)
    246                                                 ,(file-namestring classfile))))
     265                 (sys::get-fasl-function *fasl-loader* ,saved-class-number)))
    247266                             `(fset ',name
    248267                                    (make-macro ',name
    249                                                 (proxy-preloaded-function
    250                                                  '(macro-function ,name)
    251                                                  ,(file-namestring classfile)))
     268            (sys::get-fasl-function *fasl-loader* ,saved-class-number))
    252269                                    ,*source-position*
    253270                                    ',(third form)))))))))
     
    349366  ;; was already used in verify-load before I used it,
    350367  ;; however, binding *load-truename* isn't fully compliant, I think.
    351   (let ((*load-truename* *output-file-pathname*))
    352     (when compile-time-too
     368  (when compile-time-too
     369    (let ((*load-truename* *output-file-pathname*)
     370    (*fasl-loader* (make-fasl-class-loader
     371        *class-number*
     372        (concatenate 'string "org.armedbear.lisp." (base-classname))
     373        nil)))
    353374      (eval form))))
    354375
     
    367388      (let ((lambda-expression (cadr function-form)))
    368389        (jvm::with-saved-compiler-policy
    369           (let* ((classfile (next-classfile-name))
     390          (let* ((saved-class-number *class-number*)
     391     (classfile (next-classfile-name))
    370392                 (result
    371393      (with-open-file
     
    380402            (cond (compiled-function
    381403                   (setf (getf tail key)
    382                          `(load-compiled-function ,(file-namestring classfile))))
     404       `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
     405;;                         `(load-compiled-function ,(file-namestring classfile))))
    383406                  (t
    384407                   ;; FIXME This should be a warning or error of some sort...
     
    413436      (precompiler:precompile-form form nil *compile-file-environment*)))
    414437  (let* ((expr `(lambda () ,form))
     438   (saved-class-number *class-number*)
    415439         (classfile (next-classfile-name))
    416440         (result
     
    426450    (setf form
    427451          (if compiled-function
    428               `(funcall (load-compiled-function ,(file-namestring classfile)))
     452              `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
    429453              (precompiler:precompile-form form nil *compile-file-environment*)))))
    430454
     
    573597                     :stream out)
    574598              (%stream-terpri out)
    575               ;; Note: Beyond this point, you can't use DUMP-FORM,
    576               ;; because the list of uninterned symbols has been fixed now.
    577               (when *fasl-uninterned-symbols*
    578                 (write (list 'setq '*fasl-uninterned-symbols*
    579                              (coerce (mapcar #'car
    580                                              (nreverse *fasl-uninterned-symbols*))
    581                                      'vector))
    582                        :stream out))
    583               (%stream-terpri out)
    584               ;; we work with a fixed variable name here to work around the
    585               ;; lack of availability of the circle reader in the fasl reader
    586               ;; but it's a toplevel form anyway
    587               (write `(dotimes (i ,*class-number*)
    588                         (function-preload
    589                          (%format nil "~A-~D.cls"
    590                                   ,(substitute #\_ #\. (pathname-name output-file))
    591                                   (1+ i))))
    592                      :stream out
    593                      :circle t)
     599        ;; Note: Beyond this point, you can't use DUMP-FORM,
     600        ;; because the list of uninterned symbols has been fixed now.
     601        (when *fasl-uninterned-symbols*
     602    (write (list 'setq '*fasl-uninterned-symbols*
     603           (coerce (mapcar #'car
     604               (nreverse *fasl-uninterned-symbols*))
     605             'vector))
     606           :stream out))
     607        (%stream-terpri out)
     608
     609        (when (> *class-number* 0)
     610    (generate-loader-function)
     611    (write (list 'setq '*fasl-loader*
     612           `(sys::make-fasl-class-loader
     613             ,*class-number*
     614             ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
    594615              (%stream-terpri out))
    595616
     
    610631                           (merge-pathnames (make-pathname :type type)
    611632                                            output-file)))
    612                  (pathnames ()))
     633                 (pathnames nil)
     634     (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
     635                 output-file))))
     636      (when (probe-file fasl-loader)
     637        (push fasl-loader pathnames))
    613638            (dotimes (i *class-number*)
    614639              (let* ((pathname (compute-classfile-name (1+ i))))
     
    632657                  (namestring output-file) elapsed))))
    633658    (values (truename output-file) warnings-p failure-p)))
     659
     660(defmacro ncase (expr min max &rest clauses)
     661  "A CASE where all test clauses are numbers ranging from a minimum to a maximum."
     662  ;;Expr is subject to multiple evaluation, but since we only use ncase for
     663  ;;fn-index below, let's ignore it.
     664  (let* ((half (floor (/ (- max min) 2)))
     665   (middle (+ min half)))
     666    (if (> (- max min) 10)
     667  `(if (< ,expr ,middle)
     668       (ncase ,expr ,min ,middle ,@(subseq clauses 0 half))
     669       (ncase ,expr ,middle ,max ,@(subseq clauses half)))
     670  `(case ,expr ,@clauses))))
     671
     672(defun generate-loader-function ()
     673  (let* ((basename (base-classname))
     674   (expr `(lambda (fasl-loader fn-index)
     675      (identity fasl-loader) ;;to avoid unused arg
     676      (ncase fn-index 0 ,(1- *class-number*)
     677        ,@(loop
     678       :for i :from 1 :to *class-number*
     679       :collect
     680       (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
     681         `(,(1- i)
     682            (jvm::with-inline-code ()
     683        (jvm::emit 'jvm::aload 1)
     684        (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
     685               nil jvm::+java-object+)
     686        (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
     687        (jvm::emit 'jvm::dup)
     688        (jvm::emit-push-constant-int ,(1- i))
     689        (jvm::emit 'jvm::new ,class)
     690        (jvm::emit 'jvm::dup)
     691        (jvm::emit-invokespecial-init ,class '())
     692        (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
     693               (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
     694        (jvm::emit 'jvm::pop))
     695            t))))))
     696   (classname (fasl-loader-classname))
     697   (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
     698             *output-file-pathname*))))
     699    (jvm::with-saved-compiler-policy
     700  (jvm::with-file-compilation
     701      (with-open-file
     702    (f classfile
     703       :direction :output
     704       :element-type '(unsigned-byte 8)
     705       :if-exists :supersede)
     706        (jvm:compile-defun nil expr nil
     707         classfile f nil))))))
    634708
    635709(defun compile-file-if-needed (input-file &rest allargs &key force-compile
Note: See TracChangeset for help on using the changeset viewer.