Changeset 11719


Ignore:
Timestamp:
03/29/09 07:56:52 (15 years ago)
Author:
ehuelsmann
Message:

Fix COMPILE called inside COMPILE-FILE: COMPILE doesn't compile to a file,
so use a separate indicator for what our compilation purpose is.

Found by: Don Cohen <don-sourceforge-xxx at isis dot cs3 dash inc dot com>

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
4 edited

Legend:

Unmodified
Added
Removed

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

    r11675 r11719  
    429429                  (jvm::*functions-defined-in-current-file* '())
    430430                  (*fbound-names* '()))
    431               (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    432               (%stream-terpri out)
    433               (let ((*package* (find-package '#:cl)))
    434                 (write (list 'init-fasl :version *fasl-version*) :stream out)
     431              (jvm::with-file-compilation
     432                (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    435433                (%stream-terpri out)
    436                 (write (list 'setq '*source* *compile-file-truename*) :stream out)
    437                 (%stream-terpri out))
    438               (loop
    439                 (let* ((*source-position* (file-position in))
    440                        (jvm::*source-line-number* (stream-line-number in))
    441                        (form (read in nil in))
    442                        (*compiler-error-context* form))
    443                   (when (eq form in)
    444                     (return))
    445                   (process-toplevel-form form out nil)))
    446               (dolist (name *fbound-names*)
    447                 (fmakunbound name))))
     434                (let ((*package* (find-package '#:cl)))
     435                  (write (list 'init-fasl :version *fasl-version*) :stream out)
     436                  (%stream-terpri out)
     437                  (write (list 'setq '*source* *compile-file-truename*) :stream out)
     438                  (%stream-terpri out))
     439                (loop
     440                   (let* ((*source-position* (file-position in))
     441                          (jvm::*source-line-number* (stream-line-number in))
     442                          (form (read in nil in))
     443                          (*compiler-error-context* form))
     444                     (when (eq form in)
     445                       (return))
     446                     (process-toplevel-form form out nil)))
     447                (dolist (name *fbound-names*)
     448                  (fmakunbound name)))))
    448449          (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
    449450                 (setf warnings-p nil failure-p nil))

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

    r11709 r11719  
    20692069   symbol *declared-symbols* ht g
    20702070   (cond ((null (symbol-package symbol))
    2071     (setf g (if *compile-file-truename*
     2071    (setf g (if *file-compilation*
    20722072          (declare-object-as-string symbol +lisp-symbol+
    20732073                                                +lisp-symbol-class+)
    … …  
    23012301(defknown declare-instance (t) t)
    23022302(defun declare-instance (obj)
    2303   (aver (not (null *compile-file-truename*)))
     2303  (aver (not (null *file-compilation*)))
    23042304  (aver (or (structure-object-p obj) (standard-object-p obj)
    23052305            (java:java-object-p obj)))
    … …  
    24702470               (declare-object-as-string form) +lisp-object+))
    24712471        ((stringp form)
    2472          (if *compile-file-truename*
     2472         (if *file-compilation*
    24732473             (emit 'getstatic *this-class*
    24742474                   (declare-string form) +lisp-simple-string+)
    … …  
    24762476                   (declare-object form) +lisp-object+)))
    24772477        ((vectorp form)
    2478          (if *compile-file-truename*
     2478         (if *file-compilation*
    24792479             (emit 'getstatic *this-class*
    24802480                   (declare-object-as-string form) +lisp-object+)
    … …  
    24882488               (declare-object form) +lisp-object+))
    24892489        ((pathnamep form)
    2490          (let ((g (if *compile-file-truename*
     2490         (let ((g (if *file-compilation*
    24912491                      (declare-object-as-string form)
    24922492                      (declare-object form))))
    24932493           (emit 'getstatic *this-class* g +lisp-object+)))
    24942494        ((packagep form)
    2495          (let ((g (if *compile-file-truename*
     2495         (let ((g (if *file-compilation*
    24962496                      (declare-package form)
    24972497                      (declare-object form))))
    … …  
    25002500             (standard-object-p form)
    25012501             (java:java-object-p form))
    2502          (let ((g (if *compile-file-truename*
     2502         (let ((g (if *file-compilation*
    25032503                      (declare-instance form)
    25042504                      (declare-object form))))
    25052505           (emit 'getstatic *this-class* g +lisp-object+)))
    25062506        (t
    2507          (if *compile-file-truename*
     2507         (if *file-compilation*
    25082508             (error "COMPILE-CONSTANT unhandled case ~S" form)
    25092509             (emit 'getstatic *this-class*
    … …  
    30043004                 (aload 0)))
    30053005            ((null (symbol-package op))
    3006              (let ((g (if *compile-file-truename*
     3006             (let ((g (if *file-compilation*
    30073007                          (declare-object-as-string op)
    30083008                          (declare-object op))))
    … …  
    31763176          (t
    31773177           (dformat t "compile-local-function-call default case~%")
    3178            (let* ((g (if *compile-file-truename*
     3178           (let* ((g (if *file-compilation*
    31793179                         (declare-local-function local-function)
    31803180                         (declare-object (local-function-function local-function)))))
    … …  
    46044604            (aload tag-register)
    46054605            (emit 'getstatic *this-class*
    4606                   (if *compile-file-truename*
     4606                  (if *file-compilation*
    46074607                      (declare-object-as-string (tag-label tag))
    46084608                      (declare-object (tag-label tag)))
    … …  
    49144914
    49154915(defun p2-load-time-value (form target representation)
    4916   (cond (*compile-file-truename*
     4916  (cond (*file-compilation*
    49174917         (emit 'getstatic *this-class*
    49184918               (declare-load-time-value (second form)) +lisp-object+)
    … …  
    49874987                   (t
    49884988                    ;; An uninterned symbol.
    4989                     (let ((g (if *compile-file-truename*
     4989                    (let ((g (if *file-compilation*
    49904990                                 (declare-object-as-string obj)
    49914991                                 (declare-object obj))))
    … …  
    49934993             (emit-move-from-stack target representation)))
    49944994          ((listp obj)
    4995            (let ((g (if *compile-file-truename*
     4995           (let ((g (if *file-compilation*
    49964996                        (declare-object-as-string obj)
    49974997                        (declare-object obj))))
    … …  
    50835083  (let* ((compiland (local-function-compiland local-function))
    50845084         (lambda-list (cadr (compiland-lambda-expression compiland))))
    5085     (cond (*compile-file-truename*
    5086            (let* ((pathname (sys::next-classfile-name))
     5085    (cond (*file-compilation*
     5086           (let* ((pathname (funcall *pathnames-generator*))
    50875087                  (class-file (make-class-file :pathname pathname
    50885088                                               :lambda-list lambda-list)))
    … …  
    51095109  (let* ((compiland (local-function-compiland local-function))
    51105110         (lambda-list (cadr (compiland-lambda-expression compiland))))
    5111     (cond (*compile-file-truename*
    5112            (let* ((pathname (sys::next-classfile-name))
     5111    (cond (*file-compilation*
     5112           (let* ((pathname (funcall *pathnames-generator*))
    51135113                  (class-file (make-class-file :pathname pathname
    51145114                                               :lambda-list lambda-list)))
    … …  
    51785178  (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
    51795179    (aver (null (compiland-class-file compiland)))
    5180     (cond (*compile-file-truename*
     5180    (cond (*file-compilation*
    51815181           (setf (compiland-class-file compiland)
    5182                  (make-class-file :pathname (sys::next-classfile-name)
     5182                 (make-class-file :pathname (funcall *pathnames-generator*)
    51835183                                  :lambda-list lambda-list))
    51845184           (let ((class-file (compiland-class-file compiland)))
    … …  
    51885188                   +lisp-object+)))
    51895189          (t
    5190            (let ((pathname (make-temp-file)))
     5190           (let ((pathname (funcall *pathnames-generator*)))
    51915191             (setf (compiland-class-file compiland)
    51925192                   (make-class-file :pathname pathname
    … …  
    52265226                         )
    52275227                        (t
    5228                          (let ((g (if *compile-file-truename*
     5228                         (let ((g (if *file-compilation*
    52295229                                      (declare-local-function local-function)
    52305230                                      (declare-object (local-function-function local-function)))))
    … …  
    52635263                         )
    52645264                        (t
    5265                          (let ((g (if *compile-file-truename*
     5265                         (let ((g (if *file-compilation*
    52665266                                      (declare-local-function local-function)
    52675267                                      (declare-object (local-function-function local-function)))))
    … …  
    52725272                        (declare-setf-function name) +lisp-object+)
    52735273                  (emit-move-from-stack target))
    5274                  ((and (null *compile-file-truename*)
     5274                 ((and (null *file-compilation*)
    52755275                       (fboundp name)
    52765276                       (fdefinition name))
    … …  
    75337533  (when (constantp name)
    75347534    (let ((value (symbol-value name)))
    7535       (when (or (null *compile-file-truename*)
     7535      (when (or (null *file-compilation*)
    75367536                (stringp value)
    75377537                (numberp value)
    … …  
    81678167    (pool-name "Code") ; Must be in pool!
    81688168
    8169     (when *compile-file-truename*
     8169    (when *file-compilation*
    81708170      (pool-name "SourceFile") ; Must be in pool!
    81718171      (pool-name (file-namestring *compile-file-truename*)))
    … …  
    82018201      (write-method constructor stream)
    82028202      ;; attributes count
    8203       (cond (*compile-file-truename*
     8203      (cond (*file-compilation*
    82048204             ;; attributes count
    82058205             (write-u2 1 stream)

  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r11708 r11719  
    409409                 (setf (variable-ignorable-p variable) t))))))))
    410410
     411(defvar *file-compilation* nil)
     412(defvar *pathnames-generator* #'make-temp-file)
     413
    411414(defun compile (name &optional definition)
    412   (jvm-compile name definition))
     415  (let ((*file-compilation* nil)
     416        (*pathnames-generator* #'make-temp-file))
     417    (jvm-compile name definition)))
     418
     419(defmacro with-file-compilation (&body body)
     420  `(let ((*file-compilation* t)
     421         (*pathnames-generator* #'sys::next-classfile-name))
     422     ,@body))
    413423
    414424(defun finalize-generic-functions ()

  • trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

    r11712 r11719  
    11251125           (lambda-expression `(named-lambda ,name ,lambda-list ,@decls ,@(when doc `(,doc))
    11261126                                             (block ,block-name ,@body))))
    1127       (cond (*compile-file-truename*
     1127      (cond (*file-compilation*
    11281128             `(fset ',name ,lambda-expression))
    11291129            (t
Note: See TracChangeset for help on using the changeset viewer.