9 files changed, 1379 insertions, 0 deletions
diff --git a/sca-cpp/trunk/modules/scheme/Makefile.am b/sca-cpp/trunk/modules/scheme/Makefile.am
new file mode 100644
index 0000000000..ecf2a6e332
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/Makefile.am
@@ -0,0 +1,32 @@
+#  Licensed to the Apache Software Foundation (ASF) under one
+#  or more contributor license agreements.  See the NOTICE file
+#  distributed with this work for additional information
+#  regarding copyright ownership.  The ASF licenses this file
+#  to you under the Apache License, Version 2.0 (the
+#  "License"); you may not use this file except in compliance
+#  with the License.  You may obtain a copy of the License at
+#  
+#    http://www.apache.org/licenses/LICENSE-2.0
+#    
+#  Unless required by applicable law or agreed to in writing,
+#  software distributed under the License is distributed on an
+#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+#  KIND, either express or implied.  See the License for the
+#  specific language governing permissions and limitations
+#  under the License.
+
+noinst_PROGRAMS = eval-test eval-shell
+
+datadir=$(prefix)/modules/eval
+nobase_data_DATA = *.xsd
+
+INCLUDES = -I. -I$(top_builddir)/kernel -I${LIBXML2_INCLUDE} -I${APR_INCLUDE}
+
+eval_test_SOURCES = eval-test.cpp
+eval_test_LDADD = -L${LIBXML2_LIB} -lxml2 -L${APR_LIB} -lapr-1 -laprutil-1
+
+eval_shell_SOURCES = eval-shell.cpp
+eval_shell_LDADD = -L${LIBXML2_LIB} -lxml2 -L${APR_LIB} -lapr-1 -laprutil-1
+
+TESTS = eval-test
+
diff --git a/sca-cpp/trunk/modules/scheme/driver.hpp b/sca-cpp/trunk/modules/scheme/driver.hpp
new file mode 100644
index 0000000000..629a561453
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/driver.hpp
@@ -0,0 +1,76 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ *
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/* $Rev$ $Date$ */
+
+#ifndef tuscany_scheme_driver_hpp
+#define tuscany_scheme_driver_hpp
+
+/**
+ * Script evaluator main driver loop.
+ */
+
+#include "string.hpp"
+#include "stream.hpp"
+#include "eval.hpp"
+
+namespace tuscany {
+namespace scheme {
+
+const string evalOutputPrompt("; ");
+const string evalInputPrompt("=> ");
+
+const bool promptForInput(const string& str, ostream& out) {
+    out << endl << endl << str;
+    return true;
+}
+
+const bool announceOutput(const string str, ostream& out) {
+    out << endl << str;
+    return true;
+}
+
+const bool userPrint(const value val, ostream& out) {
+    if(isCompoundProcedure(val))
+        writeValue(mklist<value>(compoundProcedureSymbol, procedureParameters(val), procedureBody(val), "<procedure-env>"), out);
+    writeValue(val, out);
+    return true;
+}
+
+const value evalDriverLoop(istream& in, ostream& out, Env& env, const gc_pool& pool) {
+    promptForInput(evalInputPrompt, out);
+    value input = readValue(in);
+    if (isNil(input))
+        return input;
+    const value output = evalExpr(input, env, pool);
+    announceOutput(evalOutputPrompt, out);
+    userPrint(output, out);
+    return evalDriverLoop(in, out, env, pool);
+}
+
+const bool evalDriverRun(istream& in, ostream& out, const gc_pool& pool) {
+    setupDisplay(out);
+    Env globalEnv = setupEnvironment(pool);
+    evalDriverLoop(in, out, globalEnv, pool);
+    return true;
+}
+
+}
+}
+#endif /* tuscany_scheme_driver_hpp */
diff --git a/sca-cpp/trunk/modules/scheme/environment.hpp b/sca-cpp/trunk/modules/scheme/environment.hpp
new file mode 100644
index 0000000000..aa4517115d
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/environment.hpp
@@ -0,0 +1,179 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ *
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/* $Rev$ $Date$ */
+
+#ifndef tuscany_scheme_environment_hpp
+#define tuscany_scheme_environment_hpp
+
+/**
+ * Script evaluator environment implementation.
+ */
+
+#include "string.hpp"
+#include "list.hpp"
+#include "value.hpp"
+#include "primitive.hpp"
+#include <string>
+
+namespace tuscany {
+namespace scheme {
+
+typedef value Frame;
+typedef list<value> Env;
+
+const value trueSymbol("true");
+const value falseSymbol("false");
+const value defineSymbol("define");
+const value setSymbol("set!");
+const value dotSymbol(".");
+
+const Env theEmptyEnvironment() {
+    return list<value>();
+}
+
+const bool isDefinition(const value& exp) {
+    return isTaggedList(exp, defineSymbol);
+}
+
+const bool isAssignment(const value& exp) {
+    return isTaggedList(exp, setSymbol);
+}
+
+const bool isVariable(const value& exp) {
+    return isSymbol(exp);
+}
+
+const Env enclosingEnvironment(const Env& env) {
+    return cdr(env);
+}
+
+const gc_ptr<Frame> firstFrame(const Env& env) {
+    return car(env);
+}
+
+list<value> frameVariables(const Frame& frame) {
+    return car((list<value> )frame);
+}
+
+list<value> frameValues(const Frame& frame) {
+    return cdr((list<value> )frame);
+}
+
+const bool isDotVariable(const value& var) {
+    return var == dotSymbol;
+}
+
+const Frame makeBinding(const Frame& frameSoFar, const list<value>& variables, const list<value> values) {
+    if (isNil(variables)) {
+        if (!isNil(values))
+            logStream() << "Too many arguments supplied " << values << endl;
+        return frameSoFar;
+    }
+    if (isDotVariable(car(variables)))
+        return makeBinding(frameSoFar, cdr(variables), mklist<value>(values));
+
+    if (isNil(values)) {
+        if (!isNil(variables))
+            logStream() << "Too few arguments supplied " << variables << endl;
+        return frameSoFar;
+    }
+
+    const list<value> vars = cons(car(variables), frameVariables(frameSoFar));
+    const list<value> vals = cons(car(values), frameValues(frameSoFar));
+    const Frame newFrame = cons(value(vars), vals);
+
+    return makeBinding(newFrame, cdr(variables), cdr(values));
+}
+
+const gc_ptr<Frame> makeFrame(const list<value>& variables, const list<value> values, const gc_pool& pool) {
+    gc_ptr<Frame> frame = new (gc_new<Frame>(pool)) Frame();
+    *frame = value(makeBinding(cons(value(list<value>()), list<value>()), variables, values));
+    return frame;
+}
+
+const value definitionVariable(const value& exp) {
+    const list<value> exps(exp);
+    if(isSymbol(car(cdr(exps))))
+        return car(cdr(exps));
+    const list<value> lexps(car(cdr(exps)));
+    return car(lexps);
+}
+
+const value definitionValue(const value& exp) {
+    const list<value> exps(exp);
+    if(isSymbol(car(cdr(exps))))
+        return car(cdr(cdr(exps)));
+    const list<value> lexps(car(cdr(exps)));
+    return makeLambda(cdr(lexps), cdr(cdr(exps)));
+}
+
+const value assignmentVariable(const value& exp) {
+    return car(cdr((list<value> )exp));
+}
+
+const value assignmentValue(const value& exp) {
+    return car(cdr(cdr((list<value> )exp)));
+}
+
+const Frame addBindingToFrame(const value& var, const value& val, const Frame& frame) {
+    return cons(value(cons(var, frameVariables(frame))), cons(val, frameValues(frame)));
+}
+
+const bool defineVariable(const value& var, const value& val, Env& env) {
+    *firstFrame(env) = addBindingToFrame(var, val, *firstFrame(env));
+    return true;
+}
+
+const Env extendEnvironment(const list<value>& vars, const list<value>& vals, const Env& baseEnv, const gc_pool& pool) {
+    return cons<value>(makeFrame(vars, vals, pool), baseEnv);
+}
+
+const Env setupEnvironment(const gc_pool& pool) {
+    Env env = extendEnvironment(primitiveProcedureNames(), primitiveProcedureObjects(), theEmptyEnvironment(), pool);
+    defineVariable(trueSymbol, true, env);
+    defineVariable(falseSymbol, false, env);
+    return env;
+}
+
+const value lookupEnvLoop(const value& var, const Env& env);
+
+const value lookupEnvScan(const value& var, const list<value>& vars, const list<value>& vals, const Env& env) {
+    if(isNil(vars))
+        return lookupEnvLoop(var, enclosingEnvironment(env));
+    if(var == car(vars))
+        return car(vals);
+    return lookupEnvScan(var, cdr(vars), cdr(vals), env);
+}
+
+const value lookupEnvLoop(const value& var, const Env& env) {
+    if(env == theEmptyEnvironment()) {
+        logStream() << "Unbound variable " << var << endl;
+        return value();
+    }
+    return lookupEnvScan(var, frameVariables(*firstFrame(env)), frameValues(*firstFrame(env)), env);
+}
+
+const value lookupVariableValue(const value& var, const Env& env) {
+    return lookupEnvLoop(var, env);
+}
+
+}
+}
+#endif /* tuscany_scheme_environment_hpp */
diff --git a/sca-cpp/trunk/modules/scheme/eval-shell.cpp b/sca-cpp/trunk/modules/scheme/eval-shell.cpp
new file mode 100644
index 0000000000..58c0dd14bc
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/eval-shell.cpp
@@ -0,0 +1,36 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ *
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/* $Rev$ $Date$ */
+
+/**
+ * Script evaluator shell, used for interactive testing of scripts.
+ */
+
+#include <assert.h>
+#include "gc.hpp"
+#include "stream.hpp"
+#include "string.hpp"
+#include "driver.hpp"
+
+int main() {
+    tuscany::gc_scoped_pool pool;
+    tuscany::scheme::evalDriverRun(tuscany::cin, tuscany::cout, pool);
+    return 0;
+}
diff --git a/sca-cpp/trunk/modules/scheme/eval-test.cpp b/sca-cpp/trunk/modules/scheme/eval-test.cpp
new file mode 100644
index 0000000000..cd90dc8863
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/eval-test.cpp
@@ -0,0 +1,231 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ *
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/* $Rev$ $Date$ */
+
+/**
+ * Test script evaluator.
+ */
+
+#include <assert.h>
+#include "stream.hpp"
+#include "string.hpp"
+#include "driver.hpp"
+
+namespace tuscany {
+namespace scheme {
+
+bool testEnv() {
+    gc_scoped_pool pool;
+    Env globalEnv = list<value>();
+    Env env = extendEnvironment(mklist<value>("a"), mklist<value>(1), globalEnv, pool);
+    defineVariable("x", env, env);
+    assert(lookupVariableValue(value("x"), env) == env);
+    assert(lookupVariableValue("a", env) == value(1));
+    return true;
+}
+
+bool testEnvGC() {
+    resetLambdaCounters();
+    resetListCounters();
+    resetValueCounters();
+    testEnv();
+    assert(checkValueCounters());
+    assert(checkLambdaCounters());
+    assert(checkListCounters());
+    return true;
+}
+
+bool testRead() {
+    istringstream is("abcd");
+    assert(readValue(is) == "abcd");
+
+    istringstream is2("123");
+    assert(readValue(is2) == value(123));
+
+    istringstream is3("(abcd)");
+    assert(readValue(is3) == mklist(value("abcd")));
+
+    istringstream is4("(abcd xyz)");
+    assert(readValue(is4) == mklist<value>("abcd", "xyz"));
+
+    istringstream is5("(abcd (xyz tuv))");
+    assert(readValue(is5) == mklist<value>("abcd", mklist<value>("xyz", "tuv")));
+
+    return true;
+}
+
+bool testWrite() {
+    const list<value> i = list<value>()
+            + (list<value>() + "item" + "cart-53d67a61-aa5e-4e5e-8401-39edeba8b83b"
+                + (list<value>() + "item"
+                    + (list<value>() + "name" + "Apple")
+                    + (list<value>() + "price" + "$2.99")))
+            + (list<value>() + "item" + "cart-53d67a61-aa5e-4e5e-8401-39edeba8b83c"
+                + (list<value>() + "item"
+                    + (list<value>() + "name" + "Orange")
+                    + (list<value>() + "price" + "$3.55")));
+    const list<value> a = cons<value>("Feed", cons<value>("feed-1234", i));
+    ostringstream os;
+    writeValue(a, os);
+    istringstream is(str(os));
+    assert(readValue(is) == a);
+    return true;
+}
+
+const string testSchemeNumber(
+  "(define (testNumber) (if (= 1 1) (display \"testNumber ok\") (error \"testNumber\"))) "
+  "(testNumber)");
+
+const string testSchemeString(
+  "(define (testString) (if (= \"abc\" \"abc\") (display \"testString ok\") (error \"testString\"))) "
+  "(testString)");
+
+const string testSchemeDefinition(
+  "(define a \"abc\") (define (testDefinition) (if (= a \"abc\") (display \"testDefinition ok\") (error \"testDefinition\"))) "
+  "(testDefinition)");
+
+const string testSchemeIf(
+  "(define (testIf) (if (= \"abc\" \"abc\") (if (= \"xyz\" \"xyz\") (display \"testIf ok\") (error \"testNestedIf\")) (error \"testIf\"))) "
+  "(testIf)");
+
+const string testSchemeCond(
+  "(define (testCond) (cond ((= \"abc\" \"abc\") (display \"testCond ok\")) (else (error \"testIf\"))))"
+  "(testCond)");
+
+const string testSchemeBegin(
+  "(define (testBegin) "
+    "(begin "
+        "(define a \"abc\") "
+        "(if (= a \"abc\") (display \"testBegin1 ok\") (error \"testBegin\")) "
+        "(define x \"xyz\") "
+        "(if (= x \"xyz\") (display \"testBegin2 ok\") (error \"testBegin\")) "
+      ") "
+  ") "
+  "(testBegin)");
+
+const string testSchemeLambda(
+  "(define sqrt (lambda (x) (* x x))) "
+  "(define (testLambda) (if (= 4 (sqrt 2)) (display \"testLambda ok\") (error \"testLambda\"))) "
+  "(testLambda)");
+
+const string testSchemeForward(
+  "(define (testLambda) (if (= 4 (sqrt 2)) (display \"testForward ok\") (error \"testForward\"))) "
+  "(define sqrt (lambda (x) (* x x))) "
+  "(testLambda)");
+
+const string evalOutput(const string& scm, const gc_pool& pool) {
+    istringstream is(scm);
+    ostringstream os;
+    evalDriverRun(is, os, pool);
+    return str(os);
+}
+
+bool testEval() {
+    gc_scoped_pool pool;
+    assert(contains(evalOutput(testSchemeNumber, pool), "testNumber ok"));
+    assert(contains(evalOutput(testSchemeString, pool), "testString ok"));
+    assert(contains(evalOutput(testSchemeDefinition, pool), "testDefinition ok"));
+    assert(contains(evalOutput(testSchemeIf, pool), "testIf ok"));
+    assert(contains(evalOutput(testSchemeCond, pool), "testCond ok"));
+    assert(contains(evalOutput(testSchemeBegin, pool), "testBegin1 ok"));
+    assert(contains(evalOutput(testSchemeBegin, pool), "testBegin2 ok"));
+    assert(contains(evalOutput(testSchemeLambda, pool), "testLambda ok"));
+    assert(contains(evalOutput(testSchemeForward, pool), "testForward ok"));
+    return true;
+}
+
+bool testEvalExpr() {
+    gc_scoped_pool pool;
+    const value exp = mklist<value>("+", 2, 3);
+    Env env = setupEnvironment(pool);
+    const value r = evalExpr(exp, env, pool);
+    assert(r == value(5));
+    return true;
+}
+
+bool testEvalRun() {
+    gc_scoped_pool pool;
+    evalDriverRun(cin, cout, pool);
+    return true;
+}
+
+const value mult(const list<value>& args) {
+    const double x = car(args);
+    const double y = cadr(args);
+    return x * y;
+}
+
+const string testReturnLambda(
+  "(define (testReturnLambda) * )");
+
+const string testCallLambda(
+  "(define (testCallLambda l x y) (l x y))");
+
+bool testEvalLambda() {
+    gc_scoped_pool pool;
+    Env env = setupEnvironment(pool);
+
+    const value trl = mklist<value>("testReturnLambda");
+    istringstream trlis(testReturnLambda);
+    const value trlv = evalScript(trl, trlis, env, pool);
+
+    istringstream tclis(testCallLambda);
+    const value tcl = cons<value>("testCallLambda", quotedParameters(mklist<value>(trlv, 2, 3)));
+    const value tclv = evalScript(tcl, tclis, env, pool);
+    assert(tclv == value(6));
+
+    istringstream tcelis(testCallLambda);
+    const value tcel = cons<value>("testCallLambda", quotedParameters(mklist<value>(primitiveProcedure(mult), 3, 4)));
+    const value tcelv = evalScript(tcel, tcelis, env, pool);
+    assert(tcelv == value(12));
+    return true;
+}
+
+bool testEvalGC() {
+    resetLambdaCounters();
+    resetListCounters();
+    resetValueCounters();
+    testEval();
+    testEvalExpr();
+    testEvalLambda();
+    assert(checkValueCounters());
+    assert(checkLambdaCounters());
+    assert(checkListCounters());
+    return true;
+}
+
+}
+}
+
+int main() {
+    tuscany::cout << "Testing..." << tuscany::endl;
+
+    tuscany::scheme::testEnv();
+    tuscany::scheme::testEnvGC();
+    tuscany::scheme::testRead();
+    tuscany::scheme::testWrite();
+    tuscany::scheme::testEval();
+    tuscany::scheme::testEvalExpr();
+    tuscany::scheme::testEvalLambda();
+    tuscany::scheme::testEvalGC();
+
+    tuscany::cout << "OK" << tuscany::endl;
+    return 0;
+}
diff --git a/sca-cpp/trunk/modules/scheme/eval.hpp b/sca-cpp/trunk/modules/scheme/eval.hpp
new file mode 100644
index 0000000000..05293a53d3
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/eval.hpp
@@ -0,0 +1,290 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ *
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/* $Rev$ $Date$ */
+
+#ifndef tuscany_scheme_eval_hpp
+#define tuscany_scheme_eval_hpp
+
+/**
+ * Core script evaluation logic.
+ */
+
+#include <string.h>
+#include "list.hpp"
+#include "value.hpp"
+#include "primitive.hpp"
+#include "io.hpp"
+#include "environment.hpp"
+
+namespace tuscany {
+namespace scheme {
+
+const value evalExpr(const value& exp, Env& env, const gc_pool& pool);
+
+const value compoundProcedureSymbol("compound-procedure");
+const value procedureSymbol("procedure");
+const value applySymbol("apply");
+const value beginSymbol("begin");
+const value condSymbol("cond");
+const value elseSymbol("else");
+const value ifSymbol("if");
+
+const bool isBegin(const value& exp) {
+    return isTaggedList(exp, beginSymbol);
+}
+
+const list<value> beginActions(const value& exp) {
+    return cdr((list<value> )exp);
+}
+
+const bool isLambdaExpr(const value& exp) {
+    return isTaggedList(exp, lambdaSymbol);
+}
+
+const list<value> lambdaParameters(const value& exp) {
+    return car(cdr((list<value> )exp));
+}
+
+static list<value> lambdaBody(const value& exp) {
+    return cdr(cdr((list<value> )exp));
+}
+
+const value makeProcedure(const list<value>& parameters, const value& body, const Env& env) {
+    return mklist<value>(procedureSymbol, parameters, body, env);
+}
+
+const bool isApply(const value& exp) {
+    return isTaggedList(exp, applySymbol);
+}
+
+const bool isApplication(const value& exp) {
+    return isList(exp);
+}
+
+const value operat(const value& exp) {
+    return car((list<value> )exp);
+}
+
+const list<value> operands(const value& exp) {
+    return cdr((list<value> )exp);
+}
+
+const list<value> listOfValues(const list<value> exps, Env& env, const gc_pool& pool) {
+    if(isNil(exps))
+        return list<value> ();
+    return cons(evalExpr(car(exps), env, pool), listOfValues(cdr(exps), env, pool));
+}
+
+const value applyOperat(const value& exp) {
+    return cadr((list<value> )exp);
+}
+
+const value applyOperand(const value& exp) {
+    return caddr((list<value> )exp);
+}
+
+const bool isCompoundProcedure(const value& procedure) {
+    return isTaggedList(procedure, procedureSymbol);
+}
+
+const list<value> procedureParameters(const value& exp) {
+    return car(cdr((list<value> )exp));
+}
+
+const value procedureBody(const value& exp) {
+    return car(cdr(cdr((list<value> )exp)));
+}
+
+const Env procedureEnvironment(const value& exp) {
+    return (Env)car(cdr(cdr(cdr((list<value> )exp))));
+}
+
+const bool isLastExp(const list<value>& seq) {
+    return isNil(cdr(seq));
+}
+
+const value firstExp(const list<value>& seq) {
+    return car(seq);
+}
+
+const list<value> restExp(const list<value>& seq) {
+    return cdr(seq);
+}
+
+const value makeBegin(const list<value> seq) {
+    return cons(beginSymbol, seq);
+}
+
+const value evalSequence(const list<value>& exps, Env& env, const gc_pool& pool) {
+    if(isLastExp(exps))
+        return evalExpr(firstExp(exps), env, pool);
+    evalExpr(firstExp(exps), env, pool);
+    return evalSequence(restExp(exps), env, pool);
+}
+
+const value applyProcedure(const value& procedure, list<value>& arguments, const gc_pool& pool) {
+    if(isPrimitiveProcedure(procedure))
+        return applyPrimitiveProcedure(procedure, arguments);
+    if(isCompoundProcedure(procedure)) {
+        Env env = extendEnvironment(procedureParameters(procedure), arguments, procedureEnvironment(procedure), pool);
+        return evalSequence(procedureBody(procedure), env, pool);
+    }
+    logStream() << "Unknown procedure type " << procedure << endl;
+    return value();
+}
+
+const value sequenceToExp(const list<value> exps) {
+    if(isNil(exps))
+        return exps;
+    if(isLastExp(exps))
+        return firstExp(exps);
+    return makeBegin(exps);
+}
+
+const list<value> condClauses(const value& exp) {
+    return cdr((list<value> )exp);
+}
+
+const value condPredicate(const value& clause) {
+    return car((list<value> )clause);
+}
+
+const list<value> condActions(const value& clause) {
+    return cdr((list<value> )clause);
+}
+
+const value ifPredicate(const value& exp) {
+    return car(cdr((list<value> )exp));
+}
+
+const value ifConsequent(const value& exp) {
+    return car(cdr(cdr((list<value> )exp)));
+}
+
+const value ifAlternative(const value& exp) {
+    if(!isNil(cdr(cdr(cdr((list<value> )exp)))))
+        return car(cdr(cdr(cdr((list<value> )exp))));
+    return false;
+}
+
+const bool isCond(const value& exp) {
+    return isTaggedList(exp, condSymbol);
+}
+
+const bool isCondElseClause(const value& clause) {
+    return condPredicate(clause) == elseSymbol;
+}
+
+const bool isIf(const value& exp) {
+    return isTaggedList(exp, ifSymbol);
+}
+
+const value makeIf(value predicate, value consequent, value alternative) {
+    return mklist(ifSymbol, predicate, consequent, alternative);
+}
+
+const value expandClauses(const list<value>& clauses) {
+    if(isNil(clauses))
+        return false;
+    const value first = car(clauses);
+    const list<value> rest = cdr(clauses);
+    if(isCondElseClause(first)) {
+        if(isNil(rest))
+            return sequenceToExp(condActions(first));
+        logStream() << "else clause isn't last " << clauses << endl;
+        return value();
+    }
+    return makeIf(condPredicate(first), sequenceToExp(condActions(first)), expandClauses(rest));
+}
+
+value condToIf(const value& exp) {
+    return expandClauses(condClauses(exp));
+}
+
+value evalIf(const value& exp, Env& env, const gc_pool& pool) {
+    if(isTrue(evalExpr(ifPredicate(exp), env, pool)))
+        return evalExpr(ifConsequent(exp), env, pool);
+    return evalExpr(ifAlternative(exp), env, pool);
+}
+
+const value evalDefinition(const value& exp, Env& env, const gc_pool& pool) {
+    defineVariable(definitionVariable(exp), evalExpr(definitionValue(exp), env, pool), env);
+    return definitionVariable(exp);
+}
+
+const value evalExpr(const value& exp, Env& env, const gc_pool& pool) {
+    if(isSelfEvaluating(exp))
+        return exp;
+    if(isQuoted(exp))
+        return textOfQuotation(exp);
+    if(isDefinition(exp))
+        return evalDefinition(exp, env, pool);
+    if(isIf(exp))
+        return evalIf(exp, env, pool);
+    if(isBegin(exp))
+        return evalSequence(beginActions(exp), env, pool);
+    if(isCond(exp))
+        return evalExpr(condToIf(exp), env, pool);
+    if(isLambdaExpr(exp))
+        return makeProcedure(lambdaParameters(exp), lambdaBody(exp), env);
+    if(isVariable(exp))
+        return lookupVariableValue(exp, env);
+    if(isApply(exp)) {
+        list<value> applyOperandValues = evalExpr(applyOperand(exp), env, pool);
+        return applyProcedure(evalExpr(applyOperat(exp), env, pool), applyOperandValues, pool);
+    }
+    if(isApplication(exp)) {
+        list<value> operandValues = listOfValues(operands(exp), env, pool);
+        return applyProcedure(evalExpr(operat(exp), env, pool), operandValues, pool);
+    }
+    logStream() << "Unknown expression type " << exp << endl;
+    return value();
+}
+
+const list<value> quotedParameters(const list<value>& p) {
+    if (isNil(p))
+        return p;
+    return cons<value>(mklist<value>(quoteSymbol, car(p)), quotedParameters(cdr(p)));
+}
+
+/**
+ * Evaluate an expression against a script provided as a list of values.
+ */
+const value evalScriptLoop(const value& expr, const list<value>& script, scheme::Env& env, const gc_pool& pool) {
+    if (isNil(script))
+        return scheme::evalExpr(expr, env, pool);
+    scheme::evalExpr(car(script), env, pool);
+    return evalScriptLoop(expr, cdr(script), env, pool);
+}
+
+const value evalScript(const value& expr, const value& script, Env& env, const gc_pool& pool) {
+    return evalScriptLoop(expr, script, env, pool);
+}
+
+/**
+ * Evaluate an expression against a script provided as an input stream.
+ */
+const value evalScript(const value& expr, istream& is, Env& env, const gc_pool& pool) {
+    return evalScript(expr, readScript(is), env, pool);
+}
+
+}
+}
+#endif /* tuscany_scheme_eval_hpp */
diff --git a/sca-cpp/trunk/modules/scheme/io.hpp b/sca-cpp/trunk/modules/scheme/io.hpp
new file mode 100644
index 0000000000..5e5397cfeb
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/io.hpp
@@ -0,0 +1,217 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ *
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/* $Rev$ $Date$ */
+
+#ifndef tuscany_scheme_io_hpp
+#define tuscany_scheme_io_hpp
+
+/**
+ * Script evaluator IO functions.
+ */
+
+#include <ctype.h>
+#include "stream.hpp"
+#include "string.hpp"
+
+#include "list.hpp"
+#include "value.hpp"
+#include "primitive.hpp"
+
+namespace tuscany {
+namespace scheme {
+
+const value rightParenthesis(mklist<value>(")"));
+const value leftParenthesis(mklist<value>("("));
+const value comment(mklist<value>(";"));
+
+const double stringToNumber(const string& str) {
+    return atof(c_str(str));
+}
+
+const bool isWhitespace(const char ch) {
+    return ch != -1 && isspace(ch);
+}
+
+const bool isIdentifierStart(const char ch) {
+    return ch != -1 && !isspace(ch) && !isdigit(ch);
+}
+
+const bool isIdentifierPart(const char ch) {
+    return ch != -1 && !isspace(ch) && ch != '(' && ch != ')';
+}
+
+const bool isDigit(const char ch) {
+    return isdigit(ch) || ch == '.';
+}
+
+const bool isLeftParenthesis(const value& token) {
+    return leftParenthesis == token;
+}
+
+const bool isRightParenthesis(const value& token) {
+    return rightParenthesis == token;
+}
+
+const char readChar(istream& in) {
+    if(in.eof()) {
+        return -1;
+    }
+    char c = (char)get(in);
+    return c;
+}
+
+const char peekChar(istream& in) {
+    if(eof(in))
+        return -1;
+    char c = (char)peek(in);
+    return c;
+}
+
+const bool isQuote(const value& token) {
+    return token == quoteSymbol;
+}
+
+const value skipComment(istream& in);
+const value readQuoted(istream& in);
+const value readIdentifier(const char chr, istream& in);
+const value readString(istream& in);
+const value readNumber(const char chr, istream& in);
+const value readValue(istream& in);
+
+const value readToken(istream& in) {
+    const char firstChar = readChar(in);
+    if(isWhitespace(firstChar))
+        return readToken(in);
+    if(firstChar == ';')
+        return skipComment(in);
+    if(firstChar == '\'')
+        return readQuoted(in);
+    if(firstChar == '(')
+        return leftParenthesis;
+    if(firstChar == ')')
+        return rightParenthesis;
+    if(firstChar == '"')
+        return readString(in);
+    if(isIdentifierStart(firstChar))
+        return readIdentifier(firstChar, in);
+    if(isDigit(firstChar))
+        return readNumber(firstChar, in);
+    if(firstChar == -1)
+        return value();
+    logStream() << "Illegal lexical syntax '" << firstChar << "'" << endl;
+    return readToken(in);
+}
+
+const value skipComment(istream& in) {
+    const char nextChar = readChar(in);
+    if (nextChar == '\n')
+        return readToken(in);
+    return skipComment(in);
+}
+
+const value readQuoted(istream& in) {
+    return mklist(quoteSymbol, readValue(in));
+}
+
+const list<value> readList(const list<value>& listSoFar, istream& in) {
+    const value token = readToken(in);
+    if(isNil(token) || isRightParenthesis(token))
+        return reverse(listSoFar);
+    if(isLeftParenthesis(token))
+        return readList(cons(value(readList(list<value> (), in)), listSoFar), in);
+    return readList(cons(token, listSoFar), in);
+}
+
+const string listToString(const list<char>& l) {
+    if(isNil(l))
+        return "";
+    const char buf[1] = { car(l) };
+    return string(buf, 1) + listToString(cdr(l));
+}
+
+const list<char> readIdentifierHelper(const list<char>& listSoFar, istream& in) {
+    const char nextChar = peekChar(in);
+    if(isIdentifierPart(nextChar))
+        return readIdentifierHelper(cons(readChar(in), listSoFar), in);
+    return reverse(listSoFar);
+}
+
+const value readIdentifier(const char chr, istream& in) {
+    return c_str(listToString(readIdentifierHelper(mklist(chr), in)));
+}
+
+const list<char> readStringHelper(const list<char>& listSoFar, istream& in) {
+    const char nextChar = readChar(in);
+    if(nextChar != -1 && nextChar != '"')
+        return readStringHelper(cons(nextChar, listSoFar), in);
+    return reverse(listSoFar);
+}
+
+const value readString(istream& in) {
+    return listToString(readStringHelper(list<char>(), in));
+}
+
+const list<char> readNumberHelper(const list<char>& listSoFar, istream& in) {
+    const char nextChar = peekChar(in);
+    if(isDigit(nextChar))
+        return readNumberHelper(cons(readChar(in), listSoFar), in);
+    return reverse(listSoFar);
+}
+
+const value readNumber(const char chr, istream& in) {
+    return stringToNumber(listToString(readNumberHelper(mklist(chr), in)));
+}
+
+const value readValue(istream& in) {
+    const value nextToken = readToken(in);
+    if(isLeftParenthesis(nextToken))
+        return readList(list<value> (), in);
+    return nextToken;
+}
+
+const value readValue(const string s) {
+    istringstream in(s);
+    const value nextToken = readToken(in);
+    if(isLeftParenthesis(nextToken))
+        return readList(list<value> (), in);
+    return nextToken;
+}
+
+const bool writeValue(const value& val, ostream& out) {
+    out << val;
+    return true;
+}
+
+const string writeValue(const value& val) {
+    ostringstream out;
+    out << val;
+    return str(out);
+}
+
+const value readScript(istream& in) {
+    const value val = readValue(in);
+    if (isNil(val))
+        return list<value>();
+    return cons(val, (list<value>)readScript(in));
+}
+
+}
+}
+#endif /* tuscany_scheme_io_hpp */
diff --git a/sca-cpp/trunk/modules/scheme/primitive.hpp b/sca-cpp/trunk/modules/scheme/primitive.hpp
new file mode 100644
index 0000000000..95db5dd7a2
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/primitive.hpp
@@ -0,0 +1,275 @@
+/*
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ *
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.
+ */
+
+/* $Rev$ $Date$ */
+
+#ifndef tuscany_scheme_primitive_hpp
+#define tuscany_scheme_primitive_hpp
+
+/**
+ * Script evaluator primitive functions.
+ */
+
+#include <apr_general.h>
+#include <apr_uuid.h>
+#include "stream.hpp"
+#include "function.hpp"
+#include "list.hpp"
+#include "value.hpp"
+
+namespace tuscany {
+namespace scheme {
+
+const value primitiveSymbol("primitive");
+const value quoteSymbol("'");
+const value lambdaSymbol("lambda");
+
+#ifdef _REENTRANT
+__thread
+#endif
+ostream* displayOutStream = NULL;
+
+#ifdef _REENTRANT
+__thread
+#endif
+ostream* logOutStream = NULL;
+
+const bool setupDisplay(ostream& out) {
+    displayOutStream = &out;
+    return true;
+}
+
+ostream& displayStream() {
+    if (displayOutStream == NULL)
+        return cout;
+    return *displayOutStream;
+}
+
+const bool setupLog(ostream& out) {
+    logOutStream = &out;
+    return true;
+}
+
+ostream& logStream() {
+    if (logOutStream == NULL)
+        return cerr;
+    return *logOutStream;
+}
+
+const value carProc(const list<value>& args) {
+    return car((list<value> )car(args));
+}
+
+const value cdrProc(const list<value>& args) {
+    return cdr((list<value> )car(args));
+}
+
+const value consProc(const list<value>& args) {
+    return cons(car(args), (list<value> )cadr(args));
+}
+
+const value listProc(const list<value>& args) {
+    return args;
+}
+
+const value assocProc(const list<value>& args) {
+    return assoc(car(args), (list<list<value> >)cadr(args));
+}
+
+const value nulProc(const list<value>& args) {
+    const value v(car(args));
+    if (isNil(v))
+        return true;
+    if (isList(v))
+        return isNil(list<value>(v));
+    return false;
+}
+
+const value equalProc(const list<value>& args) {
+    return (bool)(car(args) == cadr(args));
+}
+
+const value addProc(const list<value>& args) {
+    if (isNil(cdr(args)))
+        return (double)car(args);
+    return (double)car(args) + (double)cadr(args);
+}
+
+const value subProc(const list<value>& args) {
+    if (isNil(cdr(args)))
+        return (double)0 - (double)car(args);
+    return (double)car(args) - (double)cadr(args);
+}
+
+const value mulProc(const list<value>& args) {
+    return (double)car(args) * (double)cadr(args);
+}
+
+const value divProc(const list<value>& args) {
+    return (double)car(args) / (double)cadr(args);
+}
+
+const value displayProc(const list<value>& args) {
+    if (isNil(args)) {
+        displayStream() << endl;
+        return true;
+    }
+    displayStream() << car(args);
+    return displayProc(cdr(args));
+}
+
+const value logProc(const list<value>& args) {
+    if (isNil(args)) {
+        logStream() << endl;
+        return true;
+    }
+    logStream() << car(args);
+    return logProc(cdr(args));
+}
+
+const value uuidProc(unused const list<value>& args) {
+    apr_uuid_t uuid;
+    apr_uuid_get(&uuid);
+    char buf[APR_UUID_FORMATTED_LENGTH];
+    apr_uuid_format(buf, &uuid);
+    return string(buf, APR_UUID_FORMATTED_LENGTH);
+}
+
+const value cadrProc(unused const list<value>& args) {
+    return cadr((list<value> )car(args));
+}
+
+const value caddrProc(unused const list<value>& args) {
+    return caddr((list<value> )car(args));
+}
+
+const value cadddrProc(unused const list<value>& args) {
+    return cadddr((list<value> )car(args));
+}
+
+const value cddrProc(unused const list<value>& args) {
+    return cddr((list<value> )car(args));
+}
+
+const value cdddrProc(unused const list<value>& args) {
+    return cdddr((list<value> )car(args));
+}
+
+const value applyPrimitiveProcedure(const value& proc, list<value>& args) {
+    const lambda<value(const list<value>&)> func(cadr((list<value>)proc));
+    return func(args);
+}
+
+const bool isPrimitiveProcedure(const value& proc) {
+    return isTaggedList(proc, primitiveSymbol);
+}
+
+const bool isSelfEvaluating(const value& exp) {
+    if(isNil(exp))
+        return true;
+    if(isNumber(exp))
+        return true;
+    if(isString(exp))
+        return true;
+    if(isBool(exp))
+        return true;
+    if(isChar(exp))
+        return true;
+    if(isLambda(exp))
+        return true;
+    return false;
+}
+
+const value primitiveImplementation(const list<value>& proc) {
+    return car(cdr(proc));
+}
+
+template<typename F> const value primitiveProcedure(const F& f) {
+    return mklist<value>(primitiveSymbol, (lambda<value(const list<value>&)>)f);
+}
+
+const list<value> primitiveProcedureNames() {
+    return mklist<value>("car")
+    + "cdr"
+    + "cons"
+    + "list"
+    + "nul"
+    + "="
+    + "equal?"
+    + "+"
+    + "-"
+    + "*"
+    + "/"
+    + "assoc"
+    + "cadr"
+    + "caddr"
+    + "cadddr"
+    + "cddr"
+    + "cdddr"
+    + "display"
+    + "log"
+    + "uuid";
+}
+
+const list<value> primitiveProcedureObjects() {
+    return mklist(primitiveProcedure(carProc))
+    + primitiveProcedure(cdrProc)
+    + primitiveProcedure(consProc)
+    + primitiveProcedure(listProc)
+    + primitiveProcedure(nulProc)
+    + primitiveProcedure(equalProc)
+    + primitiveProcedure(equalProc)
+    + primitiveProcedure(addProc)
+    + primitiveProcedure(subProc)
+    + primitiveProcedure(mulProc)
+    + primitiveProcedure(divProc)
+    + primitiveProcedure(assocProc)
+    + primitiveProcedure(cadrProc)
+    + primitiveProcedure(caddrProc)
+    + primitiveProcedure(cadddrProc)
+    + primitiveProcedure(cddrProc)
+    + primitiveProcedure(cdddrProc)
+    + primitiveProcedure(displayProc)
+    + primitiveProcedure(logProc)
+    + primitiveProcedure(uuidProc);
+}
+
+const bool isFalse(const value& exp) {
+    return (bool)exp == false;
+}
+
+const bool isTrue(const value& exp) {
+    return (bool)exp == true;
+}
+
+const bool isQuoted(const value& exp) {
+    return isTaggedList(exp, quoteSymbol);
+}
+
+const value textOfQuotation(const value& exp) {
+    return car(cdr((list<value> )exp));
+}
+
+const value makeLambda(const list<value>& parameters, const list<value>& body) {
+    return cons(lambdaSymbol, cons<value>(parameters, body));
+}
+
+}
+}
+#endif /* tuscany_scheme_primitive_hpp */
diff --git a/sca-cpp/trunk/modules/scheme/tuscany-sca-1.1-implementation-eval.xsd b/sca-cpp/trunk/modules/scheme/tuscany-sca-1.1-implementation-eval.xsd
new file mode 100644
index 0000000000..bbf4935346
--- /dev/null
+++ b/sca-cpp/trunk/modules/scheme/tuscany-sca-1.1-implementation-eval.xsd
@@ -0,0 +1,43 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!--
+ * Licensed to the Apache Software Foundation (ASF) under one
+ * or more contributor license agreements.  See the NOTICE file
+ * distributed with this work for additional information
+ * regarding copyright ownership.  The ASF licenses this file
+ * to you under the Apache License, Version 2.0 (the
+ * "License"); you may not use this file except in compliance
+ * with the License.  You may obtain a copy of the License at
+ * 
+ *   http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing,
+ * software distributed under the License is distributed on an
+ * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+ * KIND, either express or implied.  See the License for the
+ * specific language governing permissions and limitations
+ * under the License.    
+-->
+<schema xmlns="http://www.w3.org/2001/XMLSchema"
+    targetNamespace="http://tuscany.apache.org/xmlns/sca/1.1"
+    xmlns:sca="http://docs.oasis-open.org/ns/opencsa/sca/200903"
+    xmlns:t="http://tuscany.apache.org/xmlns/sca/1.1"
+    elementFormDefault="qualified">
+
+    <import namespace="http://docs.oasis-open.org/ns/opencsa/sca/200903" schemaLocation="sca-1.1-cd04.xsd"/>
+
+    <element name="implementation.eval" type="t:EvalImplementation" substitutionGroup="sca:implementation"/>
+    	
+    <complexType name="EvalImplementation">
+        <complexContent>
+            <extension base="sca:Implementation">
+                <sequence>
+                    <any namespace="##targetNamespace" processContents="lax" 
+                    	minOccurs="0" maxOccurs="unbounded"/>
+                </sequence>
+                <attribute name="location" type="anyURI" use="required"/>
+                <anyAttribute namespace="##any" processContents="lax"/>
+            </extension>
+        </complexContent>
+    </complexType>
+
+</schema>