[armedbear-cvs] r11924 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Fri May 22 08:37:28 UTC 2009
Author: ehuelsmann
Date: Fri May 22 04:37:09 2009
New Revision: 11924
Log:
Implement compilation of closures with non-empty
lexical environments (Part 1 [of 2]): Variables.
Modified:
trunk/abcl/src/org/armedbear/lisp/Environment.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Environment.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Environment.java Fri May 22 04:37:09 2009
@@ -328,4 +328,23 @@
return result.nreverse();
}
};
+
+ // ### environment-all-variables
+ private static final Primitive ENVIRONMENT_ALL_VARS =
+ new Primitive("environment-all-variables", PACKAGE_SYS, true, "environment")
+ {
+ @Override
+ public LispObject execute(LispObject arg) throws ConditionThrowable
+ {
+ Environment env = checkEnvironment(arg);
+ LispObject result = NIL;
+ for (Binding binding = env.vars;
+ binding != null; binding = binding.next)
+ if (binding.specialp)
+ result = result.push(binding.symbol);
+ else
+ result = result.push(new Cons(binding.symbol, binding.value));
+ return result.nreverse();
+ }
+ };
}
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Fri May 22 04:37:09 2009
@@ -1798,6 +1798,16 @@
}
};
+ // ### symbol-macro-p
+ private static final Primitive SYMBOL_MACRO_P =
+ new Primitive("symbol-macro-p", PACKAGE_SYS, true, "value")
+ {
+ @Override
+ public LispObject execute(LispObject arg) throws ConditionThrowable
+ {
+ return (arg instanceof SymbolMacro) ? T : NIL;
+ }
+ };
// ### %defparameter
private static final Primitive _DEFPARAMETER =
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 May 22 04:37:09 2009
@@ -236,6 +236,7 @@
(defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString")
(defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;")
(defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;")
+(defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment")
(defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;")
(defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw")
(defconstant +lisp-return-class+ "org/armedbear/lisp/Return")
@@ -4187,6 +4188,19 @@
(emit 'aaload)
(emit-swap representation nil)
(emit 'putfield +closure-binding-class+ "value" +lisp-object+))
+ ((variable-environment variable)
+ (assert (not *file-compilation*))
+ (emit 'getstatic *this-class*
+ (declare-object (variable-environment variable)
+ +lisp-environment+
+ +lisp-environment-class+)
+ +lisp-environment+)
+ (emit 'swap)
+ (emit-push-variable-name variable)
+ (emit 'swap)
+ (emit-invokevirtual +lisp-environment-class+ "rebind"
+ (list +lisp-symbol+ +lisp-object+)
+ nil))
(t
(assert nil))))))
@@ -4217,6 +4231,17 @@
(emit-push-constant-int (variable-closure-index variable))
(emit 'aaload)
(emit 'getfield +closure-binding-class+ "value" +lisp-object+))
+ ((variable-environment variable)
+ (assert (not *file-compilation*))
+ (emit 'getstatic *this-class*
+ (declare-object (variable-environment variable)
+ +lisp-environment+
+ +lisp-environment-class+)
+ +lisp-environment+)
+ (emit-push-variable-name variable)
+ (emit-invokevirtual +lisp-environment-class+ "lookup"
+ (list +lisp-object+)
+ +lisp-object+))
(t
(assert nil)))))
@@ -7293,7 +7318,8 @@
((or (variable-representation variable)
(variable-register variable)
(variable-closure-index variable)
- (variable-index variable))
+ (variable-index variable)
+ (variable-environment variable))
(emit-push-variable variable)
(convert-representation (variable-representation variable)
representation)
@@ -8230,6 +8256,13 @@
(variable-closure-index var))
(incf i)))
+ ;; Assert that we're not refering to any variables
+ ;; we're not allowed to use
+ (assert (= 0
+ (length (remove-if (complement #'variable-references)
+ (remove-if #'variable-references-allowed-p
+ *visible-variables*)))))
+
;; Pass 2.
(with-class-file (compiland-class-file compiland)
(p2-compiland compiland)
@@ -8244,8 +8277,6 @@
(defun compile-defun (name form environment filespec)
(aver (eq (car form) 'LAMBDA))
- (unless (or (null environment) (empty-environment-p environment))
- (compiler-unsupported "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment."))
(catch 'compile-defun-abort
(let* ((class-file (make-class-file :pathname filespec
:lambda-name name
@@ -8257,7 +8288,8 @@
:class-file
(make-class-file :pathname ,filespec
:lambda-name ',name
- :lambda-list (cadr ',form)))))))
+ :lambda-list (cadr ',form))))))
+ (*compile-file-environment* environment))
(compile-1 (make-compiland :name name
:lambda-expression
(precompiler:precompile-form form t
@@ -8393,6 +8425,19 @@
(function-lambda-expression function))))
(unless expression
(error "Can't find a definition for ~S." definition))
+ (when environment
+ (dolist (var (reverse (environment-all-variables environment)))
+ ;; We need to add all variables, even symbol macros,
+ ;; because the latter may shadow other variables by the same name
+ ;; The precompiler should have resolved all symbol-macros, so
+ ;; later we assert we didn't get any references to the symbol-macro.
+ (push (make-variable :name (if (symbolp var) var (car var))
+ :special-p (symbolp var)
+ :environment environment
+ :references-allowed-p
+ (not (sys:symbol-macro-p (cdr var)))
+ :compiland NIL) *visible-variables*)))
+ ;; FIXME: we still need to add local functions, ofcourse.
(handler-bind
((compiler-unsupported-feature-error
#'(lambda (c)
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 Fri May 22 04:37:09 2009
@@ -260,11 +260,15 @@
register ; register number for a local variable
index ; index number for a variable in the argument array
closure-index ; index number for a variable in the closure context array
+ environment ; the environment for the variable, if we're compiling in
+ ; a non-null lexical environment with variables
;; a variable can be either special-p *or* have a register *or*
- ;; have an index *or a closure-index
+ ;; have an index *or* a closure-index *or* an environment
(reads 0 :type fixnum)
(writes 0 :type fixnum)
references
+ (references-allowed-p t) ; NIL if this is a symbol macro in the enclosing
+ ; lexical environment
used-non-locally-p
(compiland *current-compiland*))
More information about the armedbear-cvs
mailing list