| /* |
| * 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 <math.h> |
| |
| #include "stream.hpp" |
| #include "function.hpp" |
| #include "list.hpp" |
| #include "tree.hpp" |
| #include "value.hpp" |
| #include "parallel.hpp" |
| |
| namespace tuscany { |
| namespace scheme { |
| |
| const value primitiveSymbol("primitive"); |
| const value quoteSymbol("'"); |
| const value lambdaSymbol("lambda"); |
| |
| #ifdef WANT_THREADS |
| const perthread_ptr<ostream> displayOutStream; |
| #else |
| ostream* displayOutStream = NULL; |
| #endif |
| |
| #ifdef WANT_THREADS |
| perthread_ptr<ostream> logOutStream; |
| #else |
| ostream* logOutStream = NULL; |
| #endif |
| |
| inline const bool setupDisplay(ostream& out) { |
| displayOutStream = &out; |
| return true; |
| } |
| |
| inline ostream& displayStream() { |
| if (displayOutStream == NULL) |
| return cout; |
| return *displayOutStream; |
| } |
| |
| inline const bool setupLog(ostream& out) { |
| logOutStream = &out; |
| return true; |
| } |
| |
| inline ostream& logStream() { |
| if (logOutStream == NULL) |
| return cerr; |
| return *logOutStream; |
| } |
| |
| inline const value carProc(const list<value>& args) { |
| return car((list<value> )car(args)); |
| } |
| |
| inline const value cdrProc(const list<value>& args) { |
| return cdr((list<value> )car(args)); |
| } |
| |
| inline const value consProc(const list<value>& args) { |
| return cons(car(args), (list<value> )cadr(args)); |
| } |
| |
| inline const value listProc(const list<value>& args) { |
| return args; |
| } |
| |
| inline const value assocProc(const list<value>& args) { |
| return assoc(car(args), (list<value>)cadr(args)); |
| } |
| |
| inline const value delAssocProc(const list<value>& args) { |
| return delAssoc(car(args), (list<value>)cadr(args)); |
| } |
| |
| inline const value substAssocProc(const list<value>& args) { |
| return substAssoc(car(args), (list<value>)cadr(args), (list<value>)caddr(args)); |
| } |
| |
| inline const value treeDelAssocProc(const list<value>& args) { |
| return treeDelAssoc((list<value>)car(args), (list<value>)cadr(args)); |
| } |
| |
| inline const value treeSubstAssocProc(const list<value>& args) { |
| return treeSubstAssoc((list<value>)car(args), (list<value>)cadr(args), (list<value>)caddr(args)); |
| } |
| |
| inline const value treeSelectAssocProc(const list<value>& args) { |
| return treeSelectAssoc((list<value>)car(args), (list<value>)cadr(args)); |
| } |
| |
| inline const value nullProc(const list<value>& args) { |
| const value v(car(args)); |
| if (isNull(v)) |
| return true; |
| if (isList(v)) |
| return isNull(list<value>(v)); |
| return false; |
| } |
| |
| inline const value equalProc(const list<value>& args) { |
| return (bool)(car(args) == cadr(args)); |
| } |
| |
| inline const value greaterProc(const list<value>& args) { |
| return (bool)(car(args) > cadr(args)); |
| } |
| |
| inline const value lesserProc(const list<value>& args) { |
| return (bool)(car(args) < cadr(args)); |
| } |
| |
| inline const value addProc(const list<value>& args) { |
| if (isNull(cdr(args))) |
| return (double)car(args); |
| return (double)car(args) + (double)cadr(args); |
| } |
| |
| inline const value subProc(const list<value>& args) { |
| if (isNull(cdr(args))) |
| return (double)0 - (double)car(args); |
| return (double)car(args) - (double)cadr(args); |
| } |
| |
| inline const value mulProc(const list<value>& args) { |
| return (double)car(args) * (double)cadr(args); |
| } |
| |
| inline const value divProc(const list<value>& args) { |
| return (double)car(args) / (double)cadr(args); |
| } |
| |
| inline const value sqrtProc(const list<value>& args) { |
| return (double)sqrt((double)car(args)); |
| } |
| |
| inline const value displayProc(const list<value>& args) { |
| if (isNull(args)) { |
| displayStream() << endl; |
| return true; |
| } |
| displayStream() << car(args); |
| return displayProc(cdr(args)); |
| } |
| |
| inline const value logProc(const list<value>& args) { |
| if (isNull(args)) { |
| logStream() << endl; |
| return true; |
| } |
| logStream() << car(args); |
| return logProc(cdr(args)); |
| } |
| |
| inline const value uuidProc(unused const list<value>& args) { |
| return mkuuid(); |
| } |
| |
| inline const value cadrProc(const list<value>& args) { |
| return cadr((list<value> )car(args)); |
| } |
| |
| inline const value caddrProc(const list<value>& args) { |
| return caddr((list<value> )car(args)); |
| } |
| |
| inline const value cadddrProc(const list<value>& args) { |
| return cadddr((list<value> )car(args)); |
| } |
| |
| inline const value cddrProc(const list<value>& args) { |
| return cddr((list<value> )car(args)); |
| } |
| |
| inline const value cdddrProc(const list<value>& args) { |
| return cdddr((list<value> )car(args)); |
| } |
| |
| inline const value appendProc(const list<value>& args) { |
| return append((list<value> )car(args), (list<value>)cadr(args)); |
| } |
| |
| inline const value startProc(unused const list<value>& args) { |
| return lvvlambda(); |
| } |
| |
| inline const value stopProc(unused const list<value>& args) { |
| return lvvlambda(); |
| } |
| |
| inline const value applyPrimitiveProcedure(const value& proc, list<value>& args) { |
| const lvvlambda func(cadr((list<value>)proc)); |
| return func(args); |
| } |
| |
| inline const bool isPrimitiveProcedure(const value& proc) { |
| return isTaggedList(proc, primitiveSymbol); |
| } |
| |
| inline const bool isSelfEvaluating(const value& exp) { |
| if(isNull(exp)) |
| return true; |
| if(isNumber(exp)) |
| return true; |
| if(isString(exp)) |
| return true; |
| if(isBool(exp)) |
| return true; |
| if(isLambda(exp)) |
| return true; |
| return false; |
| } |
| |
| inline const value primitiveImplementation(const list<value>& proc) { |
| return car(cdr(proc)); |
| } |
| |
| template<typename F> inline const value primitiveProcedure(const F& f) { |
| return mklist<value>(primitiveSymbol, (lvvlambda)f); |
| } |
| |
| inline const list<value> primitiveProcedureNames() { |
| return mklist<value>("car") |
| + "cdr" |
| + "cons" |
| + "list" |
| + "null?" |
| + "=" |
| + "equal?" |
| + "<" |
| + ">" |
| + "+" |
| + "-" |
| + "*" |
| + "/" |
| + "sqrt" |
| + "assoc" |
| + "del-assoc" |
| + "subst-assoc" |
| + "tree-select-assoc" |
| + "tree-del-assoc" |
| + "tree-subst-assoc" |
| + "cadr" |
| + "caddr" |
| + "cadddr" |
| + "cddr" |
| + "cdddr" |
| + "append" |
| + "display" |
| + "log" |
| + "uuid" |
| + "start" |
| + "stop"; |
| } |
| |
| inline const list<value> primitiveProcedureObjects() { |
| return mklist(primitiveProcedure(carProc)) |
| + primitiveProcedure(cdrProc) |
| + primitiveProcedure(consProc) |
| + primitiveProcedure(listProc) |
| + primitiveProcedure(nullProc) |
| + primitiveProcedure(equalProc) |
| + primitiveProcedure(equalProc) |
| + primitiveProcedure(lesserProc) |
| + primitiveProcedure(greaterProc) |
| + primitiveProcedure(addProc) |
| + primitiveProcedure(subProc) |
| + primitiveProcedure(mulProc) |
| + primitiveProcedure(divProc) |
| + primitiveProcedure(sqrtProc) |
| + primitiveProcedure(assocProc) |
| + primitiveProcedure(delAssocProc) |
| + primitiveProcedure(substAssocProc) |
| + primitiveProcedure(treeSelectAssocProc) |
| + primitiveProcedure(treeDelAssocProc) |
| + primitiveProcedure(treeSubstAssocProc) |
| + primitiveProcedure(cadrProc) |
| + primitiveProcedure(caddrProc) |
| + primitiveProcedure(cadddrProc) |
| + primitiveProcedure(cddrProc) |
| + primitiveProcedure(cdddrProc) |
| + primitiveProcedure(appendProc) |
| + primitiveProcedure(displayProc) |
| + primitiveProcedure(logProc) |
| + primitiveProcedure(uuidProc) |
| + primitiveProcedure(startProc) |
| + primitiveProcedure(stopProc); |
| } |
| |
| inline const bool isFalse(const value& exp) { |
| return (bool)exp == false; |
| } |
| |
| inline const bool isTrue(const value& exp) { |
| return (bool)exp == true; |
| } |
| |
| inline const bool isQuoted(const value& exp) { |
| return isTaggedList(exp, quoteSymbol); |
| } |
| |
| inline const value textOfQuotation(const value& exp) { |
| return car(cdr((list<value> )exp)); |
| } |
| |
| inline const value makeLambda(const list<value>& parameters, const list<value>& body) { |
| return cons(lambdaSymbol, cons<value>(parameters, body)); |
| } |
| |
| } |
| } |
| #endif /* tuscany_scheme_primitive_hpp */ |