[armedbear-cvs] r11393 - in branches/scripting/j/src/org/armedbear/lisp/scripting: . lisp
Alessio Stalla
astalla at common-lisp.net
Wed Nov 19 20:57:09 UTC 2008
Author: astalla
Date: Wed Nov 19 20:57:04 2008
New Revision: 11393
Log:
Implemented the Compilable interface and refactored the script evaluation code in the process.
Modified:
branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp
branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp
Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java (original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/AbclScriptEngine.java Wed Nov 19 20:57:04 2008
@@ -30,8 +30,11 @@
import javax.script.AbstractScriptEngine;
import javax.script.Bindings;
+import javax.script.Compilable;
+import javax.script.CompiledScript;
import javax.script.Invocable;
import javax.script.ScriptContext;
+import javax.script.ScriptEngine;
import javax.script.ScriptEngineFactory;
import javax.script.ScriptException;
import javax.script.SimpleBindings;
@@ -58,13 +61,16 @@
import org.armedbear.lisp.scripting.util.WriterOutputStream;
-public class AbclScriptEngine extends AbstractScriptEngine implements Invocable {
+public class AbclScriptEngine extends AbstractScriptEngine implements Invocable, Compilable {
private Interpreter interpreter;
private LispObject nonThrowingDebugHook;
private Function evalScript;
+ private Function compileScript;
+ private Function evalCompiledScript;
public AbclScriptEngine(Interpreter interpreter, boolean enableThrowingDebugger) {
+
this.interpreter = interpreter;
Interpreter.initializeLisp();
final LispThread thread = LispThread.currentThread();
@@ -80,8 +86,10 @@
loadFromClasspath("/org/armedbear/lisp/scripting/lisp/packages.lisp");
loadFromClasspath("/org/armedbear/lisp/scripting/lisp/abcl-script.lisp");
evalScript = (Function) this.findSymbol("EVAL-SCRIPT", "ABCL-SCRIPT").getSymbolFunction();
+ compileScript = (Function) this.findSymbol("COMPILE-SCRIPT", "ABCL-SCRIPT").getSymbolFunction();
+ evalCompiledScript = (Function) this.findSymbol("EVAL-COMPILED-SCRIPT", "ABCL-SCRIPT").getSymbolFunction();
} catch (ConditionThrowable e) {
- e.printStackTrace();
+ throw new Error(e);
}
}
@@ -269,8 +277,7 @@
return super.getContext();
}
- @Override
- public Object eval(String code, ScriptContext ctx) throws ScriptException {
+ private Object eval(Function evaluator, LispObject code, ScriptContext ctx) throws ScriptException {
ReaderInputStream in = null;
WriterOutputStream out = null;
LispObject retVal = null;
@@ -279,10 +286,10 @@
out = new WriterOutputStream(ctx.getWriter());
Stream outStream = new Stream(out, Symbol.CHARACTER);
Stream inStream = new Stream(in, Symbol.CHARACTER);
- retVal = evalScript.execute(makeBindings(ctx.getBindings(ScriptContext.GLOBAL_SCOPE)),
- makeBindings(ctx.getBindings(ScriptContext.ENGINE_SCOPE)),
- inStream, outStream,
- new SimpleString(code), new JavaObject(ctx));
+ retVal = evaluator.execute(makeBindings(ctx.getBindings(ScriptContext.GLOBAL_SCOPE)),
+ makeBindings(ctx.getBindings(ScriptContext.ENGINE_SCOPE)),
+ inStream, outStream,
+ code, new JavaObject(ctx));
return toJava(retVal);
} catch (ConditionThrowable e) {
throw new ScriptException(new Exception(e));
@@ -290,18 +297,27 @@
throw new ScriptException(e);
}
}
-
+
@Override
- public Object eval(Reader code, ScriptContext ctx) throws ScriptException {
+ public Object eval(String code, ScriptContext ctx) throws ScriptException {
+ return eval(evalScript, new SimpleString(code), ctx);
+ }
+
+ private static String toString(Reader reader) throws IOException {
StringWriter w = new StringWriter();
int i;
+ i = reader.read();
+ while (i != -1) {
+ w.write(i);
+ i = reader.read();
+ }
+ return w.toString();
+ }
+
+ @Override
+ public Object eval(Reader code, ScriptContext ctx) throws ScriptException {
try {
- i = code.read();
- while (i != -1) {
- w.write(i);
- i = code.read();
- }
- return eval(w.toString(), ctx);
+ return eval(toString(code), ctx);
} catch (IOException e) {
return new ScriptException(e);
}
@@ -350,7 +366,7 @@
try {
v.aset(i, new JavaObject(array[i]));
} catch (ConditionThrowable e) {
- throw new Error("Can't set simplevector index " + i, e);
+ throw new Error("Can't set SimpleVector index " + i, e);
}
}
return v;
@@ -431,4 +447,46 @@
throw new UnsupportedOperationException("Common Lisp does not have methods in the Java sense.");
}
+ public class AbclCompiledScript extends CompiledScript {
+
+ private LispObject function;
+
+ public AbclCompiledScript(LispObject function) {
+ this.function = function;
+ }
+
+ @Override
+ public Object eval(ScriptContext context) throws ScriptException {
+ return AbclScriptEngine.this.eval(evalCompiledScript, function, context);
+ }
+
+ @Override
+ public ScriptEngine getEngine() {
+ return AbclScriptEngine.this;
+ }
+
+ }
+
+
+ @Override
+ public CompiledScript compile(String script) throws ScriptException {
+ try {
+ Function f = (Function) compileScript.execute(new SimpleString(script));
+ return new AbclCompiledScript(f);
+ } catch (ConditionThrowable e) {
+ throw new ScriptException(new Exception(e));
+ } catch(ClassCastException e) {
+ throw new ScriptException(e);
+ }
+ }
+
+ @Override
+ public CompiledScript compile(Reader script) throws ScriptException {
+ try {
+ return compile(toString(script));
+ } catch (IOException e) {
+ throw new ScriptException(e);
+ }
+ }
+
}
Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/abcl-script.lisp Wed Nov 19 20:57:04 2008
@@ -45,28 +45,45 @@
:collect `(jcall +put-binding+
,java-bindings ,(car jbinding) ,(car binding))))
+(defmacro with-script-context ((global-bindings engine-bindings stdin stdout script-context)
+ body)
+ (let ((actual-global-bindings (gensym))
+ (actual-engine-bindings (gensym)))
+ `(let ((*package* (find-package :abcl-script-user))
+ (*standard-input* ,stdin)
+ (*standard-output* ,stdout)
+ (,actual-global-bindings (generate-bindings ,global-bindings))
+ (,actual-engine-bindings (generate-bindings ,engine-bindings)))
+ (eval `(let ((*standard-input* ,,stdin)
+ (*standard-output* ,,stdout)
+ (*package* (find-package :abcl-script-user)))
+ (let (,@,actual-global-bindings)
+ (let (,@,actual-engine-bindings)
+ (prog1
+ (progn ,@,body)
+ (finish-output *standard-output*)
+ ,@(generate-java-bindings
+ ,global-bindings
+ ,actual-global-bindings
+ (jcall +get-bindings+ ,script-context +global-scope+))
+ ,@(generate-java-bindings
+ ,engine-bindings
+ ,actual-engine-bindings
+ (jcall +get-bindings+ ,script-context +engine-scope+))))))))))
+
(defun eval-script (global-bindings engine-bindings stdin stdout
code-string script-context)
- (let ((*package* (find-package :abcl-script-user))
- (*standard-input* stdin)
- (*standard-output* stdout)
- (actual-global-bindings (generate-bindings global-bindings))
- (actual-engine-bindings (generate-bindings engine-bindings)))
- (eval `(let ((*standard-input* ,stdin)
- (*standard-output* ,stdout)
- (*package* (find-package :abcl-script-user)))
- (let (, at actual-global-bindings)
- (let (, at actual-engine-bindings)
- (prog1
- (progn
- ,@(read-from-string
- (concatenate 'string "(" code-string ")")))
- (finish-output *standard-output*)
- ,@(generate-java-bindings
- global-bindings
- actual-global-bindings
- (jcall +get-bindings+ script-context +global-scope+))
- ,@(generate-java-bindings
- engine-bindings
- actual-engine-bindings
- (jcall +get-bindings+ script-context +engine-scope+)))))))))
\ No newline at end of file
+ (with-script-context (global-bindings engine-bindings stdin stdout script-context)
+ (read-from-string
+ (concatenate 'string "(" code-string ")"))))
+
+(defun eval-compiled-script (global-bindings engine-bindings stdin stdout
+ function script-context)
+ (with-script-context (global-bindings engine-bindings stdin stdout script-context)
+ `((funcall ,function))))
+
+(defun compile-script (code-string)
+ (let ((*package* (find-package :abcl-script-user)))
+ (eval `(compile nil
+ (lambda ()
+ ,@(read-from-string (concatenate 'string "(" code-string ")")))))))
\ No newline at end of file
Modified: branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp
==============================================================================
--- branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp (original)
+++ branches/scripting/j/src/org/armedbear/lisp/scripting/lisp/packages.lisp Wed Nov 19 20:57:04 2008
@@ -19,6 +19,8 @@
(defpackage :abcl-script
(:use :cl :java)
(:export #:eval-script
+ #:compile-script
+ #:eval-compiled-script
#:define-java-interface-implementation
#:find-java-interface-implementation
#:implement-java-interface))
More information about the armedbear-cvs
mailing list