[armedbear-cvs] r11719 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Mar 29 07:56:55 UTC 2009
Author: ehuelsmann
Date: Sun Mar 29 03:56:52 2009
New Revision: 11719
Log:
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>
Modified:
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-file.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-file.lisp Sun Mar 29 03:56:52 2009
@@ -428,23 +428,24 @@
(*explain* *explain*)
(jvm::*functions-defined-in-current-file* '())
(*fbound-names* '()))
- (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
- (%stream-terpri out)
- (let ((*package* (find-package '#:cl)))
- (write (list 'init-fasl :version *fasl-version*) :stream out)
+ (jvm::with-file-compilation
+ (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
(%stream-terpri out)
- (write (list 'setq '*source* *compile-file-truename*) :stream out)
- (%stream-terpri out))
- (loop
- (let* ((*source-position* (file-position in))
- (jvm::*source-line-number* (stream-line-number in))
- (form (read in nil in))
- (*compiler-error-context* form))
- (when (eq form in)
- (return))
- (process-toplevel-form form out nil)))
- (dolist (name *fbound-names*)
- (fmakunbound name))))
+ (let ((*package* (find-package '#:cl)))
+ (write (list 'init-fasl :version *fasl-version*) :stream out)
+ (%stream-terpri out)
+ (write (list 'setq '*source* *compile-file-truename*) :stream out)
+ (%stream-terpri out))
+ (loop
+ (let* ((*source-position* (file-position in))
+ (jvm::*source-line-number* (stream-line-number in))
+ (form (read in nil in))
+ (*compiler-error-context* form))
+ (when (eq form in)
+ (return))
+ (process-toplevel-form form out nil)))
+ (dolist (name *fbound-names*)
+ (fmakunbound name)))))
(cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
(setf warnings-p nil failure-p nil))
((zerop (+ jvm::*errors* jvm::*warnings*))
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Mar 29 03:56:52 2009
@@ -2068,7 +2068,7 @@
(declare-with-hashtable
symbol *declared-symbols* ht g
(cond ((null (symbol-package symbol))
- (setf g (if *compile-file-truename*
+ (setf g (if *file-compilation*
(declare-object-as-string symbol +lisp-symbol+
+lisp-symbol-class+)
(declare-object symbol +lisp-symbol+
@@ -2300,7 +2300,7 @@
(defknown declare-instance (t) t)
(defun declare-instance (obj)
- (aver (not (null *compile-file-truename*)))
+ (aver (not (null *file-compilation*)))
(aver (or (structure-object-p obj) (standard-object-p obj)
(java:java-object-p obj)))
(let* ((g (symbol-name (gensym "INSTANCE")))
@@ -2469,13 +2469,13 @@
(emit 'getstatic *this-class*
(declare-object-as-string form) +lisp-object+))
((stringp form)
- (if *compile-file-truename*
+ (if *file-compilation*
(emit 'getstatic *this-class*
(declare-string form) +lisp-simple-string+)
(emit 'getstatic *this-class*
(declare-object form) +lisp-object+)))
((vectorp form)
- (if *compile-file-truename*
+ (if *file-compilation*
(emit 'getstatic *this-class*
(declare-object-as-string form) +lisp-object+)
(emit 'getstatic *this-class*
@@ -2487,24 +2487,24 @@
(emit 'getstatic *this-class*
(declare-object form) +lisp-object+))
((pathnamep form)
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-object-as-string form)
(declare-object form))))
(emit 'getstatic *this-class* g +lisp-object+)))
((packagep form)
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-package form)
(declare-object form))))
(emit 'getstatic *this-class* g +lisp-object+)))
((or (structure-object-p form)
(standard-object-p form)
(java:java-object-p form))
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-instance form)
(declare-object form))))
(emit 'getstatic *this-class* g +lisp-object+)))
(t
- (if *compile-file-truename*
+ (if *file-compilation*
(error "COMPILE-CONSTANT unhandled case ~S" form)
(emit 'getstatic *this-class*
(declare-object form) +lisp-object+))))
@@ -3003,7 +3003,7 @@
(emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+)
(aload 0)))
((null (symbol-package op))
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-object-as-string op)
(declare-object op))))
(emit 'getstatic *this-class* g +lisp-object+)))
@@ -3175,7 +3175,7 @@
(compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil))
(t
(dformat t "compile-local-function-call default case~%")
- (let* ((g (if *compile-file-truename*
+ (let* ((g (if *file-compilation*
(declare-local-function local-function)
(declare-object (local-function-function local-function)))))
(emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function
@@ -4603,7 +4603,7 @@
(let ((NEXT (gensym)))
(aload tag-register)
(emit 'getstatic *this-class*
- (if *compile-file-truename*
+ (if *file-compilation*
(declare-object-as-string (tag-label tag))
(declare-object (tag-label tag)))
+lisp-object+)
@@ -4913,7 +4913,7 @@
(emit-move-from-stack target))))
(defun p2-load-time-value (form target representation)
- (cond (*compile-file-truename*
+ (cond (*file-compilation*
(emit 'getstatic *this-class*
(declare-load-time-value (second form)) +lisp-object+)
(fix-boxing representation nil)
@@ -4986,13 +4986,13 @@
(emit 'getstatic *this-class* (declare-symbol obj) +lisp-symbol+))
(t
;; An uninterned symbol.
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-object-as-string obj)
(declare-object obj))))
(emit 'getstatic *this-class* g +lisp-object+))))
(emit-move-from-stack target representation)))
((listp obj)
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-object-as-string obj)
(declare-object obj))))
(emit 'getstatic *this-class* g +lisp-object+)
@@ -5082,8 +5082,8 @@
(defun p2-flet-process-compiland (local-function)
(let* ((compiland (local-function-compiland local-function))
(lambda-list (cadr (compiland-lambda-expression compiland))))
- (cond (*compile-file-truename*
- (let* ((pathname (sys::next-classfile-name))
+ (cond (*file-compilation*
+ (let* ((pathname (funcall *pathnames-generator*))
(class-file (make-class-file :pathname pathname
:lambda-list lambda-list)))
(set-compiland-and-write-class-file class-file compiland)
@@ -5108,8 +5108,8 @@
(defun p2-labels-process-compiland (local-function)
(let* ((compiland (local-function-compiland local-function))
(lambda-list (cadr (compiland-lambda-expression compiland))))
- (cond (*compile-file-truename*
- (let* ((pathname (sys::next-classfile-name))
+ (cond (*file-compilation*
+ (let* ((pathname (funcall *pathnames-generator*))
(class-file (make-class-file :pathname pathname
:lambda-list lambda-list)))
(set-compiland-and-write-class-file class-file compiland)
@@ -5177,9 +5177,9 @@
(defun p2-lambda (compiland target)
(let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
(aver (null (compiland-class-file compiland)))
- (cond (*compile-file-truename*
+ (cond (*file-compilation*
(setf (compiland-class-file compiland)
- (make-class-file :pathname (sys::next-classfile-name)
+ (make-class-file :pathname (funcall *pathnames-generator*)
:lambda-list lambda-list))
(let ((class-file (compiland-class-file compiland)))
(compile-and-write-to-file class-file compiland)
@@ -5187,7 +5187,7 @@
(declare-local-function (make-local-function :class-file class-file))
+lisp-object+)))
(t
- (let ((pathname (make-temp-file)))
+ (let ((pathname (funcall *pathnames-generator*)))
(setf (compiland-class-file compiland)
(make-class-file :pathname pathname
:lambda-list lambda-list))
@@ -5225,7 +5225,7 @@
(compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)
)
(t
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-local-function local-function)
(declare-object (local-function-function local-function)))))
(emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function
@@ -5262,7 +5262,7 @@
(compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)
)
(t
- (let ((g (if *compile-file-truename*
+ (let ((g (if *file-compilation*
(declare-local-function local-function)
(declare-object (local-function-function local-function)))))
(emit 'getstatic *this-class*
@@ -5271,7 +5271,7 @@
(emit 'getstatic *this-class*
(declare-setf-function name) +lisp-object+)
(emit-move-from-stack target))
- ((and (null *compile-file-truename*)
+ ((and (null *file-compilation*)
(fboundp name)
(fdefinition name))
(emit 'getstatic *this-class*
@@ -7532,7 +7532,7 @@
(defun compile-special-reference (name target representation)
(when (constantp name)
(let ((value (symbol-value name)))
- (when (or (null *compile-file-truename*)
+ (when (or (null *file-compilation*)
(stringp value)
(numberp value)
(packagep value))
@@ -8166,7 +8166,7 @@
(class-file-lambda-list class-file))))
(pool-name "Code") ; Must be in pool!
- (when *compile-file-truename*
+ (when *file-compilation*
(pool-name "SourceFile") ; Must be in pool!
(pool-name (file-namestring *compile-file-truename*)))
(when (and (boundp '*source-line-number*)
@@ -8200,7 +8200,7 @@
(write-method method stream))
(write-method constructor stream)
;; attributes count
- (cond (*compile-file-truename*
+ (cond (*file-compilation*
;; attributes count
(write-u2 1 stream)
;; attributes table
Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun Mar 29 03:56:52 2009
@@ -408,8 +408,18 @@
(t
(setf (variable-ignorable-p variable) t))))))))
+(defvar *file-compilation* nil)
+(defvar *pathnames-generator* #'make-temp-file)
+
(defun compile (name &optional definition)
- (jvm-compile name definition))
+ (let ((*file-compilation* nil)
+ (*pathnames-generator* #'make-temp-file))
+ (jvm-compile name definition)))
+
+(defmacro with-file-compilation (&body body)
+ `(let ((*file-compilation* t)
+ (*pathnames-generator* #'sys::next-classfile-name))
+ , at body))
(defun finalize-generic-functions ()
(dolist (sym '(make-instance
Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sun Mar 29 03:56:52 2009
@@ -1124,7 +1124,7 @@
(let* ((block-name (fdefinition-block-name name))
(lambda-expression `(named-lambda ,name ,lambda-list , at decls ,@(when doc `(,doc))
(block ,block-name , at body))))
- (cond (*compile-file-truename*
+ (cond (*file-compilation*
`(fset ',name ,lambda-expression))
(t
(when (and env (empty-environment-p env))
More information about the armedbear-cvs
mailing list