[armedbear-cvs] r12620 - trunk/abcl/src/org/armedbear/lisp
Mark Evenson
mevenson at common-lisp.net
Fri Apr 16 13:41:22 UTC 2010
Author: mevenson
Date: Fri Apr 16 09:41:21 2010
New Revision: 12620
Log:
Use interpreted form in a FASL if compliation fails.
INTERNAL-COMPILER-ERROR now signals that the form being compiled
should be written to the init FASL to be interpreted rather than being
the object of a SYSTEm:PROXY-PRELOADED-FUNCTION. A further
optimization of this strategy would be to actually not include the
failed compilation unit in the packed FASL.
This patches behavior for stack inconsistencies such as present in
ticket #89.
Added:
trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java
Modified:
trunk/abcl/src/org/armedbear/lisp/StandardClass.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/make_condition.java
Added: trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/InternalCompilerError.java Fri Apr 16 09:41:21 2010
@@ -0,0 +1,66 @@
+/*
+ * InternalCompilerError.java
+ *
+ * Copyright (C) 2005 Peter Graves
+ * $Id: CompilerError.java 12288 2009-11-29 22:00:12Z vvoutilainen $
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module. An independent module is a module which is not derived from
+ * or based on this library. If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so. If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package org.armedbear.lisp;
+
+import static org.armedbear.lisp.Lisp.*;
+
+public class InternalCompilerError extends Condition
+{
+ public InternalCompilerError(LispObject initArgs)
+ {
+ super(initArgs);
+ }
+
+ @Override
+ public LispObject typeOf()
+ {
+ return Symbol.INTERNAL_COMPILER_ERROR;
+ }
+
+ @Override
+ public LispObject classOf()
+ {
+ return StandardClass.INTERNAL_COMPILER_ERROR;
+ }
+
+ @Override
+ public LispObject typep(LispObject type)
+ {
+ if (type == Symbol.INTERNAL_COMPILER_ERROR)
+ return T;
+ if (type == StandardClass.INTERNAL_COMPILER_ERROR)
+ return T;
+ return super.typep(type);
+ }
+}
Modified: trunk/abcl/src/org/armedbear/lisp/StandardClass.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/StandardClass.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/StandardClass.java Fri Apr 16 09:41:21 2010
@@ -494,6 +494,9 @@
public static final StandardClass COMPILER_ERROR =
addStandardClass(Symbol.COMPILER_ERROR, list(CONDITION));
+
+ public static final StandardClass INTERNAL_COMPILER_ERROR =
+ addStandardClass(Symbol.INTERNAL_COMPILER_ERROR, list(CONDITION));
public static final StandardClass COMPILER_UNSUPPORTED_FEATURE_ERROR =
addStandardClass(Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR,
@@ -553,6 +556,8 @@
CLASS.setCPL(CLASS, STANDARD_OBJECT, BuiltInClass.CLASS_T);
COMPILER_ERROR.setCPL(COMPILER_ERROR, CONDITION, STANDARD_OBJECT,
BuiltInClass.CLASS_T);
+ INTERNAL_COMPILER_ERROR.setCPL(INTERNAL_COMPILER_ERROR, CONDITION, STANDARD_OBJECT,
+ BuiltInClass.CLASS_T);
COMPILER_UNSUPPORTED_FEATURE_ERROR.setCPL(COMPILER_UNSUPPORTED_FEATURE_ERROR,
CONDITION, STANDARD_OBJECT,
BuiltInClass.CLASS_T);
@@ -675,6 +680,7 @@
ARITHMETIC_ERROR.finalizeClass();
CELL_ERROR.finalizeClass();
COMPILER_ERROR.finalizeClass();
+ INTERNAL_COMPILER_ERROR.finalizeClass();
COMPILER_UNSUPPORTED_FEATURE_ERROR.finalizeClass();
CONDITION.finalizeClass();
CONTROL_ERROR.finalizeClass();
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Fri Apr 16 09:41:21 2010
@@ -2892,6 +2892,8 @@
PACKAGE_EXT.addExternalSymbol("NIL-VECTOR");
public static final Symbol COMPILER_ERROR =
PACKAGE_EXT.addExternalSymbol("COMPILER-ERROR");
+ public static final Symbol INTERNAL_COMPILER_ERROR =
+ PACKAGE_EXT.addExternalSymbol("INTERNAL-COMPILER-ERROR");
public static final Symbol COMPILER_UNSUPPORTED_FEATURE_ERROR =
PACKAGE_EXT.addExternalSymbol("COMPILER-UNSUPPORTED-FEATURE-ERROR");
public static final Symbol MAILBOX =
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 Fri Apr 16 09:41:21 2010
@@ -145,18 +145,26 @@
(let* ((expr `(lambda ,lambda-list
, at decls (block ,block-name , at body)))
(classfile (next-classfile-name))
+ (compilation-failure-p nil)
(result (with-open-file
(f classfile
:direction :output
:element-type '(unsigned-byte 8)
:if-exists :supersede)
- (report-error
- (jvm:compile-defun name expr nil
- classfile f nil))))
- (compiled-function (verify-load classfile)))
+ (handler-bind
+ ((internal-compiler-error
+ #'(lambda (e)
+ (setf compilation-failure-p e)
+ (continue))))
+ (report-error
+ (jvm:compile-defun name expr nil
+ classfile f nil)))))
+ (compiled-function (and (not compilation-failure-p)
+ (verify-load classfile))))
(declare (ignore result))
(cond
- (compiled-function
+ ((and (not compilation-failure-p)
+ compiled-function)
(setf form
`(fset ',name
(proxy-preloaded-function ',name ,(file-namestring classfile))
@@ -169,6 +177,9 @@
;; FIXME Should be a warning or error of some sort...
(format *error-output*
"; Unable to compile function ~A~%" name)
+ (when compilation-failure-p
+ (format *error-output*
+ "; ~A~%" compilation-failure-p))
(let ((precompiled-function
(precompiler:precompile-form expr nil
*compile-file-environment*)))
@@ -513,18 +524,19 @@
(*fasl-stream* out)
*forms-for-output*)
(jvm::with-saved-compiler-policy
- (jvm::with-file-compilation
- (handler-bind ((style-warning #'(lambda (c)
- (setf warnings-p t)
- ;; let outer handlers
- ;; do their thing
- (signal c)
- ;; prevent the next
- ;; handler from running:
- ;; we're a WARNING subclass
- (continue)))
- ((or warning
- compiler-error) #'(lambda (c)
+ (jvm::with-file-compilation
+ (handler-bind ((style-warning
+ #'(lambda (c)
+ (setf warnings-p t)
+ ;; let outer handlers do their thing
+ (signal c)
+ ;; prevent the next handler
+ ;; from running: we're a
+ ;; WARNING subclass
+ (continue)))
+ ((or warning
+ compiler-error)
+ #'(lambda (c)
(declare (ignore c))
(setf warnings-p t
failure-p t))))
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-error.lisp Fri Apr 16 09:41:21 2010
@@ -35,6 +35,7 @@
compiler-style-warn
compiler-warn
compiler-error
+ internal-compiler-error
compiler-unsupported))
(defvar *compiler-error-context* nil)
@@ -54,6 +55,11 @@
:format-control format-control
:format-arguments format-arguments))
+(defun internal-compiler-error (format-control &rest format-arguments)
+ (signal 'internal-compiler-error
+ :format-control format-control
+ :format-arguments format-arguments))
+
(defun compiler-unsupported (format-control &rest format-arguments)
(error 'compiler-unsupported-feature-error
:format-control format-control
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 Fri Apr 16 09:41:21 2010
@@ -1342,7 +1342,9 @@
(when instruction-depth
(unless (= (the fixnum instruction-depth) (the fixnum (+ depth instruction-stack)))
(format t "~&Stack inconsistency at index ~D: found ~S, expected ~S.~%"
- i instruction-depth (+ depth instruction-stack)))
+ i instruction-depth (+ depth instruction-stack))
+ (internal-compiler-error "Stack inconsistency detected in ~A."
+ (compiland-name *current-compiland*)))
(return-from walk-code))
(let ((opcode (instruction-opcode instruction)))
(setf depth (+ depth instruction-stack))
Modified: trunk/abcl/src/org/armedbear/lisp/make_condition.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/make_condition.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/make_condition.java Fri Apr 16 09:41:21 2010
@@ -121,6 +121,8 @@
if (symbol == Symbol.COMPILER_ERROR)
return new CompilerError(initArgs);
+ if (symbol == Symbol.INTERNAL_COMPILER_ERROR)
+ return new InternalCompilerError(initArgs);
if (symbol == Symbol.COMPILER_UNSUPPORTED_FEATURE_ERROR)
return new CompilerUnsupportedFeatureError(initArgs);
More information about the armedbear-cvs
mailing list