From bedb446cefc80f6d0ae5ba93f7adae8f408e3710 Mon Sep 17 00:00:00 2001 From: jsdelfino Date: Tue, 5 Jan 2010 09:16:18 +0000 Subject: Refactored eval module to avoid confusion with the python eval module. git-svn-id: http://svn.us.apache.org/repos/asf/tuscany@895952 13f79535-47bb-0310-9956-ffa450edef68 --- sca-cpp/trunk/components/cache/mcache.hpp | 16 +- sca-cpp/trunk/modules/Makefile.am | 2 +- sca-cpp/trunk/modules/eval/Makefile.am | 32 --- sca-cpp/trunk/modules/eval/driver.hpp | 76 ------ sca-cpp/trunk/modules/eval/environment.hpp | 179 ------------- sca-cpp/trunk/modules/eval/eval-shell.cpp | 36 --- sca-cpp/trunk/modules/eval/eval-test.cpp | 231 ---------------- sca-cpp/trunk/modules/eval/eval.hpp | 290 --------------------- sca-cpp/trunk/modules/eval/io.hpp | 217 --------------- sca-cpp/trunk/modules/eval/primitive.hpp | 264 ------------------- .../eval/tuscany-sca-1.1-implementation-eval.xsd | 43 --- sca-cpp/trunk/modules/scheme/Makefile.am | 32 +++ sca-cpp/trunk/modules/scheme/driver.hpp | 76 ++++++ sca-cpp/trunk/modules/scheme/environment.hpp | 179 +++++++++++++ sca-cpp/trunk/modules/scheme/eval-shell.cpp | 36 +++ sca-cpp/trunk/modules/scheme/eval-test.cpp | 231 ++++++++++++++++ sca-cpp/trunk/modules/scheme/eval.hpp | 290 +++++++++++++++++++++ sca-cpp/trunk/modules/scheme/io.hpp | 217 +++++++++++++++ sca-cpp/trunk/modules/scheme/primitive.hpp | 275 +++++++++++++++++++ .../scheme/tuscany-sca-1.1-implementation-eval.xsd | 43 +++ sca-cpp/trunk/modules/server/mod-cpp.hpp | 6 +- sca-cpp/trunk/modules/server/mod-eval.cpp | 6 +- sca-cpp/trunk/modules/server/mod-scheme.hpp | 92 +++++++ sca-cpp/trunk/modules/server/mod-scm.hpp | 94 ------- sca-cpp/trunk/test/store-script/Makefile.am | 2 +- .../trunk/test/store-script/store-script-test.cpp | 18 +- 26 files changed, 1495 insertions(+), 1488 deletions(-) delete mode 100644 sca-cpp/trunk/modules/eval/Makefile.am delete mode 100644 sca-cpp/trunk/modules/eval/driver.hpp delete mode 100644 sca-cpp/trunk/modules/eval/environment.hpp delete mode 100644 sca-cpp/trunk/modules/eval/eval-shell.cpp delete mode 100644 sca-cpp/trunk/modules/eval/eval-test.cpp delete mode 100644 sca-cpp/trunk/modules/eval/eval.hpp delete mode 100644 sca-cpp/trunk/modules/eval/io.hpp delete mode 100644 sca-cpp/trunk/modules/eval/primitive.hpp delete mode 100644 sca-cpp/trunk/modules/eval/tuscany-sca-1.1-implementation-eval.xsd create mode 100644 sca-cpp/trunk/modules/scheme/Makefile.am create mode 100644 sca-cpp/trunk/modules/scheme/driver.hpp create mode 100644 sca-cpp/trunk/modules/scheme/environment.hpp create mode 100644 sca-cpp/trunk/modules/scheme/eval-shell.cpp create mode 100644 sca-cpp/trunk/modules/scheme/eval-test.cpp create mode 100644 sca-cpp/trunk/modules/scheme/eval.hpp create mode 100644 sca-cpp/trunk/modules/scheme/io.hpp create mode 100644 sca-cpp/trunk/modules/scheme/primitive.hpp create mode 100644 sca-cpp/trunk/modules/scheme/tuscany-sca-1.1-implementation-eval.xsd create mode 100644 sca-cpp/trunk/modules/server/mod-scheme.hpp delete mode 100644 sca-cpp/trunk/modules/server/mod-scm.hpp diff --git a/sca-cpp/trunk/components/cache/mcache.hpp b/sca-cpp/trunk/components/cache/mcache.hpp index 3f32a47964..fac9c7dbb3 100644 --- a/sca-cpp/trunk/components/cache/mcache.hpp +++ b/sca-cpp/trunk/components/cache/mcache.hpp @@ -39,7 +39,7 @@ #include "value.hpp" #include "monad.hpp" #include "debug.hpp" -#include "../../modules/eval/eval.hpp" +#include "../../modules/scheme/eval.hpp" namespace tuscany { namespace cache { @@ -97,8 +97,8 @@ const failable post(const value& key, const value& val, const MemCached& c debug(key, "cache::post::key"); debug(val, "cache::post::value"); - const string ks(eval::writeValue(key)); - const string vs(eval::writeValue(val)); + const string ks(scheme::writeValue(key)); + const string vs(scheme::writeValue(val)); const apr_status_t rc = apr_memcache_add(cache.mc, c_str(ks), const_cast(c_str(vs)), length(vs), 0, 27); if (rc != APR_SUCCESS) return mkfailure("Could not add entry"); @@ -114,8 +114,8 @@ const failable put(const value& key, const value& val, const MemCached& ca debug(key, "cache::put::key"); debug(val, "cache::put::value"); - const string ks(eval::writeValue(key)); - const string vs(eval::writeValue(val)); + const string ks(scheme::writeValue(key)); + const string vs(scheme::writeValue(val)); const apr_status_t rc = apr_memcache_set(cache.mc, c_str(ks), const_cast(c_str(vs)), length(vs), 0, 27); if (rc != APR_SUCCESS) return mkfailure("Could not add entry"); @@ -130,7 +130,7 @@ const failable put(const value& key, const value& val, const MemCached& ca const failable get(const value& key, const MemCached& cache) { debug(key, "cache::get::key"); - const string ks(eval::writeValue(key)); + const string ks(scheme::writeValue(key)); apr_pool_t* vpool; const apr_status_t pc = apr_pool_create(&vpool, cache.pool); if (pc != APR_SUCCESS) @@ -144,7 +144,7 @@ const failable get(const value& key, const MemCached& cache) { return mkfailure("Could not get entry"); } - const value val(eval::readValue(string(data, size))); + const value val(scheme::readValue(string(data, size))); apr_pool_destroy(vpool); debug(val, "cache::get::result"); @@ -157,7 +157,7 @@ const failable get(const value& key, const MemCached& cache) { const failable del(const value& key, const MemCached& cache) { debug(key, "cache::delete::key"); - const string ks(eval::writeValue(key)); + const string ks(scheme::writeValue(key)); const apr_status_t rc = apr_memcache_delete(cache.mc, c_str(ks), 0); if (rc != APR_SUCCESS) return mkfailure("Could not delete entry"); diff --git a/sca-cpp/trunk/modules/Makefile.am b/sca-cpp/trunk/modules/Makefile.am index 3b2d60b93a..0c3b67347f 100644 --- a/sca-cpp/trunk/modules/Makefile.am +++ b/sca-cpp/trunk/modules/Makefile.am @@ -15,7 +15,7 @@ # specific language governing permissions and limitations # under the License. -SUBDIRS = atom eval json scdl http server +SUBDIRS = atom scheme json scdl http server includedir = $(prefix)/include/modules nobase_include_HEADERS = */*.hpp diff --git a/sca-cpp/trunk/modules/eval/Makefile.am b/sca-cpp/trunk/modules/eval/Makefile.am deleted file mode 100644 index ecf2a6e332..0000000000 --- a/sca-cpp/trunk/modules/eval/Makefile.am +++ /dev/null @@ -1,32 +0,0 @@ -# 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/eval/driver.hpp b/sca-cpp/trunk/modules/eval/driver.hpp deleted file mode 100644 index 2d1badf501..0000000000 --- a/sca-cpp/trunk/modules/eval/driver.hpp +++ /dev/null @@ -1,76 +0,0 @@ -/* - * 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_eval_driver_hpp -#define tuscany_eval_driver_hpp - -/** - * Script evaluator main driver loop. - */ - -#include "string.hpp" -#include "stream.hpp" -#include "eval.hpp" - -namespace tuscany { -namespace eval { - -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(compoundProcedureSymbol, procedureParameters(val), procedureBody(val), ""), out); - writeValue(val, out); - return true; -} - -const value evalDriverLoop(istream& in, ostream& out, Env& globalEnv, const gc_pool& pool) { - promptForInput(evalInputPrompt, out); - value input = readValue(in); - if (isNil(input)) - return input; - const value output = evalExpr(input, globalEnv, pool); - announceOutput(evalOutputPrompt, out); - userPrint(output, out); - return evalDriverLoop(in, out, globalEnv, 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_eval_driver_hpp */ diff --git a/sca-cpp/trunk/modules/eval/environment.hpp b/sca-cpp/trunk/modules/eval/environment.hpp deleted file mode 100644 index 29bb3b64da..0000000000 --- a/sca-cpp/trunk/modules/eval/environment.hpp +++ /dev/null @@ -1,179 +0,0 @@ -/* - * 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_eval_environment_hpp -#define tuscany_eval_environment_hpp - -/** - * Script evaluator environment implementation. - */ - -#include "string.hpp" -#include "list.hpp" -#include "value.hpp" -#include "primitive.hpp" -#include - -namespace tuscany { -namespace eval { - -typedef value Frame; -typedef list 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(); -} - -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 firstFrame(const Env& env) { - return car(env); -} - -list frameVariables(const Frame& frame) { - return car((list )frame); -} - -list frameValues(const Frame& frame) { - return cdr((list )frame); -} - -const bool isDotVariable(const value& var) { - return var == dotSymbol; -} - -const Frame makeBinding(const Frame& frameSoFar, const list& variables, const list 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(values)); - - if (isNil(values)) { - if (!isNil(variables)) - logStream() << "Too few arguments supplied " << variables << endl; - return frameSoFar; - } - - const list vars = cons(car(variables), frameVariables(frameSoFar)); - const list vals = cons(car(values), frameValues(frameSoFar)); - const Frame newFrame = cons(value(vars), vals); - - return makeBinding(newFrame, cdr(variables), cdr(values)); -} - -const gc_ptr makeFrame(const list& variables, const list values, const gc_pool& pool) { - gc_ptr frame = new (gc_new(pool)) Frame(); - *frame = value(makeBinding(cons(value(list()), list()), variables, values)); - return frame; -} - -const value definitionVariable(const value& exp) { - const list exps(exp); - if(isSymbol(car(cdr(exps)))) - return car(cdr(exps)); - const list lexps(car(cdr(exps))); - return car(lexps); -} - -const value definitionValue(const value& exp) { - const list exps(exp); - if(isSymbol(car(cdr(exps)))) - return car(cdr(cdr(exps))); - const list lexps(car(cdr(exps))); - return makeLambda(cdr(lexps), cdr(cdr(exps))); -} - -const value assignmentVariable(const value& exp) { - return car(cdr((list )exp)); -} - -const value assignmentValue(const value& exp) { - return car(cdr(cdr((list )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& vars, const list& vals, const Env& baseEnv, const gc_pool& pool) { - return cons(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& vars, const list& 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_eval_environment_hpp */ diff --git a/sca-cpp/trunk/modules/eval/eval-shell.cpp b/sca-cpp/trunk/modules/eval/eval-shell.cpp deleted file mode 100644 index f73ac61250..0000000000 --- a/sca-cpp/trunk/modules/eval/eval-shell.cpp +++ /dev/null @@ -1,36 +0,0 @@ -/* - * 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 -#include "gc.hpp" -#include "stream.hpp" -#include "string.hpp" -#include "driver.hpp" - -int main() { - tuscany::gc_scoped_pool pool; - tuscany::eval::evalDriverRun(tuscany::cin, tuscany::cout, pool); - return 0; -} diff --git a/sca-cpp/trunk/modules/eval/eval-test.cpp b/sca-cpp/trunk/modules/eval/eval-test.cpp deleted file mode 100644 index 3cf16f602f..0000000000 --- a/sca-cpp/trunk/modules/eval/eval-test.cpp +++ /dev/null @@ -1,231 +0,0 @@ -/* - * 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 -#include "stream.hpp" -#include "string.hpp" -#include "driver.hpp" - -namespace tuscany { -namespace eval { - -bool testEnv() { - gc_scoped_pool pool; - Env globalEnv = list(); - Env env = extendEnvironment(mklist("a"), mklist(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("abcd", "xyz")); - - istringstream is5("(abcd (xyz tuv))"); - assert(readValue(is5) == mklist("abcd", mklist("xyz", "tuv"))); - - return true; -} - -bool testWrite() { - const list i = list() - + (list() + "item" + "cart-53d67a61-aa5e-4e5e-8401-39edeba8b83b" - + (list() + "item" - + (list() + "name" + "Apple") - + (list() + "price" + "$2.99"))) - + (list() + "item" + "cart-53d67a61-aa5e-4e5e-8401-39edeba8b83c" - + (list() + "item" - + (list() + "name" + "Orange") - + (list() + "price" + "$3.55"))); - const list a = cons("Feed", cons("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("+", 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& 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("testReturnLambda"); - istringstream trlis(testReturnLambda); - const value trlv = evalScript(trl, trlis, env, pool); - - istringstream tclis(testCallLambda); - const value tcl = cons("testCallLambda", quotedParameters(mklist(trlv, 2, 3))); - const value tclv = evalScript(tcl, tclis, env, pool); - assert(tclv == value(6)); - - istringstream tcelis(testCallLambda); - const value tcel = cons("testCallLambda", quotedParameters(mklist(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::eval::testEnv(); - tuscany::eval::testEnvGC(); - tuscany::eval::testRead(); - tuscany::eval::testWrite(); - tuscany::eval::testEval(); - tuscany::eval::testEvalExpr(); - tuscany::eval::testEvalLambda(); - tuscany::eval::testEvalGC(); - - tuscany::cout << "OK" << tuscany::endl; - return 0; -} diff --git a/sca-cpp/trunk/modules/eval/eval.hpp b/sca-cpp/trunk/modules/eval/eval.hpp deleted file mode 100644 index ea6e2da13a..0000000000 --- a/sca-cpp/trunk/modules/eval/eval.hpp +++ /dev/null @@ -1,290 +0,0 @@ -/* - * 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_eval_eval_hpp -#define tuscany_eval_eval_hpp - -/** - * Core script evaluation logic. - */ - -#include -#include "list.hpp" -#include "value.hpp" -#include "primitive.hpp" -#include "io.hpp" -#include "environment.hpp" - -namespace tuscany { -namespace eval { - -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 beginActions(const value& exp) { - return cdr((list )exp); -} - -const bool isLambdaExpr(const value& exp) { - return isTaggedList(exp, lambdaSymbol); -} - -const list lambdaParameters(const value& exp) { - return car(cdr((list )exp)); -} - -static list lambdaBody(const value& exp) { - return cdr(cdr((list )exp)); -} - -const value makeProcedure(const list& parameters, const value& body, const Env& env) { - return mklist(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 )exp); -} - -const list operands(const value& exp) { - return cdr((list )exp); -} - -const list listOfValues(const list exps, Env& env, const gc_pool& pool) { - if(isNil(exps)) - return list (); - return cons(evalExpr(car(exps), env, pool), listOfValues(cdr(exps), env, pool)); -} - -const value applyOperat(const value& exp) { - return cadr((list )exp); -} - -const value applyOperand(const value& exp) { - return caddr((list )exp); -} - -const bool isCompoundProcedure(const value& procedure) { - return isTaggedList(procedure, procedureSymbol); -} - -const list procedureParameters(const value& exp) { - return car(cdr((list )exp)); -} - -const value procedureBody(const value& exp) { - return car(cdr(cdr((list )exp))); -} - -const Env procedureEnvironment(const value& exp) { - return (Env)car(cdr(cdr(cdr((list )exp)))); -} - -const bool isLastExp(const list& seq) { - return isNil(cdr(seq)); -} - -const value firstExp(const list& seq) { - return car(seq); -} - -const list restExp(const list& seq) { - return cdr(seq); -} - -const value makeBegin(const list seq) { - return cons(beginSymbol, seq); -} - -const value evalSequence(const list& 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& 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 exps) { - if(isNil(exps)) - return exps; - if(isLastExp(exps)) - return firstExp(exps); - return makeBegin(exps); -} - -const list condClauses(const value& exp) { - return cdr((list )exp); -} - -const value condPredicate(const value& clause) { - return car((list )clause); -} - -const list condActions(const value& clause) { - return cdr((list )clause); -} - -const value ifPredicate(const value& exp) { - return car(cdr((list )exp)); -} - -const value ifConsequent(const value& exp) { - return car(cdr(cdr((list )exp))); -} - -const value ifAlternative(const value& exp) { - if(!isNil(cdr(cdr(cdr((list )exp))))) - return car(cdr(cdr(cdr((list )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& clauses) { - if(isNil(clauses)) - return false; - const value first = car(clauses); - const list 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 applyOperandValues = evalExpr(applyOperand(exp), env, pool); - return applyProcedure(evalExpr(applyOperat(exp), env, pool), applyOperandValues, pool); - } - if(isApplication(exp)) { - list 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 quotedParameters(const list& p) { - if (isNil(p)) - return p; - return cons(mklist(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& script, eval::Env& globalEnv, const gc_pool& pool) { - if (isNil(script)) - return eval::evalExpr(expr, globalEnv, pool); - eval::evalExpr(car(script), globalEnv, pool); - return evalScriptLoop(expr, cdr(script), globalEnv, 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_eval_eval_hpp */ diff --git a/sca-cpp/trunk/modules/eval/io.hpp b/sca-cpp/trunk/modules/eval/io.hpp deleted file mode 100644 index 0c2abb3af9..0000000000 --- a/sca-cpp/trunk/modules/eval/io.hpp +++ /dev/null @@ -1,217 +0,0 @@ -/* - * 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_eval_io_hpp -#define tuscany_eval_io_hpp - -/** - * Script evaluator IO functions. - */ - -#include -#include "stream.hpp" -#include "string.hpp" - -#include "list.hpp" -#include "value.hpp" -#include "primitive.hpp" - -namespace tuscany { -namespace eval { - -const value rightParenthesis(mklist(")")); -const value leftParenthesis(mklist("(")); -const value comment(mklist(";")); - -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 readList(const list& 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 (), in)), listSoFar), in); - return readList(cons(token, listSoFar), in); -} - -const string listToString(const list& l) { - if(isNil(l)) - return ""; - const char buf[1] = { car(l) }; - return string(buf, 1) + listToString(cdr(l)); -} - -const list readIdentifierHelper(const list& 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 readStringHelper(const list& 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(), in)); -} - -const list readNumberHelper(const list& 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 (), in); - return nextToken; -} - -const value readValue(const string s) { - istringstream in(s); - const value nextToken = readToken(in); - if(isLeftParenthesis(nextToken)) - return readList(list (), 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(); - return cons(val, (list)readScript(in)); -} - -} -} -#endif /* tuscany_eval_io_hpp */ diff --git a/sca-cpp/trunk/modules/eval/primitive.hpp b/sca-cpp/trunk/modules/eval/primitive.hpp deleted file mode 100644 index 75d691c4ac..0000000000 --- a/sca-cpp/trunk/modules/eval/primitive.hpp +++ /dev/null @@ -1,264 +0,0 @@ -/* - * 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_eval_primitive_hpp -#define tuscany_eval_primitive_hpp - -/** - * Script evaluator primitive functions. - */ - -#include -#include -#include "stream.hpp" -#include "function.hpp" -#include "list.hpp" -#include "value.hpp" - -namespace tuscany { -namespace eval { - -const value primitiveSymbol("primitive"); -const value quoteSymbol("'"); -const value lambdaSymbol("lambda"); - -ostream* displayOutStream = &cout; -ostream* logOutStream = &cerr; - -const bool setupDisplay(ostream& out) { - displayOutStream = &out; - return true; -} - -ostream& displayStream() { - return *displayOutStream; -} - -const bool setupLog(ostream& out) { - logOutStream = &out; - return true; -} - -ostream& logStream() { - return *logOutStream; -} - -const value carProc(const list& args) { - return car((list )car(args)); -} - -const value cdrProc(const list& args) { - return cdr((list )car(args)); -} - -const value consProc(const list& args) { - return cons(car(args), (list )cadr(args)); -} - -const value listProc(const list& args) { - return args; -} - -const value assocProc(const list& args) { - return assoc(car(args), (list >)cadr(args)); -} - -const value nulProc(const list& args) { - const value v(car(args)); - if (isNil(v)) - return true; - if (isList(v)) - return isNil(list(v)); - return false; -} - -const value equalProc(const list& args) { - return (bool)(car(args) == cadr(args)); -} - -const value addProc(const list& args) { - if (isNil(cdr(args))) - return (double)car(args); - return (double)car(args) + (double)cadr(args); -} - -const value subProc(const list& args) { - if (isNil(cdr(args))) - return (double)0 - (double)car(args); - return (double)car(args) - (double)cadr(args); -} - -const value mulProc(const list& args) { - return (double)car(args) * (double)cadr(args); -} - -const value divProc(const list& args) { - return (double)car(args) / (double)cadr(args); -} - -const value displayProc(const list& args) { - if (isNil(args)) { - displayStream() << endl; - return true; - } - displayStream() << car(args); - return displayProc(cdr(args)); -} - -const value logProc(const list& args) { - if (isNil(args)) { - logStream() << endl; - return true; - } - logStream() << car(args); - return logProc(cdr(args)); -} - -const value uuidProc(unused const list& 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& args) { - return cadr((list )car(args)); -} - -const value caddrProc(unused const list& args) { - return caddr((list )car(args)); -} - -const value cadddrProc(unused const list& args) { - return cadddr((list )car(args)); -} - -const value cddrProc(unused const list& args) { - return cddr((list )car(args)); -} - -const value cdddrProc(unused const list& args) { - return cdddr((list )car(args)); -} - -const value applyPrimitiveProcedure(const value& proc, list& args) { - const lambda&)> func(cadr((list)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& proc) { - return car(cdr(proc)); -} - -template const value primitiveProcedure(const F& f) { - return mklist(primitiveSymbol, (lambda&)>)f); -} - -const list primitiveProcedureNames() { - return mklist("car") - + "cdr" - + "cons" - + "list" - + "nul" - + "=" - + "equal?" - + "+" - + "-" - + "*" - + "/" - + "assoc" - + "cadr" - + "caddr" - + "cadddr" - + "cddr" - + "cdddr" - + "display" - + "log" - + "uuid"; -} - -const list 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 )exp)); -} - -const value makeLambda(const list& parameters, const list& body) { - return cons(lambdaSymbol, cons(parameters, body)); -} - -} -} -#endif /* tuscany_eval_primitive_hpp */ diff --git a/sca-cpp/trunk/modules/eval/tuscany-sca-1.1-implementation-eval.xsd b/sca-cpp/trunk/modules/eval/tuscany-sca-1.1-implementation-eval.xsd deleted file mode 100644 index bbf4935346..0000000000 --- a/sca-cpp/trunk/modules/eval/tuscany-sca-1.1-implementation-eval.xsd +++ /dev/null @@ -1,43 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - 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(compoundProcedureSymbol, procedureParameters(val), procedureBody(val), ""), 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 + +namespace tuscany { +namespace scheme { + +typedef value Frame; +typedef list 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(); +} + +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 firstFrame(const Env& env) { + return car(env); +} + +list frameVariables(const Frame& frame) { + return car((list )frame); +} + +list frameValues(const Frame& frame) { + return cdr((list )frame); +} + +const bool isDotVariable(const value& var) { + return var == dotSymbol; +} + +const Frame makeBinding(const Frame& frameSoFar, const list& variables, const list 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(values)); + + if (isNil(values)) { + if (!isNil(variables)) + logStream() << "Too few arguments supplied " << variables << endl; + return frameSoFar; + } + + const list vars = cons(car(variables), frameVariables(frameSoFar)); + const list vals = cons(car(values), frameValues(frameSoFar)); + const Frame newFrame = cons(value(vars), vals); + + return makeBinding(newFrame, cdr(variables), cdr(values)); +} + +const gc_ptr makeFrame(const list& variables, const list values, const gc_pool& pool) { + gc_ptr frame = new (gc_new(pool)) Frame(); + *frame = value(makeBinding(cons(value(list()), list()), variables, values)); + return frame; +} + +const value definitionVariable(const value& exp) { + const list exps(exp); + if(isSymbol(car(cdr(exps)))) + return car(cdr(exps)); + const list lexps(car(cdr(exps))); + return car(lexps); +} + +const value definitionValue(const value& exp) { + const list exps(exp); + if(isSymbol(car(cdr(exps)))) + return car(cdr(cdr(exps))); + const list lexps(car(cdr(exps))); + return makeLambda(cdr(lexps), cdr(cdr(exps))); +} + +const value assignmentVariable(const value& exp) { + return car(cdr((list )exp)); +} + +const value assignmentValue(const value& exp) { + return car(cdr(cdr((list )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& vars, const list& vals, const Env& baseEnv, const gc_pool& pool) { + return cons(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& vars, const list& 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 +#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 +#include "stream.hpp" +#include "string.hpp" +#include "driver.hpp" + +namespace tuscany { +namespace scheme { + +bool testEnv() { + gc_scoped_pool pool; + Env globalEnv = list(); + Env env = extendEnvironment(mklist("a"), mklist(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("abcd", "xyz")); + + istringstream is5("(abcd (xyz tuv))"); + assert(readValue(is5) == mklist("abcd", mklist("xyz", "tuv"))); + + return true; +} + +bool testWrite() { + const list i = list() + + (list() + "item" + "cart-53d67a61-aa5e-4e5e-8401-39edeba8b83b" + + (list() + "item" + + (list() + "name" + "Apple") + + (list() + "price" + "$2.99"))) + + (list() + "item" + "cart-53d67a61-aa5e-4e5e-8401-39edeba8b83c" + + (list() + "item" + + (list() + "name" + "Orange") + + (list() + "price" + "$3.55"))); + const list a = cons("Feed", cons("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("+", 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& 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("testReturnLambda"); + istringstream trlis(testReturnLambda); + const value trlv = evalScript(trl, trlis, env, pool); + + istringstream tclis(testCallLambda); + const value tcl = cons("testCallLambda", quotedParameters(mklist(trlv, 2, 3))); + const value tclv = evalScript(tcl, tclis, env, pool); + assert(tclv == value(6)); + + istringstream tcelis(testCallLambda); + const value tcel = cons("testCallLambda", quotedParameters(mklist(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 +#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 beginActions(const value& exp) { + return cdr((list )exp); +} + +const bool isLambdaExpr(const value& exp) { + return isTaggedList(exp, lambdaSymbol); +} + +const list lambdaParameters(const value& exp) { + return car(cdr((list )exp)); +} + +static list lambdaBody(const value& exp) { + return cdr(cdr((list )exp)); +} + +const value makeProcedure(const list& parameters, const value& body, const Env& env) { + return mklist(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 )exp); +} + +const list operands(const value& exp) { + return cdr((list )exp); +} + +const list listOfValues(const list exps, Env& env, const gc_pool& pool) { + if(isNil(exps)) + return list (); + return cons(evalExpr(car(exps), env, pool), listOfValues(cdr(exps), env, pool)); +} + +const value applyOperat(const value& exp) { + return cadr((list )exp); +} + +const value applyOperand(const value& exp) { + return caddr((list )exp); +} + +const bool isCompoundProcedure(const value& procedure) { + return isTaggedList(procedure, procedureSymbol); +} + +const list procedureParameters(const value& exp) { + return car(cdr((list )exp)); +} + +const value procedureBody(const value& exp) { + return car(cdr(cdr((list )exp))); +} + +const Env procedureEnvironment(const value& exp) { + return (Env)car(cdr(cdr(cdr((list )exp)))); +} + +const bool isLastExp(const list& seq) { + return isNil(cdr(seq)); +} + +const value firstExp(const list& seq) { + return car(seq); +} + +const list restExp(const list& seq) { + return cdr(seq); +} + +const value makeBegin(const list seq) { + return cons(beginSymbol, seq); +} + +const value evalSequence(const list& 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& 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 exps) { + if(isNil(exps)) + return exps; + if(isLastExp(exps)) + return firstExp(exps); + return makeBegin(exps); +} + +const list condClauses(const value& exp) { + return cdr((list )exp); +} + +const value condPredicate(const value& clause) { + return car((list )clause); +} + +const list condActions(const value& clause) { + return cdr((list )clause); +} + +const value ifPredicate(const value& exp) { + return car(cdr((list )exp)); +} + +const value ifConsequent(const value& exp) { + return car(cdr(cdr((list )exp))); +} + +const value ifAlternative(const value& exp) { + if(!isNil(cdr(cdr(cdr((list )exp))))) + return car(cdr(cdr(cdr((list )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& clauses) { + if(isNil(clauses)) + return false; + const value first = car(clauses); + const list 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 applyOperandValues = evalExpr(applyOperand(exp), env, pool); + return applyProcedure(evalExpr(applyOperat(exp), env, pool), applyOperandValues, pool); + } + if(isApplication(exp)) { + list 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 quotedParameters(const list& p) { + if (isNil(p)) + return p; + return cons(mklist(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& 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 +#include "stream.hpp" +#include "string.hpp" + +#include "list.hpp" +#include "value.hpp" +#include "primitive.hpp" + +namespace tuscany { +namespace scheme { + +const value rightParenthesis(mklist(")")); +const value leftParenthesis(mklist("(")); +const value comment(mklist(";")); + +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 readList(const list& 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 (), in)), listSoFar), in); + return readList(cons(token, listSoFar), in); +} + +const string listToString(const list& l) { + if(isNil(l)) + return ""; + const char buf[1] = { car(l) }; + return string(buf, 1) + listToString(cdr(l)); +} + +const list readIdentifierHelper(const list& 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 readStringHelper(const list& 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(), in)); +} + +const list readNumberHelper(const list& 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 (), in); + return nextToken; +} + +const value readValue(const string s) { + istringstream in(s); + const value nextToken = readToken(in); + if(isLeftParenthesis(nextToken)) + return readList(list (), 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(); + return cons(val, (list)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 +#include +#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& args) { + return car((list )car(args)); +} + +const value cdrProc(const list& args) { + return cdr((list )car(args)); +} + +const value consProc(const list& args) { + return cons(car(args), (list )cadr(args)); +} + +const value listProc(const list& args) { + return args; +} + +const value assocProc(const list& args) { + return assoc(car(args), (list >)cadr(args)); +} + +const value nulProc(const list& args) { + const value v(car(args)); + if (isNil(v)) + return true; + if (isList(v)) + return isNil(list(v)); + return false; +} + +const value equalProc(const list& args) { + return (bool)(car(args) == cadr(args)); +} + +const value addProc(const list& args) { + if (isNil(cdr(args))) + return (double)car(args); + return (double)car(args) + (double)cadr(args); +} + +const value subProc(const list& args) { + if (isNil(cdr(args))) + return (double)0 - (double)car(args); + return (double)car(args) - (double)cadr(args); +} + +const value mulProc(const list& args) { + return (double)car(args) * (double)cadr(args); +} + +const value divProc(const list& args) { + return (double)car(args) / (double)cadr(args); +} + +const value displayProc(const list& args) { + if (isNil(args)) { + displayStream() << endl; + return true; + } + displayStream() << car(args); + return displayProc(cdr(args)); +} + +const value logProc(const list& args) { + if (isNil(args)) { + logStream() << endl; + return true; + } + logStream() << car(args); + return logProc(cdr(args)); +} + +const value uuidProc(unused const list& 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& args) { + return cadr((list )car(args)); +} + +const value caddrProc(unused const list& args) { + return caddr((list )car(args)); +} + +const value cadddrProc(unused const list& args) { + return cadddr((list )car(args)); +} + +const value cddrProc(unused const list& args) { + return cddr((list )car(args)); +} + +const value cdddrProc(unused const list& args) { + return cdddr((list )car(args)); +} + +const value applyPrimitiveProcedure(const value& proc, list& args) { + const lambda&)> func(cadr((list)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& proc) { + return car(cdr(proc)); +} + +template const value primitiveProcedure(const F& f) { + return mklist(primitiveSymbol, (lambda&)>)f); +} + +const list primitiveProcedureNames() { + return mklist("car") + + "cdr" + + "cons" + + "list" + + "nul" + + "=" + + "equal?" + + "+" + + "-" + + "*" + + "/" + + "assoc" + + "cadr" + + "caddr" + + "cadddr" + + "cddr" + + "cdddr" + + "display" + + "log" + + "uuid"; +} + +const list 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 )exp)); +} + +const value makeLambda(const list& parameters, const list& body) { + return cons(lambdaSymbol, cons(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 @@ + + + + + + + + + + + + + + + + + + + + + diff --git a/sca-cpp/trunk/modules/server/mod-cpp.hpp b/sca-cpp/trunk/modules/server/mod-cpp.hpp index 17d44e1428..93abd84590 100644 --- a/sca-cpp/trunk/modules/server/mod-cpp.hpp +++ b/sca-cpp/trunk/modules/server/mod-cpp.hpp @@ -36,13 +36,12 @@ #include "debug.hpp" #include "monad.hpp" #include "dynlib.hpp" -#include "../eval/driver.hpp" +#include "../scheme/driver.hpp" #include "../http/httpd.hpp" namespace tuscany { namespace server { -namespace modeval { -namespace cpp { +namespace modcpp { /** * Evaluate a C++ component implementation function. @@ -75,6 +74,5 @@ const failable&)> > readImplementation(const stri } } } -} #endif /* tuscany_modcpp_hpp */ diff --git a/sca-cpp/trunk/modules/server/mod-eval.cpp b/sca-cpp/trunk/modules/server/mod-eval.cpp index 8e8870dd52..c5e71e108c 100644 --- a/sca-cpp/trunk/modules/server/mod-eval.cpp +++ b/sca-cpp/trunk/modules/server/mod-eval.cpp @@ -36,7 +36,7 @@ #include "../scdl/scdl.hpp" #include "../http/curl.hpp" #include "../http/httpd.hpp" -#include "mod-scm.hpp" +#include "mod-scheme.hpp" #include "mod-cpp.hpp" extern "C" { @@ -275,9 +275,9 @@ const list proxies(const list& refs, const string& base) { */ const failable&)> > readImplementation(const string& itype, const string& path, const list& px) { if (contains(itype, ".scheme")) - return scm::readImplementation(path, px); + return modscheme::readImplementation(path, px); if (contains(itype, ".cpp")) - return cpp::readImplementation(path, px); + return modcpp::readImplementation(path, px); return mkfailure&)> >(string("Unsupported implementation type: ") + itype); } diff --git a/sca-cpp/trunk/modules/server/mod-scheme.hpp b/sca-cpp/trunk/modules/server/mod-scheme.hpp new file mode 100644 index 0000000000..13b4ac5760 --- /dev/null +++ b/sca-cpp/trunk/modules/server/mod-scheme.hpp @@ -0,0 +1,92 @@ +/* + * 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_modscm_hpp +#define tuscany_modscm_hpp + +/** + * Evaluation functions used by mod-eval to evaluate implementation.scheme + * component implementations. + */ + +#include "string.hpp" +#include "stream.hpp" +#include "function.hpp" +#include "list.hpp" +#include "value.hpp" +#include "debug.hpp" +#include "monad.hpp" +#include "../scheme/primitive.hpp" +#include "../scheme/driver.hpp" +#include "../http/httpd.hpp" + +namespace tuscany { +namespace server { +namespace modscheme { + +/** + * Convert proxy lambdas to evaluator primitive procedures. + */ +const list primitiveProcedures(const list& l) { + if (isNil(l)) + return l; + return cons(mklist(scheme::primitiveSymbol, car(l)), primitiveProcedures(cdr(l))); +} + +/** + * Evaluate a script component implementation function. + */ +struct evalImplementation { + const value impl; + const list px; + evalImplementation(const value& impl, const list& px) : impl(impl), px(scheme::quotedParameters(primitiveProcedures(px))) { + } + const value operator()(const list& params) const { + const value expr = cons(car(params), append(scheme::quotedParameters(cdr(params)), px)); + debug(expr, "modeval::scm::evalImplementation::input"); + gc_pool pool(gc_current_pool()); + scheme::Env globalEnv = scheme::setupEnvironment(pool); + const value val = scheme::evalScript(expr, impl, globalEnv, pool); + debug(val, "modeval::scm::evalImplementation::result"); + if (isNil(val)) + return mklist(value(), string("Could not evaluate expression")); + return mklist(val); + } +}; + +/** + * Read a script component implementation. + */ +const failable&)> > readImplementation(const string& path, const list& px) { + ifstream is(path); + if (fail(is)) + return mkfailure&)> >(string("Could not read implementation: ") + path); + const value impl = scheme::readScript(is); + if (isNil(impl)) + return mkfailure&)> >(string("Could not read implementation: ") + path); + return lambda&)>(evalImplementation(impl, px)); +} + +} +} +} + +#endif /* tuscany_modscm_hpp */ diff --git a/sca-cpp/trunk/modules/server/mod-scm.hpp b/sca-cpp/trunk/modules/server/mod-scm.hpp deleted file mode 100644 index 887b1de968..0000000000 --- a/sca-cpp/trunk/modules/server/mod-scm.hpp +++ /dev/null @@ -1,94 +0,0 @@ -/* - * 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_modscm_hpp -#define tuscany_modscm_hpp - -/** - * Evaluation functions used by mod-eval to evaluate implementation.scheme - * component implementations. - */ - -#include "string.hpp" -#include "stream.hpp" -#include "function.hpp" -#include "list.hpp" -#include "value.hpp" -#include "debug.hpp" -#include "monad.hpp" -#include "../eval/primitive.hpp" -#include "../eval/driver.hpp" -#include "../http/httpd.hpp" - -namespace tuscany { -namespace server { -namespace modeval { -namespace scm { - -/** - * Convert proxy lambdas to evaluator primitive procedures. - */ -const list primitiveProcedures(const list& l) { - if (isNil(l)) - return l; - return cons(mklist(eval::primitiveSymbol, car(l)), primitiveProcedures(cdr(l))); -} - -/** - * Evaluate a script component implementation function. - */ -struct evalImplementation { - const value impl; - const list px; - evalImplementation(const value& impl, const list& px) : impl(impl), px(eval::quotedParameters(primitiveProcedures(px))) { - } - const value operator()(const list& params) const { - const value expr = cons(car(params), append(eval::quotedParameters(cdr(params)), px)); - debug(expr, "modeval::scm::evalImplementation::input"); - gc_pool pool(gc_current_pool()); - eval::Env globalEnv = eval::setupEnvironment(pool); - const value val = eval::evalScript(expr, impl, globalEnv, pool); - debug(val, "modeval::scm::evalImplementation::result"); - if (isNil(val)) - return mklist(value(), string("Could not evaluate expression")); - return mklist(val); - } -}; - -/** - * Read a script component implementation. - */ -const failable&)> > readImplementation(const string& path, const list& px) { - ifstream is(path); - if (fail(is)) - return mkfailure&)> >(string("Could not read implementation: ") + path); - const value impl = eval::readScript(is); - if (isNil(impl)) - return mkfailure&)> >(string("Could not read implementation: ") + path); - return lambda&)>(evalImplementation(impl, px)); -} - -} -} -} -} - -#endif /* tuscany_modscm_hpp */ diff --git a/sca-cpp/trunk/test/store-script/Makefile.am b/sca-cpp/trunk/test/store-script/Makefile.am index 7e8413ba91..fc6a1f88fb 100644 --- a/sca-cpp/trunk/test/store-script/Makefile.am +++ b/sca-cpp/trunk/test/store-script/Makefile.am @@ -17,7 +17,7 @@ noinst_PROGRAMS = store-script-test -INCLUDES = -I. -I$(top_builddir)/kernel -I$(top_builddir)/modules/eval -I${LIBXML2_INCLUDE} -I${APR_INCLUDE} -I${JS_INCLUDE} +INCLUDES = -I. -I$(top_builddir)/kernel -I${LIBXML2_INCLUDE} -I${APR_INCLUDE} -I${JS_INCLUDE} store_script_test_SOURCES = store-script-test.cpp store_script_test_LDADD = -L${LIBXML2_LIB} -lxml2 -L${APR_LIB} -lapr-1 -laprutil-1 -L${JS_LIB} -lmozjs diff --git a/sca-cpp/trunk/test/store-script/store-script-test.cpp b/sca-cpp/trunk/test/store-script/store-script-test.cpp index a85b661b43..05aefcaf8c 100644 --- a/sca-cpp/trunk/test/store-script/store-script-test.cpp +++ b/sca-cpp/trunk/test/store-script/store-script-test.cpp @@ -28,9 +28,9 @@ #include "stream.hpp" #include "string.hpp" #include "list.hpp" -#include "driver.hpp" #include "xml.hpp" -#include "../json/json.hpp" +#include "../../modules/scheme/driver.hpp" +#include "../../modules/json/json.hpp" namespace store { @@ -41,7 +41,7 @@ bool testScript() { ifstream is("store-script.scm"); ostringstream os; - eval::evalDriverRun(is, os, pool); + scheme::evalDriverRun(is, os, pool); assert(contains(str(os), "(\"Sample Feed\" \"")); assert(contains(str(os), "\" (\"Item\" \"")); assert(contains(str(os), "\" ((javaClass \"services.Item\") (name \"Orange\") (currencyCode \"USD\") (currencySymbol \"$\") (price 3.55))) (\"Item\" \"")); @@ -54,10 +54,10 @@ bool testEval() { gc_scoped_pool pool; ifstream is("store-script.scm"); ostringstream os; - eval::setupDisplay(os); - eval::Env globalEnv = eval::setupEnvironment(pool); + scheme::setupDisplay(os); + scheme::Env globalEnv = scheme::setupEnvironment(pool); const value exp(mklist("storeui_service", string("getcatalog"))); - const value val = eval::evalScript(exp, is, globalEnv, pool); + const value val = scheme::evalScript(exp, is, globalEnv, pool); ostringstream vs; vs << val; @@ -68,11 +68,11 @@ bool testEval() { gc_scoped_pool pool; ifstream is("store-script.scm"); ostringstream os; - eval::setupDisplay(os); + scheme::setupDisplay(os); - eval::Env globalEnv = eval::setupEnvironment(pool); + scheme::Env globalEnv = scheme::setupEnvironment(pool); const value exp(mklist("storeui_service", string("gettotal"))); - const value res = eval::evalScript(exp, is, globalEnv, pool); + const value res = scheme::evalScript(exp, is, globalEnv, pool); ostringstream rs; rs << res; -- cgit v1.2.3