diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,34 @@ # Revision history for zeolite-lang +## 0.13.0.0 -- 2021-03-17 + +### Language + +* **[breaking]** Streamlines C++ extensions to cut down on boilerplate code. + This is a massive change that breaks *all* existing C++ extensions; however, + hand-written procedure definitions can be copied-and-pasted into a new + extension template. Use `zeolite --templates` to regenerate new templates for + C++ extensions. + +* **[new]** Adds pragmas for local variable rules: + + * **[new]** `$ReadOnly[foo]$` marks `foo` as read-only in the current context + following the line with the pragma. + + * **[new]** `$Hidden[foo]$` hides `foo` in the current context following the + line with the pragma. + +* **[fix]** Fixes a latent issue with the `reduce` built-in when converting an + intersection type to a union type, when one or both sides contains another + nested union or intersection. This was previously fixed for compile-time + checks, but `reduce` was missed. + +### Compiler CLI + +* **[breaking]** Adds [`microlens`][microlens] and + [`microlens-th`][microlens-th] as dependencies, to help clean up the compiler + code. This should not change the compiler's behavior. + ## 0.12.0.0 -- 2020-12-11 ### Language @@ -475,4 +504,6 @@ * First version. Released on an unsuspecting world. [megaparsec]: https://hackage.haskell.org/package/megaparsec +[microlens]: https://hackage.haskell.org/package/microlens +[microlens-th]: https://hackage.haskell.org/package/microlens-th [parsec]: https://hackage.haskell.org/package/parsec diff --git a/base/category-source.cpp b/base/category-source.cpp --- a/base/category-source.cpp +++ b/base/category-source.cpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -158,9 +158,34 @@ bool TypeInstance::CanConvert(const S& x, const S& y) { - // See checkGeneralType for the ordering here. + // See pairMergeTree for the ordering here. + // TODO: Consider using a cache here, since the check could be expensive. if (x.get() == y.get()) { return true; + } else if (x->InstanceMergeType() == MergeType::INTERSECT && + y->InstanceMergeType() == MergeType::UNION) { + for (const auto& left : x->MergedTypes()) { + if (left->InstanceMergeType() == MergeType::SINGLE) { + for (const auto& right : y->MergedTypes()) { + if (right->InstanceMergeType() == MergeType::SINGLE) { + if (TypeInstance::CanConvert(left, right)) { + return true; + } + } + } + } + } + for (const auto& left : x->MergedTypes()) { + if (TypeInstance::CanConvert(left, y)) { + return true; + } + } + for (const auto right : y->MergedTypes()) { + if (TypeInstance::CanConvert(x, right)) { + return true; + } + } + return false; } else if (y->InstanceMergeType() == MergeType::INTERSECT) { for (const auto& right : y->MergedTypes()) { if (!TypeInstance::CanConvert(x, right)) { diff --git a/bin/zeolite.hs b/bin/zeolite.hs --- a/bin/zeolite.hs +++ b/bin/zeolite.hs @@ -55,7 +55,7 @@ showHelp :: IO () showHelp = do - hPutStrLn stderr "Zeolite CLI Help:" + hPutStrLn stderr $ "Zeolite " ++ compilerVersion ++ " Help:" mapM_ (hPutStrLn stderr . (" " ++)) optionHelpText hPutStrLn stderr "Also see https://ta0kira.github.io/zeolite for more documentation." diff --git a/example/parser/parse-text.0rx b/example/parser/parse-text.0rx --- a/example/parser/parse-text.0rx +++ b/example/parser/parse-text.0rx @@ -12,6 +12,7 @@ scoped { Int index <- 0 } in while (index < match.readSize()) { + $ReadOnly[context,index]$ if (context.atEof() || context.current() != match.readPosition(index)) { if (index > 0) { // Partial match => set error context. @@ -50,10 +51,12 @@ Builder builder <- String.builder() Int count <- 0 while (!context.atEof() && (max == 0 || count < max)) { + $ReadOnly[context,count]$ Bool found <- false scoped { Int index <- 0 } in while (index < matches.readSize()) { + $ReadOnly[index]$ if (context.current() == matches.readPosition(index)) { \ builder.append(matches.readPosition(index).formatted()) found <- true diff --git a/lib/file/.zeolite-module b/lib/file/.zeolite-module --- a/lib/file/.zeolite-module +++ b/lib/file/.zeolite-module @@ -8,11 +8,11 @@ ] extra_files: [ category_source { - source: "file/Category_RawFileReader.cpp" + source: "file/Extension_RawFileReader.cpp" categories: [RawFileReader] } category_source { - source: "file/Category_RawFileWriter.cpp" + source: "file/Extension_RawFileWriter.cpp" categories: [RawFileWriter] } ] diff --git a/lib/file/Category_RawFileReader.cpp b/lib/file/Category_RawFileReader.cpp deleted file mode 100644 --- a/lib/file/Category_RawFileReader.cpp +++ /dev/null @@ -1,229 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -#include - -#include "category-source.hpp" -#include "Category_BlockReader.hpp" -#include "Category_Bool.hpp" -#include "Category_Formatted.hpp" -#include "Category_Int.hpp" -#include "Category_PersistentResource.hpp" -#include "Category_RawFileReader.hpp" -#include "Category_String.hpp" -#ifdef ZEOLITE_PUBLIC_NAMESPACE -namespace ZEOLITE_PUBLIC_NAMESPACE { -#endif // ZEOLITE_PUBLIC_NAMESPACE -namespace { -const int collection_RawFileReader = 0; -} // namespace -const void* const Functions_RawFileReader = &collection_RawFileReader; -const TypeFunction& Function_RawFileReader_open = (*new TypeFunction{ 0, 1, 1, "RawFileReader", "open", Functions_RawFileReader, 0 }); -const ValueFunction& Function_RawFileReader_getFileError = (*new ValueFunction{ 0, 0, 1, "RawFileReader", "getFileError", Functions_RawFileReader, 0 }); -namespace { -class Category_RawFileReader; -class Type_RawFileReader; -S CreateType_RawFileReader(Params<0>::Type params); -class Value_RawFileReader; -S CreateValue_RawFileReader(S parent, const ParamTuple& params, const ValueTuple& args); -struct Category_RawFileReader : public TypeCategory { - std::string CategoryName() const final { return "RawFileReader"; } - Category_RawFileReader() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("RawFileReader (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_RawFileReader::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } -}; -Category_RawFileReader& CreateCategory_RawFileReader() { - static auto& category = *new Category_RawFileReader(); - return category; -} -struct Type_RawFileReader : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_RawFileReader& parent; - bool CanConvertFrom(const S& from) const final { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_RawFileReader()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_PersistentResource()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_BlockReader()) { - args = std::vector>{GetType_String(T_get())}; - return true; - } - return false; - } - Type_RawFileReader(Category_RawFileReader& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("RawFileReader (init @type)") - } - ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_RawFileReader::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_RawFileReader[] = { - &Type_RawFileReader::Call_open, - }; - if (label.collection == Functions_RawFileReader) { - if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileReader / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_RawFileReader[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); - } - ReturnTuple Call_open(const S& self, const ParamTuple& params, const ValueTuple& args); -}; -S CreateType_RawFileReader(Params<0>::Type params) { - static const auto cached = S_get(new Type_RawFileReader(CreateCategory_RawFileReader(), Params<0>::Type())); - return cached; -} -struct Value_RawFileReader : public TypeValue { - Value_RawFileReader(S p, const ParamTuple& params, const ValueTuple& args) - : parent(p), filename(args.At(0)->AsString()), - file(new std::ifstream(filename, std::ios::in | std::ios::binary)) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_RawFileReader::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_BlockReader[] = { - &Value_RawFileReader::Call_pastEnd, - &Value_RawFileReader::Call_readBlock, - }; - static const CallType Table_PersistentResource[] = { - &Value_RawFileReader::Call_freeResource, - }; - static const CallType Table_RawFileReader[] = { - &Value_RawFileReader::Call_getFileError, - }; - if (label.collection == Functions_BlockReader) { - if (label.function_num < 0 || label.function_num >= sizeof Table_BlockReader / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_BlockReader[label.function_num])(self, params, args); - } - if (label.collection == Functions_PersistentResource) { - if (label.function_num < 0 || label.function_num >= sizeof Table_PersistentResource / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_PersistentResource[label.function_num])(self, params, args); - } - if (label.collection == Functions_RawFileReader) { - if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileReader / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_RawFileReader[label.function_num])(self, params, args); - } - return TypeValue::Dispatch(self, label, params, args); - } - std::string CategoryName() const final { return parent->CategoryName(); } - ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - const S parent; - std::mutex mutex; - const std::string filename; - R file; - CAPTURE_CREATION -}; -S CreateValue_RawFileReader(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Value_RawFileReader(parent, params, args)); -} -ReturnTuple Type_RawFileReader::Call_open(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileReader.open") - return ReturnTuple(CreateValue_RawFileReader(CreateType_RawFileReader(Params<0>::Type()), ParamTuple(), args)); -} -ReturnTuple Value_RawFileReader::Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileReader.freeResource") - std::lock_guard lock(mutex); - if (file) { - file = nullptr; - } - return ReturnTuple(); -} -ReturnTuple Value_RawFileReader::Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileReader.getFileError") - std::lock_guard lock(mutex); - if (!file) { - return ReturnTuple(Box_String(PrimString_FromLiteral("file has already been closed"))); - } - if (file->rdstate() & std::ios::badbit) { - return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be read or opened"))); - } - if (file->rdstate() & std::ios::failbit) { - return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be read or opened"))); - } - return ReturnTuple(Var_empty); -} -ReturnTuple Value_RawFileReader::Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileReader.pastEnd") - std::lock_guard lock(mutex); - return ReturnTuple(Box_Bool(!file || file->fail() || file->eof())); -} -ReturnTuple Value_RawFileReader::Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileReader.readBlock") - TRACE_CREATION - std::lock_guard lock(mutex); - const PrimInt Var_arg1 = (args.At(0))->AsInt(); - if (Var_arg1 < 0) { - FAIL() << "Read size " << Var_arg1 << " is invalid"; - } - if (!file || file->rdstate() != std::ios::goodbit) { - FAIL() << "Error reading file \"" << filename << "\""; - } - std::string buffer(Var_arg1, '\x00'); - int read_size = 0; - if (file) { - const bool eof = file->eof(); - if (!eof && !file->fail()) { - file->read(&buffer[0], Var_arg1); - read_size = file->gcount(); - if (file->fail()) { - // Clear an EOF-related error, since we can't tell if it's because the - // file ended or because of a real error. - file->clear(); - file->setstate(std::ios::eofbit); - } - } - } - return ReturnTuple(Box_String(buffer.substr(0, read_size))); -} -} // namespace -TypeCategory& GetCategory_RawFileReader() { - return CreateCategory_RawFileReader(); -} -S GetType_RawFileReader(Params<0>::Type params) { - return CreateType_RawFileReader(params); -} -#ifdef ZEOLITE_PUBLIC_NAMESPACE -} // namespace ZEOLITE_PUBLIC_NAMESPACE -using namespace ZEOLITE_PUBLIC_NAMESPACE; -#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/file/Category_RawFileWriter.cpp b/lib/file/Category_RawFileWriter.cpp deleted file mode 100644 --- a/lib/file/Category_RawFileWriter.cpp +++ /dev/null @@ -1,210 +0,0 @@ - -/* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -#include - -#include "category-source.hpp" -#include "Category_BlockWriter.hpp" -#include "Category_Formatted.hpp" -#include "Category_Int.hpp" -#include "Category_PersistentResource.hpp" -#include "Category_RawFileWriter.hpp" -#include "Category_String.hpp" -#ifdef ZEOLITE_PUBLIC_NAMESPACE -namespace ZEOLITE_PUBLIC_NAMESPACE { -#endif // ZEOLITE_PUBLIC_NAMESPACE -namespace { -const int collection_RawFileWriter = 0; -} // namespace -const void* const Functions_RawFileWriter = &collection_RawFileWriter; -const TypeFunction& Function_RawFileWriter_open = (*new TypeFunction{ 0, 1, 1, "RawFileWriter", "open", Functions_RawFileWriter, 0 }); -const ValueFunction& Function_RawFileWriter_getFileError = (*new ValueFunction{ 0, 0, 1, "RawFileWriter", "getFileError", Functions_RawFileWriter, 0 }); -namespace { -class Category_RawFileWriter; -class Type_RawFileWriter; -S CreateType_RawFileWriter(Params<0>::Type params); -class Value_RawFileWriter; -S CreateValue_RawFileWriter(S parent, const ParamTuple& params, const ValueTuple& args); -struct Category_RawFileWriter : public TypeCategory { - std::string CategoryName() const final { return "RawFileWriter"; } - Category_RawFileWriter() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("RawFileWriter (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_RawFileWriter::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } -}; -Category_RawFileWriter& CreateCategory_RawFileWriter() { - static auto& category = *new Category_RawFileWriter(); - return category; -} -struct Type_RawFileWriter : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_RawFileWriter& parent; - bool CanConvertFrom(const S& from) const final { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_RawFileWriter()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_PersistentResource()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_BlockWriter()) { - args = std::vector>{GetType_String(T_get())}; - return true; - } - return false; - } - Type_RawFileWriter(Category_RawFileWriter& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("RawFileWriter (init @type)") - } - ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_RawFileWriter::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_RawFileWriter[] = { - &Type_RawFileWriter::Call_open, - }; - if (label.collection == Functions_RawFileWriter) { - if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileWriter / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_RawFileWriter[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); - } - ReturnTuple Call_open(const S& self, const ParamTuple& params, const ValueTuple& args); -}; -S CreateType_RawFileWriter(Params<0>::Type params) { - static const auto cached = S_get(new Type_RawFileWriter(CreateCategory_RawFileWriter(), Params<0>::Type())); - return cached; -} -struct Value_RawFileWriter : public TypeValue { - Value_RawFileWriter(S p, const ParamTuple& params, const ValueTuple& args) - : parent(p), filename(args.At(0)->AsString()), - file(new std::ofstream(filename, std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_RawFileWriter::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_BlockWriter[] = { - &Value_RawFileWriter::Call_writeBlock, - }; - static const CallType Table_PersistentResource[] = { - &Value_RawFileWriter::Call_freeResource, - }; - static const CallType Table_RawFileWriter[] = { - &Value_RawFileWriter::Call_getFileError, - }; - if (label.collection == Functions_BlockWriter) { - if (label.function_num < 0 || label.function_num >= sizeof Table_BlockWriter / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_BlockWriter[label.function_num])(self, params, args); - } - if (label.collection == Functions_PersistentResource) { - if (label.function_num < 0 || label.function_num >= sizeof Table_PersistentResource / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_PersistentResource[label.function_num])(self, params, args); - } - if (label.collection == Functions_RawFileWriter) { - if (label.function_num < 0 || label.function_num >= sizeof Table_RawFileWriter / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_RawFileWriter[label.function_num])(self, params, args); - } - return TypeValue::Dispatch(self, label, params, args); - } - std::string CategoryName() const final { return parent->CategoryName(); } - ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_writeBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - const S parent; - std::mutex mutex; - const std::string filename; - R file; - CAPTURE_CREATION -}; -S CreateValue_RawFileWriter(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Value_RawFileWriter(parent, params, args)); -} -ReturnTuple Type_RawFileWriter::Call_open(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileWriter.open") - return ReturnTuple(CreateValue_RawFileWriter(CreateType_RawFileWriter(Params<0>::Type()), ParamTuple(), args)); -} -ReturnTuple Value_RawFileWriter::Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileWriter.freeResource") - std::lock_guard lock(mutex); - if (file) { - file = nullptr; - } - return ReturnTuple(); -} -ReturnTuple Value_RawFileWriter::Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileWriter.getFileError") - std::lock_guard lock(mutex); - if (!file) { - return ReturnTuple(Box_String(PrimString_FromLiteral("file has already been closed"))); - } - if (file->rdstate() & std::ios::badbit) { - return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be written or opened"))); - } - if (file->rdstate() & std::ios::failbit) { - return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be written or opened"))); - } - return ReturnTuple(Var_empty); -} -ReturnTuple Value_RawFileWriter::Call_writeBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("RawFileWriter.writeBlock") - TRACE_CREATION - std::lock_guard lock(mutex); - const PrimString& Var_arg1 = args.At(0)->AsString(); - if (!file || file->rdstate() != std::ios::goodbit) { - FAIL() << "Error writing file \"" << filename << "\""; - } - int write_size = 0; - if (file) { - file->write(&Var_arg1[0], Var_arg1.size()); - file->flush(); - write_size = file->fail()? 0 : Var_arg1.size(); - } - return ReturnTuple(Box_Int(write_size)); -} -} // namespace -TypeCategory& GetCategory_RawFileWriter() { - return CreateCategory_RawFileWriter(); -} -S GetType_RawFileWriter(Params<0>::Type params) { - return CreateType_RawFileWriter(params); -} -#ifdef ZEOLITE_PUBLIC_NAMESPACE -} // namespace ZEOLITE_PUBLIC_NAMESPACE -using namespace ZEOLITE_PUBLIC_NAMESPACE; -#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/file/Extension_RawFileReader.cpp b/lib/file/Extension_RawFileReader.cpp new file mode 100644 --- /dev/null +++ b/lib/file/Extension_RawFileReader.cpp @@ -0,0 +1,128 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020-2021 Kevin P. Barry +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include +#include + +#include "category-source.hpp" +#include "Streamlined_RawFileReader.hpp" +#include "Category_Formatted.hpp" +#include "Category_String.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +S CreateValue_RawFileReader(S parent, const ParamTuple& params, const ValueTuple& args); + +struct ExtCategory_RawFileReader : public Category_RawFileReader { +}; + +struct ExtType_RawFileReader : public Type_RawFileReader { + inline ExtType_RawFileReader(Category_RawFileReader& p, Params<0>::Type params) : Type_RawFileReader(p, params) {} + + ReturnTuple Call_open(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.open") + return ReturnTuple(CreateValue_RawFileReader(CreateType_RawFileReader(Params<0>::Type()), ParamTuple(), args)); + } +}; + +struct ExtValue_RawFileReader : public Value_RawFileReader { + inline ExtValue_RawFileReader(S p, const ParamTuple& params, const ValueTuple& args) + : Value_RawFileReader(p, params), + filename(args.At(0)->AsString()), + file(new std::ifstream(filename, std::ios::in | std::ios::binary)) {} + + ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.freeResource") + std::lock_guard lock(mutex); + if (file) { + file = nullptr; + } + return ReturnTuple(); + } + + ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.getFileError") + std::lock_guard lock(mutex); + if (!file) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file has already been closed"))); + } + if (file->rdstate() & std::ios::badbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be read or opened"))); + } + if (file->rdstate() & std::ios::failbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be read or opened"))); + } + return ReturnTuple(Var_empty); + } + + ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.pastEnd") + std::lock_guard lock(mutex); + return ReturnTuple(Box_Bool(!file || file->fail() || file->eof())); + } + + ReturnTuple Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileReader.readBlock") + TRACE_CREATION + std::lock_guard lock(mutex); + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + if (Var_arg1 < 0) { + FAIL() << "Read size " << Var_arg1 << " is invalid"; + } + if (!file || file->rdstate() != std::ios::goodbit) { + FAIL() << "Error reading file \"" << filename << "\""; + } + std::string buffer(Var_arg1, '\x00'); + int read_size = 0; + if (file) { + const bool eof = file->eof(); + if (!eof && !file->fail()) { + file->read(&buffer[0], Var_arg1); + read_size = file->gcount(); + if (file->fail()) { + // Clear an EOF-related error, since we can't tell if it's because the + // file ended or because of a real error. + file->clear(); + file->setstate(std::ios::eofbit); + } + } + } + return ReturnTuple(Box_String(buffer.substr(0, read_size))); + } + + std::mutex mutex; + const std::string filename; + R file; + CAPTURE_CREATION +}; + +Category_RawFileReader& CreateCategory_RawFileReader() { + static auto& category = *new ExtCategory_RawFileReader(); + return category; +} +S CreateType_RawFileReader(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_RawFileReader(CreateCategory_RawFileReader(), Params<0>::Type())); + return cached; +} +S CreateValue_RawFileReader(S parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new ExtValue_RawFileReader(parent, params, args)); +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/file/Extension_RawFileWriter.cpp b/lib/file/Extension_RawFileWriter.cpp new file mode 100644 --- /dev/null +++ b/lib/file/Extension_RawFileWriter.cpp @@ -0,0 +1,110 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020-2021 Kevin P. Barry +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include +#include + +#include "category-source.hpp" +#include "Streamlined_RawFileWriter.hpp" +#include "Category_Formatted.hpp" +#include "Category_String.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +S CreateValue_RawFileWriter(S parent, const ParamTuple& params, const ValueTuple& args); + +struct ExtCategory_RawFileWriter : public Category_RawFileWriter { +}; + +struct ExtType_RawFileWriter : public Type_RawFileWriter { + inline ExtType_RawFileWriter(Category_RawFileWriter& p, Params<0>::Type params) : Type_RawFileWriter(p, params) {} + + ReturnTuple Call_open(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.open") + return ReturnTuple(CreateValue_RawFileWriter(CreateType_RawFileWriter(Params<0>::Type()), ParamTuple(), args)); + } +}; + +struct ExtValue_RawFileWriter : public Value_RawFileWriter { + inline ExtValue_RawFileWriter(S p, const ParamTuple& params, const ValueTuple& args) + : Value_RawFileWriter(p, params), + filename(args.At(0)->AsString()), + file(new std::ofstream(filename, std::ios::out | std::ios::binary | std::ios::trunc | std::ios::ate)) {} + + ReturnTuple Call_freeResource(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.freeResource") + std::lock_guard lock(mutex); + if (file) { + file = nullptr; + } + return ReturnTuple(); + } + + ReturnTuple Call_getFileError(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.getFileError") + std::lock_guard lock(mutex); + if (!file) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file has already been closed"))); + } + if (file->rdstate() & std::ios::badbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be written or opened"))); + } + if (file->rdstate() & std::ios::failbit) { + return ReturnTuple(Box_String(PrimString_FromLiteral("file could not be written or opened"))); + } + return ReturnTuple(Var_empty); + } + + ReturnTuple Call_writeBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("RawFileWriter.writeBlock") + TRACE_CREATION + std::lock_guard lock(mutex); + const PrimString& Var_arg1 = args.At(0)->AsString(); + if (!file || file->rdstate() != std::ios::goodbit) { + FAIL() << "Error writing file \"" << filename << "\""; + } + int write_size = 0; + if (file) { + file->write(&Var_arg1[0], Var_arg1.size()); + file->flush(); + write_size = file->fail()? 0 : Var_arg1.size(); + } + return ReturnTuple(Box_Int(write_size)); + } + + std::mutex mutex; + const std::string filename; + R file; + CAPTURE_CREATION +}; + +Category_RawFileWriter& CreateCategory_RawFileWriter() { + static auto& category = *new ExtCategory_RawFileWriter(); + return category; +} +S CreateType_RawFileWriter(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_RawFileWriter(CreateCategory_RawFileWriter(), Params<0>::Type())); + return cached; +} +S CreateValue_RawFileWriter(S parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new ExtValue_RawFileWriter(parent, params, args)); +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/math/.zeolite-module b/lib/math/.zeolite-module --- a/lib/math/.zeolite-module +++ b/lib/math/.zeolite-module @@ -5,13 +5,8 @@ ] extra_files: [ category_source { - source: "lib/math/Category_Math.cpp" - categories: [Math] - } - category_source { - source: "lib/math/Source_Math.cpp" + source: "lib/math/Extension_Math.cpp" categories: [Math] } - "lib/math/Source_Math.hpp" ] mode: incremental {} diff --git a/lib/math/Category_Math.cpp b/lib/math/Category_Math.cpp deleted file mode 100644 --- a/lib/math/Category_Math.cpp +++ /dev/null @@ -1,225 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry - -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -#include - -#include "Source_Math.hpp" -#include "Category_Float.hpp" -#include "Category_String.hpp" - - -#ifdef ZEOLITE_PUBLIC_NAMESPACE -namespace ZEOLITE_PUBLIC_NAMESPACE { -#endif // ZEOLITE_PUBLIC_NAMESPACE - -namespace { - -struct Impl_Category_Math : public Category_Math {}; - -struct Impl_Type_Math : public Type_Math { - Impl_Type_Math(Category_Math& p, Params<0>::Type params) : Type_Math(p, std::move(params)) {} - - ReturnTuple Call_acos(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.acos") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::acos(Var_arg1))); - } - - ReturnTuple Call_acosh(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.acosh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::acosh(Var_arg1))); - } - - ReturnTuple Call_asin(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.asin") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::asin(Var_arg1))); - } - - ReturnTuple Call_asinh(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.asinh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::asinh(Var_arg1))); - } - - ReturnTuple Call_atan(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.atan") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::atan(Var_arg1))); - } - - ReturnTuple Call_atanh(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.atanh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::atanh(Var_arg1))); - } - - ReturnTuple Call_ceil(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.ceil") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::ceil(Var_arg1))); - } - - ReturnTuple Call_cos(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.cos") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::cos(Var_arg1))); - } - - ReturnTuple Call_cosh(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.cosh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::cosh(Var_arg1))); - } - - ReturnTuple Call_exp(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.exp") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::exp(Var_arg1))); - } - - ReturnTuple Call_fabs(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.fabs") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::fabs(Var_arg1))); - } - - ReturnTuple Call_floor(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.floor") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::floor(Var_arg1))); - } - - ReturnTuple Call_fmod(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.fmod") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); - return ReturnTuple(Box_Float(std::fmod(Var_arg1,Var_arg2))); - } - - ReturnTuple Call_isinf(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.isinf") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Bool(std::isinf(Var_arg1))); - } - - ReturnTuple Call_isnan(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.isnan") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Bool(std::isnan(Var_arg1))); - } - - ReturnTuple Call_log(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.log") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::log(Var_arg1))); - } - - ReturnTuple Call_log10(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.log10") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::log10(Var_arg1))); - } - - ReturnTuple Call_log2(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.log2") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::log2(Var_arg1))); - } - - ReturnTuple Call_pow(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.pow") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); - return ReturnTuple(Box_Float(std::pow(Var_arg1,Var_arg2))); - } - - ReturnTuple Call_round(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.round") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::round(Var_arg1))); - } - - ReturnTuple Call_sin(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.sin") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::sin(Var_arg1))); - } - - ReturnTuple Call_sinh(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.sinh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::sinh(Var_arg1))); - } - - ReturnTuple Call_sqrt(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.sqrt") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::sqrt(Var_arg1))); - } - - ReturnTuple Call_tan(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.tan") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::tan(Var_arg1))); - } - - ReturnTuple Call_tanh(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.tanh") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::tanh(Var_arg1))); - } - - ReturnTuple Call_trunc(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.trunc") - const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); - return ReturnTuple(Box_Float(std::trunc(Var_arg1))); - } - - ReturnTuple Call_abs(const S& self, const ParamTuple& params, const ValueTuple& args) final { - TRACE_FUNCTION("Math.abs") - const PrimInt Var_arg1 = (args.At(0))->AsInt(); - return ReturnTuple(Box_Int(std::abs(Var_arg1))); - } -}; - -struct Impl_Value_Math : public Value_Math { - Impl_Value_Math(S p, const ParamTuple& params, const ValueTuple& args) : Value_Math(p) {} -}; - -} // namespace - -Category_Math& CreateCategory_Math() { - static auto& category = *new Impl_Category_Math(); - return category; -} - -S CreateType_Math(Params<0>::Type params) { - static const auto cached = S_get(new Impl_Type_Math(CreateCategory_Math(), Params<0>::Type())); - return cached; -} - -S CreateValue_Math(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Impl_Value_Math(parent, params, args)); -} - -#ifdef ZEOLITE_PUBLIC_NAMESPACE -} // namespace ZEOLITE_PUBLIC_NAMESPACE -using namespace ZEOLITE_PUBLIC_NAMESPACE; -#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/math/Extension_Math.cpp b/lib/math/Extension_Math.cpp new file mode 100644 --- /dev/null +++ b/lib/math/Extension_Math.cpp @@ -0,0 +1,217 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020-2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include + +#include "category-source.hpp" +#include "Streamlined_Math.hpp" +#include "Category_Formatted.hpp" +#include "Category_String.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +struct ExtCategory_Math : public Category_Math { +}; + +struct ExtType_Math : public Type_Math { + inline ExtType_Math(Category_Math& p, Params<0>::Type params) : Type_Math(p, params) {} + + ReturnTuple Call_acos(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.acos") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::acos(Var_arg1))); + } + + ReturnTuple Call_acosh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.acosh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::acosh(Var_arg1))); + } + + ReturnTuple Call_asin(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.asin") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::asin(Var_arg1))); + } + + ReturnTuple Call_asinh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.asinh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::asinh(Var_arg1))); + } + + ReturnTuple Call_atan(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.atan") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::atan(Var_arg1))); + } + + ReturnTuple Call_atanh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.atanh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::atanh(Var_arg1))); + } + + ReturnTuple Call_ceil(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.ceil") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::ceil(Var_arg1))); + } + + ReturnTuple Call_cos(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.cos") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::cos(Var_arg1))); + } + + ReturnTuple Call_cosh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.cosh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::cosh(Var_arg1))); + } + + ReturnTuple Call_exp(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.exp") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::exp(Var_arg1))); + } + + ReturnTuple Call_fabs(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.fabs") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::fabs(Var_arg1))); + } + + ReturnTuple Call_floor(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.floor") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::floor(Var_arg1))); + } + + ReturnTuple Call_fmod(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.fmod") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); + return ReturnTuple(Box_Float(std::fmod(Var_arg1,Var_arg2))); + } + + ReturnTuple Call_isinf(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.isinf") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Bool(std::isinf(Var_arg1))); + } + + ReturnTuple Call_isnan(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.isnan") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Bool(std::isnan(Var_arg1))); + } + + ReturnTuple Call_log(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.log") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::log(Var_arg1))); + } + + ReturnTuple Call_log10(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.log10") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::log10(Var_arg1))); + } + + ReturnTuple Call_log2(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.log2") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::log2(Var_arg1))); + } + + ReturnTuple Call_pow(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.pow") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + const PrimFloat Var_arg2 = (args.At(1))->AsFloat(); + return ReturnTuple(Box_Float(std::pow(Var_arg1,Var_arg2))); + } + + ReturnTuple Call_round(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.round") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::round(Var_arg1))); + } + + ReturnTuple Call_sin(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.sin") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::sin(Var_arg1))); + } + + ReturnTuple Call_sinh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.sinh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::sinh(Var_arg1))); + } + + ReturnTuple Call_sqrt(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.sqrt") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::sqrt(Var_arg1))); + } + + ReturnTuple Call_tan(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.tan") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::tan(Var_arg1))); + } + + ReturnTuple Call_tanh(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.tanh") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::tanh(Var_arg1))); + } + + ReturnTuple Call_trunc(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.trunc") + const PrimFloat Var_arg1 = (args.At(0))->AsFloat(); + return ReturnTuple(Box_Float(std::trunc(Var_arg1))); + } + + ReturnTuple Call_abs(const S& self, const ParamTuple& params, const ValueTuple& args) final { + TRACE_FUNCTION("Math.abs") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + return ReturnTuple(Box_Int(std::abs(Var_arg1))); + } +}; + +struct ExtValue_Math : public Value_Math { + inline ExtValue_Math(S p, const ParamTuple& params, const ValueTuple& args) : Value_Math(p, params) {} +}; + +Category_Math& CreateCategory_Math() { + static auto& category = *new ExtCategory_Math(); + return category; +} +S CreateType_Math(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_Math(CreateCategory_Math(), Params<0>::Type())); + return cached; +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/math/Source_Math.cpp b/lib/math/Source_Math.cpp deleted file mode 100644 --- a/lib/math/Source_Math.cpp +++ /dev/null @@ -1,162 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry - -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -#include - -#include "Source_Math.hpp" - - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE - -namespace { -const int collection_Math = 0; -} // namespace -const void* const Functions_Math = &collection_Math; -const TypeFunction& Function_Math_acos = (*new TypeFunction{ 0, 1, 1, "Math", "acos", Functions_Math, 0 }); -const TypeFunction& Function_Math_acosh = (*new TypeFunction{ 0, 1, 1, "Math", "acosh", Functions_Math, 1 }); -const TypeFunction& Function_Math_asin = (*new TypeFunction{ 0, 1, 1, "Math", "asin", Functions_Math, 2 }); -const TypeFunction& Function_Math_asinh = (*new TypeFunction{ 0, 1, 1, "Math", "asinh", Functions_Math, 3 }); -const TypeFunction& Function_Math_atan = (*new TypeFunction{ 0, 1, 1, "Math", "atan", Functions_Math, 4 }); -const TypeFunction& Function_Math_atanh = (*new TypeFunction{ 0, 1, 1, "Math", "atanh", Functions_Math, 5 }); -const TypeFunction& Function_Math_ceil = (*new TypeFunction{ 0, 1, 1, "Math", "ceil", Functions_Math, 6 }); -const TypeFunction& Function_Math_cos = (*new TypeFunction{ 0, 1, 1, "Math", "cos", Functions_Math, 7 }); -const TypeFunction& Function_Math_cosh = (*new TypeFunction{ 0, 1, 1, "Math", "cosh", Functions_Math, 8 }); -const TypeFunction& Function_Math_exp = (*new TypeFunction{ 0, 1, 1, "Math", "exp", Functions_Math, 9 }); -const TypeFunction& Function_Math_fabs = (*new TypeFunction{ 0, 1, 1, "Math", "fabs", Functions_Math, 10 }); -const TypeFunction& Function_Math_floor = (*new TypeFunction{ 0, 1, 1, "Math", "floor", Functions_Math, 11 }); -const TypeFunction& Function_Math_fmod = (*new TypeFunction{ 0, 2, 1, "Math", "fmod", Functions_Math, 12 }); -const TypeFunction& Function_Math_isinf = (*new TypeFunction{ 0, 1, 1, "Math", "isinf", Functions_Math, 13 }); -const TypeFunction& Function_Math_isnan = (*new TypeFunction{ 0, 1, 1, "Math", "isnan", Functions_Math, 14 }); -const TypeFunction& Function_Math_log = (*new TypeFunction{ 0, 1, 1, "Math", "log", Functions_Math, 15 }); -const TypeFunction& Function_Math_log10 = (*new TypeFunction{ 0, 1, 1, "Math", "log10", Functions_Math, 16 }); -const TypeFunction& Function_Math_log2 = (*new TypeFunction{ 0, 1, 1, "Math", "log2", Functions_Math, 17 }); -const TypeFunction& Function_Math_pow = (*new TypeFunction{ 0, 2, 1, "Math", "pow", Functions_Math, 18 }); -const TypeFunction& Function_Math_round = (*new TypeFunction{ 0, 1, 1, "Math", "round", Functions_Math, 19 }); -const TypeFunction& Function_Math_sin = (*new TypeFunction{ 0, 1, 1, "Math", "sin", Functions_Math, 20 }); -const TypeFunction& Function_Math_sinh = (*new TypeFunction{ 0, 1, 1, "Math", "sinh", Functions_Math, 21 }); -const TypeFunction& Function_Math_sqrt = (*new TypeFunction{ 0, 1, 1, "Math", "sqrt", Functions_Math, 22 }); -const TypeFunction& Function_Math_tan = (*new TypeFunction{ 0, 1, 1, "Math", "tan", Functions_Math, 23 }); -const TypeFunction& Function_Math_tanh = (*new TypeFunction{ 0, 1, 1, "Math", "tanh", Functions_Math, 24 }); -const TypeFunction& Function_Math_trunc = (*new TypeFunction{ 0, 1, 1, "Math", "trunc", Functions_Math, 25 }); -const TypeFunction& Function_Math_abs = (*new TypeFunction{ 0, 1, 1, "Math", "abs", Functions_Math, 26 }); - -std::string Category_Math::CategoryName() const { return "Math"; } - -Category_Math::Category_Math() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Math (init @category)") -} - -ReturnTuple Category_Math::Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) { - using CallType = ReturnTuple(Category_Math::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); -} - -Type_Math::Type_Math(Category_Math& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Math (init @type)") -} - -std::string Type_Math::CategoryName() const { return parent.CategoryName(); } - -void Type_Math::BuildTypeName(std::ostream& output) const { - return TypeInstance::TypeNameFrom(output, parent); -} - -bool Type_Math::CanConvertFrom(const S& from) const { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; -} - -bool Type_Math::TypeArgsForParent(const TypeCategory& category, std::vector>& args) const { - if (&category == &GetCategory_Math()) { - args = std::vector>{}; - return true; - } - return false; -} - -ReturnTuple Type_Math::Dispatch(const S& self, const TypeFunction& label, - const ParamTuple& params, const ValueTuple& args) { - using CallType = ReturnTuple(Type_Math::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_Math[] = { - &Type_Math::Call_acos, - &Type_Math::Call_acosh, - &Type_Math::Call_asin, - &Type_Math::Call_asinh, - &Type_Math::Call_atan, - &Type_Math::Call_atanh, - &Type_Math::Call_ceil, - &Type_Math::Call_cos, - &Type_Math::Call_cosh, - &Type_Math::Call_exp, - &Type_Math::Call_fabs, - &Type_Math::Call_floor, - &Type_Math::Call_fmod, - &Type_Math::Call_isinf, - &Type_Math::Call_isnan, - &Type_Math::Call_log, - &Type_Math::Call_log10, - &Type_Math::Call_log2, - &Type_Math::Call_pow, - &Type_Math::Call_round, - &Type_Math::Call_sin, - &Type_Math::Call_sinh, - &Type_Math::Call_sqrt, - &Type_Math::Call_tan, - &Type_Math::Call_tanh, - &Type_Math::Call_trunc, - &Type_Math::Call_abs, - }; - if (label.collection == Functions_Math) { - if (label.function_num < 0 || label.function_num >= sizeof Table_Math / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Math[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); -} - -Value_Math::Value_Math(S p) : parent(p) {} - -ReturnTuple Value_Math::Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) { - using CallType = ReturnTuple(Value_Math::*)(const S&, const ParamTuple&, const ValueTuple&); - return TypeValue::Dispatch(self, label, params, args); -} - -std::string Value_Math::CategoryName() const { return parent->CategoryName(); } - -TypeCategory& GetCategory_Math() { - return CreateCategory_Math(); -} -S GetType_Math(Params<0>::Type params) { - return CreateType_Math(params); -} - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -using namespace ZEOLITE_DYNAMIC_NAMESPACE; -#endif // ZEOLITE_DYNAMIC_NAMESPACE diff --git a/lib/math/Source_Math.hpp b/lib/math/Source_Math.hpp deleted file mode 100644 --- a/lib/math/Source_Math.hpp +++ /dev/null @@ -1,112 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry - -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -#ifndef HEADER_Source_Math -#define HEADER_Source_Math - -#include - -#include "category-source.hpp" -#include "Category_Math.hpp" - - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -namespace ZEOLITE_DYNAMIC_NAMESPACE { -#endif // ZEOLITE_DYNAMIC_NAMESPACE - -class Category_Math : public TypeCategory { - public: - std::string CategoryName() const final; - - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final; - - protected: - Category_Math(); -}; - -class Type_Math : public TypeInstance { - public: - std::string CategoryName() const final; - - void BuildTypeName(std::ostream& output) const final; - - bool CanConvertFrom(const S& from) const final; - - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final; - - ReturnTuple Dispatch(const S& self, const TypeFunction& label, - const ParamTuple& params, const ValueTuple& args) final; - - protected: - Type_Math(Category_Math& p, Params<0>::Type params); - - virtual ReturnTuple Call_acos(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_acosh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_asin(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_asinh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_atan(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_atanh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_ceil(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_cos(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_cosh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_exp(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_fabs(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_floor(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_fmod(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_isinf(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_isnan(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_log(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_log10(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_log2(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_pow(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_round(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_sin(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_sinh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_sqrt(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_tan(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_tanh(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_trunc(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - virtual ReturnTuple Call_abs(const S& self, const ParamTuple& params, const ValueTuple& args) = 0; - - Category_Math& parent; -}; - -class Value_Math : public TypeValue { - public: - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final; - - std::string CategoryName() const final; - - protected: - Value_Math(S p); - - S parent; -}; - -Category_Math& CreateCategory_Math(); - -S CreateType_Math(Params<0>::Type params); - -S CreateValue_Math(Type_Math& parent, const ParamTuple& params, const ValueTuple& args); - -#ifdef ZEOLITE_DYNAMIC_NAMESPACE -} // namespace ZEOLITE_DYNAMIC_NAMESPACE -using namespace ZEOLITE_DYNAMIC_NAMESPACE; -#endif // ZEOLITE_DYNAMIC_NAMESPACE - -#endif // HEADER_Source_Math diff --git a/lib/util/.zeolite-module b/lib/util/.zeolite-module --- a/lib/util/.zeolite-module +++ b/lib/util/.zeolite-module @@ -11,15 +11,15 @@ ] extra_files: [ category_source { - source: "util/Category_Argv.cpp" + source: "util/Extension_Argv.cpp" categories: [Argv] } category_source { - source: "util/Category_SimpleInput.cpp" + source: "util/Extension_SimpleInput.cpp" categories: [SimpleInput] } category_source { - source: "util/Category_SimpleOutput.cpp" + source: "util/Extension_SimpleOutput.cpp" categories: [SimpleOutput] } ] diff --git a/lib/util/Category_Argv.cpp b/lib/util/Category_Argv.cpp deleted file mode 100644 --- a/lib/util/Category_Argv.cpp +++ /dev/null @@ -1,163 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -#include "category-source.hpp" -#include "Category_Argv.hpp" -#include "Category_Formatted.hpp" -#include "Category_Int.hpp" -#include "Category_ReadPosition.hpp" -#include "Category_String.hpp" -#ifdef ZEOLITE_PUBLIC_NAMESPACE -namespace ZEOLITE_PUBLIC_NAMESPACE { -#endif // ZEOLITE_PUBLIC_NAMESPACE -namespace { -extern const S& Var_global; -const int collection_Argv = 0; -} // namespace -const void* const Functions_Argv = &collection_Argv; -const TypeFunction& Function_Argv_global = (*new TypeFunction{ 0, 0, 1, "Argv", "global", Functions_Argv, 0 }); -namespace { -class Category_Argv; -class Type_Argv; -S CreateType_Argv(Params<0>::Type params); -class Value_Argv; -S CreateValue_Argv(S parent, const ParamTuple& params, const ValueTuple& args); -struct Category_Argv : public TypeCategory { - std::string CategoryName() const final { return "Argv"; } - Category_Argv() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Argv (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_Argv::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } -}; -Category_Argv& CreateCategory_Argv() { - static auto& category = *new Category_Argv(); - return category; -} -struct Type_Argv : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_Argv& parent; - bool CanConvertFrom(const S& from) const final { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_Argv()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_ReadPosition()) { - args = std::vector>{GetType_String(T_get())}; - return true; - } - return false; - } - Type_Argv(Category_Argv& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Argv (init @type)") - } - ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_Argv::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_Argv[] = { - &Type_Argv::Call_global, - }; - if (label.collection == Functions_Argv) { - if (label.function_num < 0 || label.function_num >= sizeof Table_Argv / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Argv[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); - } - ReturnTuple Call_global(const S& self, const ParamTuple& params, const ValueTuple& args); -}; -S CreateType_Argv(Params<0>::Type params) { - static const auto cached = S_get(new Type_Argv(CreateCategory_Argv(), Params<0>::Type())); - return cached; -} -struct Value_Argv : public TypeValue { - Value_Argv(int start, int size) : start_(start), size_(size) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_Argv::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_ReadPosition[] = { - &Value_Argv::Call_readPosition, - &Value_Argv::Call_readSize, - &Value_Argv::Call_subSequence, - }; - if (label.collection == Functions_ReadPosition) { - if (label.function_num < 0 || label.function_num >= sizeof Table_ReadPosition / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_ReadPosition[label.function_num])(self, params, args); - } - return TypeValue::Dispatch(self, label, params, args); - } - std::string CategoryName() const final { return "Argv"; } - inline int GetSize() const { return size_ < 0 ? Argv::ArgCount() : size_; } - ReturnTuple Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - const int start_; - const int size_; -}; -ReturnTuple Type_Argv::Call_global(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Argv.global") - return ReturnTuple(Var_global); -} -ReturnTuple Value_Argv::Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Argv.readPosition") - const PrimInt Var_arg1 = (args.At(0))->AsInt(); - return ReturnTuple(Box_String(Argv::GetArgAt(start_ + Var_arg1))); -} -ReturnTuple Value_Argv::Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Argv.readSize") - return ReturnTuple(Box_Int(GetSize())); -} -ReturnTuple Value_Argv::Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Argv.subSequence") - const PrimInt Var_arg1 = (args.At(0))->AsInt(); - const PrimInt Var_arg2 = (args.At(1))->AsInt(); - if (Var_arg1 < 0 || (Var_arg1 > 0 && Var_arg1 >= GetSize())) { - FAIL() << "Subsequence index " << Var_arg1 << " is out of bounds"; - } - if (Var_arg2 < 0 || Var_arg1 + Var_arg2 > GetSize()) { - FAIL() << "Subsequence size " << Var_arg2 << " is invalid"; - } - return ReturnTuple(S(new Value_Argv(start_ + Var_arg1, Var_arg2))); -} -const S& Var_global = *new S(new Value_Argv(0, -1)); -} // namespace -TypeCategory& GetCategory_Argv() { - return CreateCategory_Argv(); -} -S GetType_Argv(Params<0>::Type params) { - return CreateType_Argv(params); -} -#ifdef ZEOLITE_PUBLIC_NAMESPACE -} // namespace ZEOLITE_PUBLIC_NAMESPACE -using namespace ZEOLITE_PUBLIC_NAMESPACE; -#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/Category_SimpleInput.cpp b/lib/util/Category_SimpleInput.cpp deleted file mode 100644 --- a/lib/util/Category_SimpleInput.cpp +++ /dev/null @@ -1,168 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -// TODO: Maybe use C++ instead. -#include - -#include "category-source.hpp" -#include "Category_BlockReader.hpp" -#include "Category_Bool.hpp" -#include "Category_Formatted.hpp" -#include "Category_Int.hpp" -#include "Category_SimpleInput.hpp" -#include "Category_String.hpp" -#ifdef ZEOLITE_PUBLIC_NAMESPACE -namespace ZEOLITE_PUBLIC_NAMESPACE { -#endif // ZEOLITE_PUBLIC_NAMESPACE -namespace { -extern const S& Var_stdin; -const int collection_SimpleInput = 0; -} // namespace -const void* const Functions_SimpleInput = &collection_SimpleInput; -const TypeFunction& Function_SimpleInput_stdin = (*new TypeFunction{ 0, 0, 1, "SimpleInput", "stdin", Functions_SimpleInput, 0 }); -namespace { -class Category_SimpleInput; -class Type_SimpleInput; -S CreateType_SimpleInput(Params<0>::Type params); -class Value_SimpleInput; -S CreateValue_SimpleInput(S parent, const ParamTuple& params, const ValueTuple& args); -struct Category_SimpleInput : public TypeCategory { - std::string CategoryName() const final { return "SimpleInput"; } - Category_SimpleInput() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("SimpleInput (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_SimpleInput::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } -}; -Category_SimpleInput& CreateCategory_SimpleInput() { - static auto& category = *new Category_SimpleInput(); - return category; -} -struct Type_SimpleInput : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_SimpleInput& parent; - bool CanConvertFrom(const S& from) const final { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_SimpleInput()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_BlockReader()) { - args = std::vector>{GetType_String(T_get())}; - return true; - } - return false; - } - Type_SimpleInput(Category_SimpleInput& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("SimpleInput (init @type)") - } - ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_SimpleInput::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_SimpleInput[] = { - &Type_SimpleInput::Call_stdin, - }; - if (label.collection == Functions_SimpleInput) { - if (label.function_num < 0 || label.function_num >= sizeof Table_SimpleInput / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_SimpleInput[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); - } - ReturnTuple Call_stdin(const S& self, const ParamTuple& params, const ValueTuple& args); -}; -S CreateType_SimpleInput(Params<0>::Type params) { - static const auto cached = S_get(new Type_SimpleInput(CreateCategory_SimpleInput(), Params<0>::Type())); - return cached; -} -struct Value_SimpleInput : public TypeValue { - Value_SimpleInput(S p, const ParamTuple& params, const ValueTuple& args) : parent(p) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_SimpleInput::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_BlockReader[] = { - &Value_SimpleInput::Call_pastEnd, - &Value_SimpleInput::Call_readBlock, - }; - if (label.collection == Functions_BlockReader) { - if (label.function_num < 0 || label.function_num >= sizeof Table_BlockReader / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_BlockReader[label.function_num])(self, params, args); - } - return TypeValue::Dispatch(self, label, params, args); - } - std::string CategoryName() const final { return parent->CategoryName(); } - ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - bool zero_read = false; - std::mutex mutex; - const S parent; -}; -S CreateValue_SimpleInput(S parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Value_SimpleInput(parent, params, args)); -} -ReturnTuple Type_SimpleInput::Call_stdin(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleInput.stdin") - return ReturnTuple(Var_stdin); -} -ReturnTuple Value_SimpleInput::Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleInput.pastEnd") - std::lock_guard lock(mutex); - return ReturnTuple(Box_Bool(zero_read)); -} -ReturnTuple Value_SimpleInput::Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleInput.readBlock") - std::lock_guard lock(mutex); - const int size = args.At(0)->AsInt(); - if (size < 0) { - FAIL() << "Read size " << size << " is invalid"; - } - std::string buffer(size, '\x00'); - const int read_size = read(STDIN_FILENO, &buffer[0], size); - if (read_size < 0) { - return ReturnTuple(Box_String("")); - } else { - zero_read = read_size == 0; - return ReturnTuple(Box_String(buffer.substr(0, read_size))); - } -} -const S& Var_stdin = *new S(CreateValue_SimpleInput(CreateType_SimpleInput(Params<0>::Type()), ParamTuple(), ArgTuple())); -} // namespace -TypeCategory& GetCategory_SimpleInput() { - return CreateCategory_SimpleInput(); -} -S GetType_SimpleInput(Params<0>::Type params) { - return CreateType_SimpleInput(params); -} -#ifdef ZEOLITE_PUBLIC_NAMESPACE -} // namespace ZEOLITE_PUBLIC_NAMESPACE -using namespace ZEOLITE_PUBLIC_NAMESPACE; -#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/Category_SimpleOutput.cpp b/lib/util/Category_SimpleOutput.cpp deleted file mode 100644 --- a/lib/util/Category_SimpleOutput.cpp +++ /dev/null @@ -1,220 +0,0 @@ -/* ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry -Licensed 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. ------------------------------------------------------------------------------ */ - -// Author: Kevin P. Barry [ta0kira@gmail.com] - -#include -#include - -#include "category-source.hpp" -#include "Category_BufferedWriter.hpp" -#include "Category_Formatted.hpp" -#include "Category_SimpleOutput.hpp" -#include "Category_String.hpp" -#include "Category_Writer.hpp" -#ifdef ZEOLITE_PUBLIC_NAMESPACE -namespace ZEOLITE_PUBLIC_NAMESPACE { -#endif // ZEOLITE_PUBLIC_NAMESPACE -namespace { -extern const S& Var_stdout; -extern const S& Var_stderr; -extern const S& Var_error; -const int collection_SimpleOutput = 0; -} // namespace -const void* const Functions_SimpleOutput = &collection_SimpleOutput; -const TypeFunction& Function_SimpleOutput_error = (*new TypeFunction{ 0, 0, 1, "SimpleOutput", "error", Functions_SimpleOutput, 0 }); -const TypeFunction& Function_SimpleOutput_stderr = (*new TypeFunction{ 0, 0, 1, "SimpleOutput", "stderr", Functions_SimpleOutput, 1 }); -const TypeFunction& Function_SimpleOutput_stdout = (*new TypeFunction{ 0, 0, 1, "SimpleOutput", "stdout", Functions_SimpleOutput, 2 }); -namespace { -class Category_SimpleOutput; -class Type_SimpleOutput; -S CreateType_SimpleOutput(Params<0>::Type params); -class Value_SimpleOutput; -class Writer; -S CreateValue_SimpleOutput(S writer); -struct Category_SimpleOutput : public TypeCategory { - std::string CategoryName() const final { return "SimpleOutput"; } - Category_SimpleOutput() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("SimpleOutput (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_SimpleOutput::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } -}; -Category_SimpleOutput& CreateCategory_SimpleOutput() { - static auto& category = *new Category_SimpleOutput(); - return category; -} -struct Type_SimpleOutput : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_SimpleOutput& parent; - bool CanConvertFrom(const S& from) const final { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_SimpleOutput()) { - args = std::vector>{}; - return true; - } - if (&category == &GetCategory_BufferedWriter()) { - args = std::vector>{GetType_Formatted(T_get())}; - return true; - } - if (&category == &GetCategory_Writer()) { - args = std::vector>{GetType_Formatted(T_get())}; - return true; - } - return false; - } - Type_SimpleOutput(Category_SimpleOutput& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("SimpleOutput (init @type)") - } - ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_SimpleOutput::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_SimpleOutput[] = { - &Type_SimpleOutput::Call_error, - &Type_SimpleOutput::Call_stderr, - &Type_SimpleOutput::Call_stdout, - }; - if (label.collection == Functions_SimpleOutput) { - if (label.function_num < 0 || label.function_num >= sizeof Table_SimpleOutput / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_SimpleOutput[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); - } - ReturnTuple Call_error(const S& self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_stderr(const S& self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_stdout(const S& self, const ParamTuple& params, const ValueTuple& args); -}; -S CreateType_SimpleOutput(Params<0>::Type params) { - static const auto cached = S_get(new Type_SimpleOutput(CreateCategory_SimpleOutput(), Params<0>::Type())); - return cached; -} -struct Writer { - virtual void Write(const PrimString& message) = 0; - virtual void Flush() = 0; - virtual ~Writer() {} -}; -struct Value_SimpleOutput : public TypeValue { - Value_SimpleOutput(S w) : writer_(w) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_SimpleOutput::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_BufferedWriter[] = { - &Value_SimpleOutput::Call_flush, - }; - static const CallType Table_Writer[] = { - &Value_SimpleOutput::Call_write, - }; - if (label.collection == Functions_BufferedWriter) { - if (label.function_num < 0 || label.function_num >= sizeof Table_BufferedWriter / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_BufferedWriter[label.function_num])(self, params, args); - } - if (label.collection == Functions_Writer) { - if (label.function_num < 0 || label.function_num >= sizeof Table_Writer / sizeof(CallType)) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Writer[label.function_num])(self, params, args); - } - return TypeValue::Dispatch(self, label, params, args); - } - std::string CategoryName() const final { return "SimpleOutput"; } - ReturnTuple Call_flush(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - ReturnTuple Call_write(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - std::mutex mutex_; - const S writer_; -}; -S CreateValue_SimpleOutput(S writer) { - return S_get(new Value_SimpleOutput(writer)); -} -ReturnTuple Type_SimpleOutput::Call_error(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleOutput.error") - return ReturnTuple(Var_error); -} -ReturnTuple Type_SimpleOutput::Call_stderr(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleOutput.stderr") - return ReturnTuple(Var_stderr); -} -ReturnTuple Type_SimpleOutput::Call_stdout(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleOutput.stdout") - return ReturnTuple(Var_stdout); -} -ReturnTuple Value_SimpleOutput::Call_flush(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleOutput.flush"); - std::lock_guard lock(mutex_); - writer_->Flush(); - return ReturnTuple(); -} -ReturnTuple Value_SimpleOutput::Call_write(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("SimpleOutput.write") - const S& Var_arg1 = (args.At(0)); - std::lock_guard lock(mutex_); - writer_->Write(TypeValue::Call(args.At(0), Function_Formatted_formatted, - ParamTuple(), ArgTuple()).Only()->AsString()); - return ReturnTuple(); -} -class StreamWriter : public Writer { - public: - StreamWriter(std::ostream& output) : output_(output) {} - - void Write(const PrimString& message) final { - output_ << message; - } - - void Flush() final {} - - private: - std::ostream& output_; -}; -class ErrorWriter : public Writer { - public: - void Write(const PrimString& message) final { - output_ << message; - } - - void Flush() final { - FAIL() << output_.str(); - } - - std::ostringstream output_; -}; -const S& Var_stdout = CreateValue_SimpleOutput(S_get(new StreamWriter(std::cout))); -const S& Var_stderr = CreateValue_SimpleOutput(S_get(new StreamWriter(std::cerr))); -const S& Var_error = CreateValue_SimpleOutput(S_get(new ErrorWriter())); -} // namespace -TypeCategory& GetCategory_SimpleOutput() { - return CreateCategory_SimpleOutput(); -} -S GetType_SimpleOutput(Params<0>::Type params) { - return CreateType_SimpleOutput(params); -} -#ifdef ZEOLITE_PUBLIC_NAMESPACE -} // namespace ZEOLITE_PUBLIC_NAMESPACE -using namespace ZEOLITE_PUBLIC_NAMESPACE; -#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/Extension_Argv.cpp b/lib/util/Extension_Argv.cpp new file mode 100644 --- /dev/null +++ b/lib/util/Extension_Argv.cpp @@ -0,0 +1,96 @@ +/* ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "category-source.hpp" +#include "Streamlined_Argv.hpp" +#include "Category_Formatted.hpp" +#include "Category_String.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +S CreateValue_Argv(S parent, const ParamTuple& params, int st, int sz); + +namespace { +extern const S& Var_global; +} // namespace + +struct ExtCategory_Argv : public Category_Argv { +}; + +struct ExtType_Argv : public Type_Argv { + inline ExtType_Argv(Category_Argv& p, Params<0>::Type params) : Type_Argv(p, params) {} + + ReturnTuple Call_global(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.global") + return ReturnTuple(Var_global); + } +}; + +struct ExtValue_Argv : public Value_Argv { + inline ExtValue_Argv(S p, const ParamTuple& params, int st, int sz) + : Value_Argv(p, params), start(st), size(sz) {} + + ReturnTuple Call_readPosition(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.readPosition") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + return ReturnTuple(Box_String(Argv::GetArgAt(start + Var_arg1))); + } + + ReturnTuple Call_readSize(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.readSize") + return ReturnTuple(Box_Int(GetSize())); + } + + ReturnTuple Call_subSequence(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Argv.subSequence") + const PrimInt Var_arg1 = (args.At(0))->AsInt(); + const PrimInt Var_arg2 = (args.At(1))->AsInt(); + if (Var_arg1 < 0 || (Var_arg1 > 0 && Var_arg1 >= GetSize())) { + FAIL() << "Subsequence index " << Var_arg1 << " is out of bounds"; + } + if (Var_arg2 < 0 || Var_arg1 + Var_arg2 > GetSize()) { + FAIL() << "Subsequence size " << Var_arg2 << " is invalid"; + } + return ReturnTuple(S(new ExtValue_Argv(parent, ParamTuple(), start + Var_arg1, Var_arg2))); + } + + inline int GetSize() const { return size < 0 ? Argv::ArgCount() : size; } + + const int start; + const int size; +}; + +namespace { +const S& Var_global = *new S(new ExtValue_Argv(CreateType_Argv(Params<0>::Type()), ParamTuple(), 0, -1)); +} // namespace + +Category_Argv& CreateCategory_Argv() { + static auto& category = *new ExtCategory_Argv(); + return category; +} +S CreateType_Argv(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_Argv(CreateCategory_Argv(), Params<0>::Type())); + return cached; +} +S CreateValue_Argv(S parent, const ParamTuple& params, int st, int sz) { + return S_get(new ExtValue_Argv(parent, params, st, sz)); +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/Extension_SimpleInput.cpp b/lib/util/Extension_SimpleInput.cpp new file mode 100644 --- /dev/null +++ b/lib/util/Extension_SimpleInput.cpp @@ -0,0 +1,90 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2021 Kevin P. Barry +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +// TODO: Maybe use C++ instead. +#include + +#include "category-source.hpp" +#include "Streamlined_SimpleInput.hpp" +#include "Category_Formatted.hpp" +#include "Category_String.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +namespace { +extern const S& Var_stdin; +} // namespace + +struct ExtCategory_SimpleInput : public Category_SimpleInput { +}; + +struct ExtType_SimpleInput : public Type_SimpleInput { + inline ExtType_SimpleInput(Category_SimpleInput& p, Params<0>::Type params) : Type_SimpleInput(p, params) {} + + ReturnTuple Call_stdin(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleInput.stdin") + return ReturnTuple(Var_stdin); + } +}; + +struct ExtValue_SimpleInput : public Value_SimpleInput { + inline ExtValue_SimpleInput(S p, const ParamTuple& params, const ValueTuple& args) : Value_SimpleInput(p, params) {} + + ReturnTuple Call_pastEnd(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleInput.pastEnd") + std::lock_guard lock(mutex); + return ReturnTuple(Box_Bool(zero_read)); + } + + ReturnTuple Call_readBlock(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleInput.readBlock") + std::lock_guard lock(mutex); + const int size = args.At(0)->AsInt(); + if (size < 0) { + FAIL() << "Read size " << size << " is invalid"; + } + std::string buffer(size, '\x00'); + const int read_size = read(STDIN_FILENO, &buffer[0], size); + if (read_size < 0) { + return ReturnTuple(Box_String("")); + } else { + zero_read = read_size == 0; + return ReturnTuple(Box_String(buffer.substr(0, read_size))); + } + } + + bool zero_read = false; + std::mutex mutex; +}; + +namespace { +const S& Var_stdin = *new S(new ExtValue_SimpleInput(CreateType_SimpleInput(Params<0>::Type()), ParamTuple(), ArgTuple())); +} // namespace + +Category_SimpleInput& CreateCategory_SimpleInput() { + static auto& category = *new ExtCategory_SimpleInput(); + return category; +} +S CreateType_SimpleInput(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_SimpleInput(CreateCategory_SimpleInput(), Params<0>::Type())); + return cached; +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/lib/util/Extension_SimpleOutput.cpp b/lib/util/Extension_SimpleOutput.cpp new file mode 100644 --- /dev/null +++ b/lib/util/Extension_SimpleOutput.cpp @@ -0,0 +1,136 @@ +/* ----------------------------------------------------------------------------- +Copyright 2019-2021 Kevin P. Barry +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include +#include +#include + +#include "category-source.hpp" +#include "Streamlined_SimpleOutput.hpp" +#include "Category_Formatted.hpp" +#include "Category_String.hpp" + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +namespace ZEOLITE_PUBLIC_NAMESPACE { +#endif // ZEOLITE_PUBLIC_NAMESPACE + +namespace { +extern const S& Var_stdout; +extern const S& Var_stderr; +extern const S& Var_error; +} // namespace + +struct ExtCategory_SimpleOutput : public Category_SimpleOutput { +}; + +struct ExtType_SimpleOutput : public Type_SimpleOutput { + inline ExtType_SimpleOutput(Category_SimpleOutput& p, Params<0>::Type params) : Type_SimpleOutput(p, params) {} + + ReturnTuple Call_error(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.error") + return ReturnTuple(Var_error); + } + + ReturnTuple Call_stderr(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.stderr") + return ReturnTuple(Var_stderr); + } + + ReturnTuple Call_stdout(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.stdout") + return ReturnTuple(Var_stdout); + } +}; + +namespace { +struct Writer { + virtual void Write(const PrimString& message) = 0; + virtual void Flush() = 0; + virtual ~Writer() {} +}; +} // namespace + +struct ExtValue_SimpleOutput : public Value_SimpleOutput { + inline ExtValue_SimpleOutput(S p, const ParamTuple& params, S w) + : Value_SimpleOutput(p, params), writer(w) {} + + ReturnTuple Call_flush(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.flush") + std::lock_guard lock(mutex); + writer->Flush(); + return ReturnTuple(); + } + + ReturnTuple Call_write(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("SimpleOutput.write") + const S& Var_arg1 = (args.At(0)); + std::lock_guard lock(mutex); + writer->Write(TypeValue::Call(args.At(0), Function_Formatted_formatted, + ParamTuple(), ArgTuple()).Only()->AsString()); + return ReturnTuple(); + } + + std::mutex mutex; + const S writer; +}; + +namespace { + +class StreamWriter : public Writer { + public: + StreamWriter(std::ostream& o) : output(o) {} + + void Write(const PrimString& message) final { + output << message; + } + + void Flush() final {} + + private: + std::ostream& output; +}; + +class ErrorWriter : public Writer { + public: + void Write(const PrimString& message) final { + output << message; + } + + void Flush() final { + FAIL() << output.str(); + } + + std::ostringstream output; +}; + +const S& Var_stdout = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), ParamTuple(), S_get(new StreamWriter(std::cout)))); +const S& Var_stderr = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), ParamTuple(), S_get(new StreamWriter(std::cerr)))); +const S& Var_error = *new S(new ExtValue_SimpleOutput(CreateType_SimpleOutput(Params<0>::Type()), ParamTuple(), S_get(new ErrorWriter()))); + +} // namespace + +Category_SimpleOutput& CreateCategory_SimpleOutput() { + static auto& category = *new ExtCategory_SimpleOutput(); + return category; +} +S CreateType_SimpleOutput(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_SimpleOutput(CreateCategory_SimpleOutput(), Params<0>::Type())); + return cached; +} + +#ifdef ZEOLITE_PUBLIC_NAMESPACE +} // namespace ZEOLITE_PUBLIC_NAMESPACE +using namespace ZEOLITE_PUBLIC_NAMESPACE; +#endif // ZEOLITE_PUBLIC_NAMESPACE diff --git a/src/Base/MergeTree.hs b/src/Base/MergeTree.hs --- a/src/Base/MergeTree.hs +++ b/src/Base/MergeTree.hs @@ -89,11 +89,9 @@ pair x2 (MergeAll ys) = allOp $ map (x2 `pair`) ys pair (MergeAll xs) y2 = anyOp $ map (`pair` y2) xs pair x2 (MergeAny ys) = anyOp $ map (x2 `pair`) ys - -separateLeaves :: [MergeTree a] -> ([MergeTree a],[a]) -separateLeaves = foldr split ([],[]) where - split (MergeLeaf x) (ms,ls) = (ms,x:ls) - split x (ms,ls) = (x:ms,ls) + separateLeaves = foldr split ([],[]) where + split (MergeLeaf x2) (ms,ls) = (ms,x2:ls) + split x2 (ms,ls) = (x2:ms,ls) instance Functor MergeTree where fmap f = reduceMergeCommon mergeAny mergeAll (mergeLeaf . f) diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs --- a/src/Cli/Compiler.hs +++ b/src/Cli/Compiler.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -41,7 +41,8 @@ import Cli.Programs import Cli.TestRunner import Compilation.ProcedureContext (ExprMap) -import CompilerCxx.Category +import CompilerCxx.CxxFiles +import CompilerCxx.LanguageModule import CompilerCxx.Naming import Module.CompileMetadata import Module.Paths @@ -50,7 +51,6 @@ import Parser.TextParser (SourceContext) import Types.Builtin import Types.DefinedCategory -import Types.Pragma import Types.Procedure (isLiteralCategory) import Types.TypeCategory import Types.TypeInstance @@ -108,8 +108,9 @@ -- skip checking all inputs/outputs for each dependency. let ns0 = StaticNamespace $ publicNamespace $ show compilerHash ++ path let ns1 = StaticNamespace . privateNamespace $ show time ++ show compilerHash ++ path - let ex = concat $ map getSourceCategories es - let ss = filter (not . isLiteralCategory) ex + let extensions = concat $ map getSourceCategories es + let ss = filter (not . isLiteralCategory) extensions + let ex = filter isLiteralCategory extensions cs <- loadModuleGlobals resolver p (ns0,ns1) ps Nothing deps1' deps2 let cm = createLanguageModule ex ss em cs let cs2 = filter (not . hasCodeVisibility FromDependency) cs @@ -204,6 +205,7 @@ Nothing -> return [] Just o -> return $ map (\c -> Left $ ([o],fakeCxx c)) cs where + allDeps = Set.fromList (cs ++ ds2) fakeCxx c = CxxOutput { coCategory = Just c, coFilename = "", @@ -211,7 +213,7 @@ Just ns2 -> ns2 Nothing -> NoNamespace, coUsesNamespace = Set.fromList [ns0,ns1], - coUsesCategory = Set.fromList ds2, + coUsesCategory = c `Set.delete` allDeps, coOutput = [] } compileExtraSource _ _ paths (OtherSource f2) = do @@ -275,16 +277,20 @@ let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs let ca' = foldr Set.delete ca $ map dcName ds2 let testingCats = Set.fromList $ map getCategoryName ts1 - ts <- mapErrorsM (\n -> compileConcreteTemplate (n `Set.member` testingCats) tm n) $ Set.toList ca' + ts <- fmap concat $ mapErrorsM (\n -> generate (n `Set.member` testingCats) tm n) $ Set.toList ca' mapErrorsM_ writeTemplate ts where - writeTemplate (CxxOutput _ n _ _ _ content) = do - let n' = p d n - exists <- errorFromIO $ doesFileExist n' - if exists - then compilerWarningM $ "Skipping existing file " ++ n - else do - errorFromIO $ hPutStrLn stderr $ "Writing file " ++ n - errorFromIO $ writeFile n' $ concat $ map (++ "\n") content + generate testing tm n = do + (_,t) <- getConcreteCategory tm ([],n) + let ctx = FileContext testing tm Set.empty Map.empty + generateStreamlinedTemplate ctx t + writeTemplate (CxxOutput _ n _ _ _ content) = do + let n' = p d n + exists <- errorFromIO $ doesFileExist n' + if exists + then compilerWarningM $ "Skipping existing file " ++ n + else do + errorFromIO $ hPutStrLn stderr $ "Writing file " ++ n + errorFromIO $ writeFile n' $ concat $ map (++ "\n") content runModuleTests :: (PathIOHandler r, CompilerBackend b) => r -> b -> FilePath -> [FilePath] -> LoadedTests -> TrackedErrorsIO [((Int,Int),TrackedErrors ())] diff --git a/src/Cli/RunCompiler.hs b/src/Cli/RunCompiler.hs --- a/src/Cli/RunCompiler.hs +++ b/src/Cli/RunCompiler.hs @@ -21,7 +21,7 @@ ) where import Control.Monad (foldM,when) -import Data.List (intercalate) +import Data.List (intercalate,nub) import System.Directory import System.FilePath import System.IO @@ -161,13 +161,22 @@ compilerHash = getCompilerHash backend compileSingle d = do d' <- errorFromIO $ canonicalizePath (p d) + (is',is2') <- maybeUseConfig d' base <- resolveBaseModule resolver - as <- fmap fixPaths $ mapErrorsM (resolveModule resolver d') is - as2 <- fmap fixPaths $ mapErrorsM (resolveModule resolver d') is2 + as <- fmap fixPaths $ mapErrorsM (resolveModule resolver d') is' + as2 <- fmap fixPaths $ mapErrorsM (resolveModule resolver d') is2' deps1 <- loadPublicDeps compilerHash f Map.empty (base:as) deps2 <- loadPublicDeps compilerHash f (mapMetadata deps1) as2 path <- errorFromIO $ canonicalizePath p createModuleTemplates resolver path d deps1 deps2 [c] -> TypeInstance -> ExpressionType -> Positional GeneralInstance -> m () ccGetVariable :: a -> UsedVariable c -> m (VariableValue c) ccAddVariable :: a -> UsedVariable c -> VariableValue c -> m a + ccSetReadOnly :: a -> UsedVariable c -> m a + ccSetHidden :: a -> UsedVariable c -> m a ccCheckVariableInit :: a -> [UsedVariable c] -> m () ccWrite :: a -> s -> m a ccGetOutput :: a -> m s @@ -123,7 +126,7 @@ ccSetJumpType :: a -> [c] -> JumpType -> m a ccStartLoop :: a -> LoopSetup s -> m a ccGetLoop :: a -> m (LoopSetup s) - ccStartCleanup :: a -> m a + ccStartCleanup :: a -> [c] -> m a ccPushCleanup :: a -> a -> m a ccGetCleanup :: a -> JumpType -> m (CleanupBlock c s) ccExprLookup :: a -> [c] -> MacroName -> m (Expression c) @@ -184,9 +187,6 @@ JumpMax -- Max value for use as initial state in folds. deriving (Eq,Ord,Show) -instance Show c => Show (VariableValue c) where - show (VariableValue c _ t _) = show t ++ formatFullContextBrace c - csCurrentScope :: CompilerContext c m s a => CompilerState a m SymbolScope csCurrentScope = fmap ccCurrentScope get >>= lift @@ -228,6 +228,14 @@ UsedVariable c -> VariableValue c -> CompilerState a m () csAddVariable v t = fmap (\x -> ccAddVariable x v t) get >>= lift >>= put +csSetReadOnly :: CompilerContext c m s a => + UsedVariable c -> CompilerState a m () +csSetReadOnly v = fmap (\x -> ccSetReadOnly x v) get >>= lift >>= put + +csSetHidden :: CompilerContext c m s a => + UsedVariable c -> CompilerState a m () +csSetHidden v = fmap (\x -> ccSetHidden x v) get >>= lift >>= put + csCheckVariableInit :: CompilerContext c m s a => [UsedVariable c] -> CompilerState a m () csCheckVariableInit vs = fmap (\x -> ccCheckVariableInit x vs) get >>= lift @@ -272,8 +280,8 @@ csStartLoop :: CompilerContext c m s a => LoopSetup s -> CompilerState a m () csStartLoop l = fmap (\x -> ccStartLoop x l) get >>= lift >>= put -csStartCleanup :: CompilerContext c m s a => CompilerState a m () -csStartCleanup = fmap (\x -> ccStartCleanup x) get >>= lift >>= put +csStartCleanup :: CompilerContext c m s a => [c] -> CompilerState a m () +csStartCleanup c = fmap (\x -> ccStartCleanup x c) get >>= lift >>= put csGetLoop :: CompilerContext c m s a => CompilerState a m (LoopSetup s) csGetLoop = fmap ccGetLoop get >>= lift diff --git a/src/Compilation/ProcedureContext.hs b/src/Compilation/ProcedureContext.hs --- a/src/Compilation/ProcedureContext.hs +++ b/src/Compilation/ProcedureContext.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -18,7 +18,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} module Compilation.ProcedureContext ( ExprMap, @@ -29,6 +30,8 @@ ) where import Control.Monad (when) +import Lens.Micro hiding (mapped) +import Lens.Micro.TH import Data.Maybe (fromJust,isJust) import qualified Data.Map as Map import qualified Data.Set as Set @@ -39,42 +42,11 @@ import Base.Positional import Compilation.CompilerState import Types.DefinedCategory -import Types.Pragma (MacroName) import Types.Procedure import Types.TypeCategory import Types.TypeInstance -data ProcedureContext c = - ProcedureContext { - pcScope :: SymbolScope, - pcType :: CategoryName, - pcExtParams :: Positional (ValueParam c), - pcIntParams :: Positional (ValueParam c), - pcMembers :: [DefinedMember c], - pcCategories :: CategoryMap c, - pcAllFilters :: ParamFilters, - pcExtFilters :: [ParamFilter c], - pcIntFilters :: [ParamFilter c], - pcParamScopes :: Map.Map ParamName SymbolScope, - pcFunctions :: Map.Map FunctionName (ScopedFunction c), - pcVariables :: Map.Map VariableName (VariableValue c), - pcReturns :: ReturnValidation c, - pcJumpType :: JumpType, - pcIsNamed :: Bool, - pcPrimNamed :: [ReturnVariable], - pcRequiredTypes :: Set.Set CategoryName, - pcOutput :: [String], - pcDisallowInit :: Bool, - pcLoopSetup :: LoopSetup [String], - pcCleanupBlocks :: [Maybe (CleanupBlock c [String])], - pcInCleanup :: Bool, - pcUsedVars :: [UsedVariable c], - pcExprMap :: ExprMap c, - pcReservedMacros :: [(MacroName,[c])], - pcNoTrace :: Bool - } - type ExprMap c = Map.Map MacroName (Expression c) data ReturnValidation c = @@ -88,59 +60,63 @@ } deriving (Show) +data ProcedureContext c = + ProcedureContext { + _pcScope :: SymbolScope, + _pcType :: CategoryName, + _pcExtParams :: Positional (ValueParam c), + _pcIntParams :: Positional (ValueParam c), + _pcMembers :: [DefinedMember c], + _pcCategories :: CategoryMap c, + _pcAllFilters :: ParamFilters, + _pcExtFilters :: [ParamFilter c], + _pcIntFilters :: [ParamFilter c], + _pcParamScopes :: Map.Map ParamName SymbolScope, + _pcFunctions :: Map.Map FunctionName (ScopedFunction c), + _pcVariables :: Map.Map VariableName (VariableValue c), + _pcReturns :: ReturnValidation c, + _pcJumpType :: JumpType, + _pcIsNamed :: Bool, + _pcPrimNamed :: [ReturnVariable], + _pcRequiredTypes :: Set.Set CategoryName, + _pcOutput :: [String], + _pcDisallowInit :: Bool, + _pcLoopSetup :: LoopSetup [String], + _pcCleanupBlocks :: [Maybe (CleanupBlock c [String])], + _pcInCleanup :: Bool, + _pcUsedVars :: [UsedVariable c], + _pcExprMap :: ExprMap c, + _pcReservedMacros :: [(MacroName,[c])], + _pcNoTrace :: Bool + } + +$(makeLenses ''ProcedureContext) + instance (Show c, CollectErrorsM m) => CompilerContext c m [String] (ProcedureContext c) where - ccCurrentScope = return . pcScope - ccResolver = return . AnyTypeResolver . CategoryResolver . pcCategories + ccCurrentScope = return . (^. pcScope) + ccResolver = return . AnyTypeResolver . CategoryResolver . (^. pcCategories) ccSameType ctx = return . (== same) where - same = TypeInstance (pcType ctx) (fmap (singleType . JustParamName False . vpParam) $ pcExtParams ctx) - ccAllFilters = return . pcAllFilters + same = TypeInstance (ctx ^. pcType) (fmap (singleType . JustParamName False . vpParam) $ ctx ^. pcExtParams) + ccAllFilters = return . (^. pcAllFilters) ccGetParamScope ctx p = do - case p `Map.lookup` pcParamScopes ctx of + case p `Map.lookup` (ctx ^. pcParamScopes) of (Just s) -> return s _ -> compilerErrorM $ "Param " ++ show p ++ " does not exist" - ccAddRequired ctx ts = return $ - ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = Set.union (pcRequiredTypes ctx) ts, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - ccGetRequired = return . pcRequiredTypes - ccGetCategoryFunction ctx c Nothing n = ccGetCategoryFunction ctx c (Just $ pcType ctx) n + ccAddRequired ctx ts = return $ ctx & pcRequiredTypes <>~ ts + ccGetRequired = return . (^. pcRequiredTypes) + ccGetCategoryFunction ctx c Nothing n = ccGetCategoryFunction ctx c (Just $ ctx ^. pcType) n ccGetCategoryFunction ctx c (Just t) n = getFunction where getFunction -- Same category as the procedure itself. - | t == pcType ctx = checkFunction $ n `Map.lookup` pcFunctions ctx + | t == ctx ^. pcType = checkFunction $ n `Map.lookup` (ctx ^. pcFunctions) -- A different category than the procedure. | otherwise = do - (_,ca) <- getCategory (pcCategories ctx) (c,t) + (_,ca) <- getCategory (ctx ^. pcCategories) (c,t) let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca checkFunction $ n `Map.lookup` fa checkFunction (Just f) = do - when (pcDisallowInit ctx && t == pcType ctx && pcScope ctx == CategoryScope) $ + when (ctx ^. pcDisallowInit && t == ctx ^. pcType && ctx ^. pcScope == CategoryScope) $ compilerErrorM $ "Function " ++ show n ++ " disallowed during initialization" ++ formatFullContextBrace c when (sfScope f /= CategoryScope) $ @@ -153,8 +129,8 @@ ccGetTypeFunction ctx c t n = getFunction t where getFunction (Just t2) = reduceMergeTree getFromAny getFromAll getFromSingle t2 getFunction Nothing = do - let ps = fmap (singleType . JustParamName False . vpParam) $ pcExtParams ctx - getFunction (Just $ singleType $ JustTypeInstance $ TypeInstance (pcType ctx) ps) + let ps = fmap (singleType . JustParamName False . vpParam) $ ctx ^. pcExtParams + getFunction (Just $ singleType $ JustTypeInstance $ TypeInstance (ctx ^. pcType) ps) getFromAny _ = compilerErrorM $ "Use explicit type conversion to call " ++ show n ++ " from " ++ show t getFromAll ts = do @@ -171,22 +147,22 @@ "Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c getFromSingle (JustTypeInstance t2) -- Same category as the procedure itself. - | tiName t2 == pcType ctx = - subAndCheckFunction (tiName t2) (fmap vpParam $ pcExtParams ctx) (tiParams t2) $ n `Map.lookup` pcFunctions ctx + | tiName t2 == ctx ^. pcType = + subAndCheckFunction (tiName t2) (fmap vpParam $ ctx ^. pcExtParams) (tiParams t2) $ n `Map.lookup` (ctx ^. pcFunctions) -- A different category than the procedure. | otherwise = do - (_,ca) <- getCategory (pcCategories ctx) (c,tiName t2) + (_,ca) <- getCategory (ctx ^. pcCategories) (c,tiName t2) let params = Positional $ map vpParam $ getCategoryParams ca let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca subAndCheckFunction (tiName t2) params (tiParams t2) $ n `Map.lookup` fa getFromSingle _ = compilerErrorM $ "Type " ++ show t ++ " contains unresolved types" checkDefine t2 = do - (_,ca) <- getCategory (pcCategories ctx) (c,diName t2) + (_,ca) <- getCategory (ctx ^. pcCategories) (c,diName t2) let params = Positional $ map vpParam $ getCategoryParams ca let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca subAndCheckFunction (diName t2) params (diParams t2) $ n `Map.lookup` fa subAndCheckFunction t2 ps1 ps2 (Just f) = do - when (pcDisallowInit ctx && t2 == pcType ctx) $ + when (ctx ^. pcDisallowInit && t2 == ctx ^. pcType) $ compilerErrorM $ "Function " ++ show n ++ " disallowed during initialization" ++ formatFullContextBrace c when (sfScope f == CategoryScope) $ @@ -201,25 +177,25 @@ " does not have a type or value function named " ++ show n ++ formatFullContextBrace c ccCheckValueInit ctx c (TypeInstance t as) ts ps - | t /= pcType ctx = - compilerErrorM $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " ++ + | t /= ctx ^. pcType = + compilerErrorM $ "Category " ++ show (ctx ^. pcType) ++ " cannot initialize values from " ++ show t ++ formatFullContextBrace c | otherwise = "In initialization at " ++ formatFullContext c ??> do - let t' = TypeInstance (pcType ctx) as + let t' = TypeInstance (ctx ^. pcType) as r <- ccResolver ctx allFilters <- ccAllFilters ctx - pa <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcExtParams ctx) as - pa2 <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcIntParams ctx) ps + pa <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcExtParams) as + pa2 <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcIntParams) ps let pa' = Map.union pa pa2 validateTypeInstance r allFilters t' -- Check internal param substitution. - let mapped = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) (pcIntFilters ctx) - let positional = map (getFilters mapped) (map vpParam $ pValues $ pcIntParams ctx) - assigned <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcIntParams ctx) ps + let mapped = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) (ctx ^. pcIntFilters) + let positional = map (getFilters mapped) (map vpParam $ pValues $ ctx ^. pcIntParams) + assigned <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ ctx ^. pcIntParams) ps subbed <- fmap Positional $ mapErrorsM (assignFilters assigned) positional processPairs_ (validateAssignment r allFilters) ps subbed -- Check initializer types. - ms <- fmap Positional $ mapErrorsM (subSingle pa') (pcMembers ctx) + ms <- fmap Positional $ mapErrorsM (subSingle pa') (ctx ^. pcMembers) processPairs_ (checkInit r allFilters) ms (Positional $ zip ([1..] :: [Int]) $ pValues ts) return () where @@ -236,49 +212,30 @@ t2' <- uncheckedSubValueType (getValueForParam pa) t2 return $ MemberValue c2 n t2' ccGetVariable ctx (UsedVariable c n) = - case n `Map.lookup` pcVariables ctx of - (Just v) -> return v - _ -> compilerErrorM $ "Variable " ++ show n ++ " is not defined" ++ - formatFullContextBrace c + case n `Map.lookup` (ctx ^. pcVariables) of + (Just (VariableValue _ _ _ (VariableHidden c2))) -> + compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++ + " was explicitly hidden at " ++ formatFullContext c2 + (Just v) -> return v + _ -> compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++ " is not defined" ccAddVariable ctx (UsedVariable c n) t = do - case n `Map.lookup` pcVariables ctx of + case n `Map.lookup` (ctx ^. pcVariables) of Nothing -> return () (Just v) -> compilerErrorM $ "Variable " ++ show n ++ formatFullContextBrace c ++ " is already defined: " ++ show v - return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = Map.insert n t (pcVariables ctx), - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } + return $ ctx & pcVariables <>~ Map.fromList [(n,t)] + ccSetReadOnly ctx v@(UsedVariable c n) = do + (VariableValue c2 s t _) <- ccGetVariable ctx v + return $ ctx & pcVariables %~ Map.insert n (VariableValue c2 s t (VariableReadOnly c)) + ccSetHidden ctx v@(UsedVariable c n) = do + (VariableValue c2 s t _) <- ccGetVariable ctx v + return $ ctx & pcVariables %~ Map.insert n (VariableValue c2 s t (VariableHidden c)) ccCheckVariableInit ctx vs -- Returns are checked during cleanup inlining. - | pcInCleanup ctx = return () + | ctx ^. pcInCleanup = return () | otherwise = - case pcReturns ctx of + case ctx ^. pcReturns of ValidateNames _ _ na -> mapErrorsM_ (checkSingle na) vs _ -> return () where @@ -286,222 +243,31 @@ when (n `Map.member` na) $ compilerErrorM $ "Named return " ++ show n ++ " might not be initialized" ++ formatFullContextBrace c - ccWrite ctx ss = return $ - ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx ++ ss, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - ccGetOutput = return . pcOutput - ccClearOutput ctx = return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = [], - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - ccUpdateAssigned ctx n = update (pcReturns ctx) where - update (ValidateNames ns ts ra) = return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = ValidateNames ns ts $ Map.delete n ra, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - update _ = return ctx + ccWrite ctx ss = return $ ctx & pcOutput <>~ ss + ccGetOutput = return . (^. pcOutput) + ccClearOutput ctx = return $ ctx & pcOutput .~ mempty + ccUpdateAssigned ctx n = return $ ctx & pcReturns %~ update where + update (ValidateNames ns ts ra) = ValidateNames ns ts $ Map.delete n ra + update rs = rs ccAddUsed ctx v - | pcInCleanup ctx = return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx ++ [v], - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - | otherwise = return ctx - ccInheritReturns ctx cs = return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = returns, - pcJumpType = jump, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = used, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - where - used = pcUsedVars ctx ++ (concat $ map pcUsedVars cs) - (returns,jump) = combineSeries (pcReturns ctx,pcJumpType ctx) inherited - combineSeries (r@(ValidatePositions _),j1) (_,j2) = (r,max j1 j2) - combineSeries (_,j1) (r@(ValidatePositions _),j2) = (r,max j1 j2) - combineSeries (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.intersection ra1 ra2,max j1 j2) - inherited = foldr combineParallel (ValidateNames (Positional []) (Positional []) Map.empty,JumpMax) $ zip (map pcReturns cs) (map pcJumpType cs) - -- Ignore a branch if it jumps to a higher scope. - combineParallel (_,j1) (r,j2) | j1 > NextStatement = (r,min j1 j2) - combineParallel (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.union ra1 ra2,min j1 j2) - combineParallel (r@(ValidatePositions _),j1) (_,j2) = (r,min j1 j2) - combineParallel (_,j1) (r@(ValidatePositions _),j2) = (r,min j1 j2) - ccInheritUsed ctx ctx2 = return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx ++ pcUsedVars ctx2, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } + | ctx ^. pcInCleanup = return $ ctx & pcUsedVars <>~ [v] + | otherwise = return ctx + ccInheritReturns ctx cs = return $ ctx & pcReturns .~ returns & pcJumpType .~ jump & pcUsedVars .~ used where + used = ctx ^. pcUsedVars ++ (concat $ map (^. pcUsedVars) cs) + (returns,jump) = combineSeries (ctx ^. pcReturns,ctx ^. pcJumpType) inherited + combineSeries (r@(ValidatePositions _),j1) (_,j2) = (r,max j1 j2) + combineSeries (_,j1) (r@(ValidatePositions _),j2) = (r,max j1 j2) + combineSeries (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.intersection ra1 ra2,max j1 j2) + inherited = foldr combineParallel (ValidateNames (Positional []) (Positional []) Map.empty,JumpMax) $ zip (map (^. pcReturns) cs) (map (^. pcJumpType) cs) + -- Ignore a branch if it jumps to a higher scope. + combineParallel (_,j1) (r,j2) | j1 > NextStatement = (r,min j1 j2) + combineParallel (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.union ra1 ra2,min j1 j2) + combineParallel (r@(ValidatePositions _),j1) (_,j2) = (r,min j1 j2) + combineParallel (_,j1) (r@(ValidatePositions _),j2) = (r,min j1 j2) + ccInheritUsed ctx ctx2 = return $ ctx & pcUsedVars <>~ (ctx2 ^. pcUsedVars) ccRegisterReturn ctx c vs = do - returns <- check (pcReturns ctx) - return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = returns, - pcJumpType = JumpReturn, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } + returns <- check (ctx ^. pcReturns) + return $ ctx & pcReturns .~ returns & pcJumpType .~ JumpReturn where check (ValidatePositions rs) = do let vs' = case vs of @@ -528,162 +294,50 @@ alwaysError (n,_) = compilerErrorM $ "Named return " ++ show n ++ " might not be initialized" ++ formatFullContextBrace c - ccPrimNamedReturns = return . pcPrimNamed + ccPrimNamedReturns = return . (^. pcPrimNamed) ccIsUnreachable ctx - | pcInCleanup ctx = return $ pcJumpType ctx > JumpReturn - | otherwise = return $ pcJumpType ctx > NextStatement - ccIsNamedReturns = return . pcIsNamed + | ctx ^. pcInCleanup = return $ ctx ^. pcJumpType > JumpReturn + | otherwise = return $ ctx ^. pcJumpType > NextStatement + ccIsNamedReturns = return . (^. pcIsNamed) ccSetJumpType ctx c j - | pcInCleanup ctx && j == JumpBreak = + | ctx ^. pcInCleanup && j == JumpBreak = compilerErrorM $ "Explicit break at " ++ formatFullContext c ++ " not allowed in cleanup" - | pcInCleanup ctx && j == JumpContinue = + | ctx ^. pcInCleanup && j == JumpContinue = compilerErrorM $ "Explicit continue at " ++ formatFullContext c ++ " not allowed in cleanup" - | pcInCleanup ctx && j == JumpReturn = + | ctx ^. pcInCleanup && j == JumpReturn = compilerErrorM $ "Explicit return at " ++ formatFullContext c ++ " not allowed in cleanup" - | otherwise = - return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = max j (pcJumpType ctx), - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - ccStartLoop ctx l = - return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = l, - pcCleanupBlocks = Nothing:(pcCleanupBlocks ctx), - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - ccGetLoop = return . pcLoopSetup - ccStartCleanup ctx = do - let vars = protectReturns (pcReturns ctx) (pcVariables ctx) - return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = vars, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = pcCleanupBlocks ctx, - pcInCleanup = True, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } - where - protectReturns (ValidateNames ns _ _) vs = foldr protect vs (pValues ns) - protectReturns _ vs = vs - protect n vs = - case n `Map.lookup` vs of - Just (VariableValue c s@LocalScope t _) -> Map.insert n (VariableValue c s t False) vs - _ -> vs - ccPushCleanup ctx ctx2 = - return $ ProcedureContext { - pcScope = pcScope ctx, - pcType = pcType ctx, - pcExtParams = pcExtParams ctx, - pcIntParams = pcIntParams ctx, - pcMembers = pcMembers ctx, - pcCategories = pcCategories ctx, - pcAllFilters = pcAllFilters ctx, - pcExtFilters = pcExtFilters ctx, - pcIntFilters = pcIntFilters ctx, - pcParamScopes = pcParamScopes ctx, - pcFunctions = pcFunctions ctx, - pcVariables = pcVariables ctx, - pcReturns = pcReturns ctx, - pcJumpType = pcJumpType ctx, - pcIsNamed = pcIsNamed ctx, - pcPrimNamed = pcPrimNamed ctx, - pcRequiredTypes = pcRequiredTypes ctx, - pcOutput = pcOutput ctx, - pcDisallowInit = pcDisallowInit ctx, - pcLoopSetup = pcLoopSetup ctx, - pcCleanupBlocks = (Just cleanup):(pcCleanupBlocks ctx), - pcInCleanup = pcInCleanup ctx, - pcUsedVars = pcUsedVars ctx, - pcExprMap = pcExprMap ctx, - pcReservedMacros = pcReservedMacros ctx, - pcNoTrace = pcNoTrace ctx - } where - cleanup = CleanupBlock (pcOutput ctx2) (pcUsedVars ctx2) (pcJumpType ctx2) (pcRequiredTypes ctx2) + | otherwise = return $ ctx & pcJumpType %~ max j + ccStartLoop ctx l = return $ ctx & pcLoopSetup .~ l & pcCleanupBlocks %~ (Nothing:) + ccGetLoop = return . (^. pcLoopSetup) + ccStartCleanup ctx c = do + let vars = protectReturns (ctx ^. pcReturns) (ctx ^. pcVariables) + return $ ctx & pcVariables .~ vars & pcInCleanup .~ True where + protectReturns (ValidateNames ns _ _) vs = foldr protect vs (pValues ns) + protectReturns _ vs = vs + protect n vs = + case n `Map.lookup` vs of + Just (VariableValue c2 s@LocalScope t _) -> Map.insert n (VariableValue c2 s t (VariableReadOnly c)) vs + _ -> vs + ccPushCleanup ctx ctx2 = return $ ctx & pcCleanupBlocks %~ (Just cleanup:) where + cleanup = CleanupBlock (ctx2 ^. pcOutput) (ctx2 ^. pcUsedVars) (ctx2 ^. pcJumpType) (ctx2 ^. pcRequiredTypes) ccGetCleanup ctx j = return combined where combined | j == NextStatement = - case pcCleanupBlocks ctx of + case ctx ^. pcCleanupBlocks of ((Just b):_) -> b _ -> emptyCleanupBlock - | j == JumpReturn = combine $ map fromJust $ filter isJust $ pcCleanupBlocks ctx - | j == JumpBreak || j == JumpContinue = combine $ map fromJust $ takeWhile isJust $ pcCleanupBlocks ctx + | j == JumpReturn = combine $ map fromJust $ filter isJust $ ctx ^. pcCleanupBlocks + | j == JumpBreak || j == JumpContinue = combine $ map fromJust $ takeWhile isJust $ ctx ^. pcCleanupBlocks | otherwise = emptyCleanupBlock combine cs = CleanupBlock (concat $ map csCleanup cs) (concat $ map csUsesVars cs) (foldr max NextStatement (map csJumpType cs)) (Set.unions $ map csRequires cs) ccExprLookup ctx c n = - case n `Map.lookup` pcExprMap ctx of + case n `Map.lookup` (ctx ^. pcExprMap) of Nothing -> compilerErrorM $ "Env expression " ++ show n ++ " is not defined" ++ formatFullContextBrace c Just e -> do - checkReserved (pcReservedMacros ctx) [(n,c)] + checkReserved (ctx ^. pcReservedMacros) [(n,c)] return e where checkReserved [] _ = return () @@ -692,94 +346,10 @@ | otherwise = (mapErrorsM_ singleError (m:rs)) (Map.Map VariableName (VariableValue c)) -> @@ -794,7 +364,7 @@ update (PassedValue c t,r) va = do va' <- va case ovName r `Map.lookup` va' of - Nothing -> return $ Map.insert (ovName r) (VariableValue c LocalScope t True) va' + Nothing -> return $ Map.insert (ovName r) (VariableValue c LocalScope t VariableDefault) va' (Just v) -> compilerErrorM $ "Variable " ++ show (ovName r) ++ formatFullContextBrace (ovContext r) ++ " is already defined" ++ @@ -811,7 +381,7 @@ update (PassedValue c t,a) va = do va' <- va case ivName a `Map.lookup` va' of - Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t False) va' + Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t (VariableReadOnly c)) va' (Just v) -> compilerErrorM $ "Variable " ++ show (ivName a) ++ formatFullContextBrace (ivContext a) ++ " is already defined" ++ diff --git a/src/Compilation/ScopeContext.hs b/src/Compilation/ScopeContext.hs --- a/src/Compilation/ScopeContext.hs +++ b/src/Compilation/ScopeContext.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -117,5 +117,5 @@ -- TODO: This is probably in the wrong module. builtinVariables :: TypeInstance -> Map.Map VariableName (VariableValue c) builtinVariables t = Map.fromList [ - (VariableName "self",VariableValue [] ValueScope (ValueType RequiredValue $ singleType $ JustTypeInstance t) False) + (VariableName "self",VariableValue [] ValueScope (ValueType RequiredValue $ singleType $ JustTypeInstance t) (VariableReadOnly [])) ] diff --git a/src/CompilerCxx/Category.hs b/src/CompilerCxx/Category.hs deleted file mode 100644 --- a/src/CompilerCxx/Category.hs +++ /dev/null @@ -1,874 +0,0 @@ -{- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry - -Licensed 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. ------------------------------------------------------------------------------ -} - --- Author: Kevin P. Barry [ta0kira@gmail.com] - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Safe #-} - -module CompilerCxx.Category ( - CxxOutput(..), - LanguageModule(..), - PrivateSource(..), - compileCategoryDeclaration, - compileLanguageModule, - compileConcreteDefinition, - compileConcreteTemplate, - compileInterfaceDefinition, - compileModuleMain, - compileTestsModule, -) where - -import Control.Monad (foldM,when) -import Data.List (intercalate,sortBy) -import Prelude hiding (pi) -import qualified Data.Map as Map -import qualified Data.Set as Set - -#if MIN_VERSION_base(4,11,0) -#else -import Data.Semigroup -#endif - -import Base.CompilerError -import Base.GeneralType -import Base.MergeTree -import Base.Positional -import Compilation.CompilerState -import Compilation.ProcedureContext (ExprMap) -import Compilation.ScopeContext -import CompilerCxx.CategoryContext -import CompilerCxx.Code -import CompilerCxx.Naming -import CompilerCxx.Procedure -import Types.Builtin -import Types.DefinedCategory -import Types.Pragma -import Types.Procedure -import Types.TypeCategory -import Types.TypeInstance -import Types.Variance - - -data CxxOutput = - CxxOutput { - coCategory :: Maybe CategoryName, - coFilename :: String, - coNamespace :: Namespace, - coUsesNamespace :: Set.Set Namespace, - coUsesCategory :: Set.Set CategoryName, - coOutput :: [String] - } - deriving (Show) - -data LanguageModule c = - LanguageModule { - lmPublicNamespaces :: Set.Set Namespace, - lmPrivateNamespaces :: Set.Set Namespace, - lmLocalNamespaces :: Set.Set Namespace, - lmPublicDeps :: [AnyCategory c], - lmPrivateDeps :: [AnyCategory c], - lmTestingDeps :: [AnyCategory c], - lmPublicLocal :: [AnyCategory c], - lmPrivateLocal :: [AnyCategory c], - lmTestingLocal :: [AnyCategory c], - lmExternal :: [CategoryName], - lmStreamlined :: [CategoryName], - lmExprMap :: ExprMap c - } - -data PrivateSource c = - PrivateSource { - psNamespace :: Namespace, - psTesting :: Bool, - psCategory :: [AnyCategory c], - psDefine :: [DefinedCategory c] - } - -compileLanguageModule :: (Ord c, Show c, CollectErrorsM m) => - LanguageModule c -> [PrivateSource c] -> m [CxxOutput] -compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex ss em) xa = do - checkSupefluous $ Set.toList $ (Set.fromList ex) `Set.difference` ca - -- Check public sources up front so that error messages aren't duplicated for - -- every source file. - ta <- tmTesting - xx1 <- fmap concat $ mapErrorsM (compileSourceP False tmPublic nsPublic) cs1 - xx2 <- fmap concat $ mapErrorsM (compileSourceP False tmPrivate nsPrivate) ps1 - xx3 <- fmap concat $ mapErrorsM (compileSourceP True tmTesting nsTesting) ts1 - (ds,xx4) <- fmap mergeGeneratedX $ mapErrorsM compileSourceX xa - xx5 <- fmap concat $ mapErrorsM (\s -> compileConcreteStreamlined (s `Set.member` testingCats) ta s) ss - -- TODO: This should account for a name clash between a category declared in a - -- TestsOnly .0rp and one declared in a non-TestOnly .0rx. - let dm = mapByName ds - checkDefined dm ex $ filter isValueConcrete (cs1 ++ ps1 ++ ts1) - checkStreamlined - return $ xx1 ++ xx2 ++ xx3 ++ xx4 ++ xx5 where - testingCats = Set.fromList $ map getCategoryName ts1 - tmPublic = foldM includeNewTypes defaultCategories [cs0,cs1] - tmPrivate = tmPublic >>= \tm -> foldM includeNewTypes tm [ps0,ps1] - tmTesting = tmPrivate >>= \tm -> foldM includeNewTypes tm [ts0,ts1] - nsPublic = ns0 `Set.union` ns2 - nsPrivate = ns1 `Set.union` nsPublic - nsTesting = nsPrivate - compileSourceP testing tm ns c = do - tm' <- tm - hxx <- compileCategoryDeclaration testing tm' ns c - cxx <- if isValueConcrete c - then return [] - else compileInterfaceDefinition testing c >>= return . (:[]) - return (hxx:cxx) - compileSourceX (PrivateSource ns testing cs2 ds) = do - tm <- if testing - then tmTesting - else tmPrivate - let ns4 = if testing - then nsTesting - else nsPrivate - let cs = if testing - then cs1 ++ ps1 ++ ts1 - else cs1 ++ ps1 - checkLocals ds (ex ++ map getCategoryName (cs2 ++ cs)) - when testing $ checkTests ds (cs1 ++ ps1) - let dm = mapByName ds - checkDefined dm [] $ filter isValueConcrete cs2 - tm' <- includeNewTypes tm cs2 - -- Ensures that there isn't an inavertent collision when resolving - -- dependencies for the module later on. - tmTesting' <- tmTesting - _ <- (includeNewTypes tmTesting' cs2) - hxx <- mapErrorsM (compileCategoryDeclaration testing tm' ns4) cs2 - let interfaces = filter (not . isValueConcrete) cs2 - cxx1 <- mapErrorsM (compileInterfaceDefinition testing) interfaces - cxx2 <- mapErrorsM (compileDefinition testing tm' (ns `Set.insert` ns4)) ds - return (ds,hxx ++ cxx1 ++ cxx2) - mergeGeneratedX ((ds,xx):xs2) = let (ds2,xx2) = mergeGeneratedX xs2 in (ds++ds2,xx++xx2) - mergeGeneratedX _ = ([],[]) - compileDefinition testing tm ns4 d = do - tm' <- mergeInternalInheritance tm d - let refines = dcName d `Map.lookup` tm >>= return . getCategoryRefines - compileConcreteDefinition testing tm' em ns4 refines d - mapByName = Map.fromListWith (++) . map (\d -> (dcName d,[d])) - ca = Set.fromList $ map getCategoryName $ filter isValueConcrete (cs1 ++ ps1 ++ ts1) - checkLocals ds cs2 = mapErrorsM_ (checkLocal $ Set.fromList cs2) ds - checkLocal cs2 d = - when (not $ dcName d `Set.member` cs2) $ - compilerErrorM ("Definition for " ++ show (dcName d) ++ - formatFullContextBrace (dcContext d) ++ - " does not correspond to a visible category in this module") - checkTests ds ps = do - let pa = Map.fromList $ map (\c -> (getCategoryName c,getCategoryContext c)) $ filter isValueConcrete ps - mapErrorsM_ (checkTest pa) ds - checkTest pa d = - case dcName d `Map.lookup` pa of - Nothing -> return () - Just c -> - compilerErrorM ("Category " ++ show (dcName d) ++ - formatFullContextBrace (dcContext d) ++ - " was not declared as $TestsOnly$" ++ formatFullContextBrace c) - checkDefined dm ex2 = mapErrorsM_ (checkSingle dm (Set.fromList ex2)) - checkSingle dm es t = - case (getCategoryName t `Set.member` es, getCategoryName t `Map.lookup` dm) of - (False,Just [_]) -> return () - (True,Nothing) -> return () - (True,Just [d]) -> - compilerErrorM ("Category " ++ show (getCategoryName t) ++ - formatFullContextBrace (getCategoryContext t) ++ - " was declared external but is also defined at " ++ formatFullContext (dcContext d)) - (False,Nothing) -> - compilerErrorM ("Category " ++ show (getCategoryName t) ++ - formatFullContextBrace (getCategoryContext t) ++ - " has not been defined or declared external") - (_,Just ds) -> - ("Category " ++ show (getCategoryName t) ++ - formatFullContextBrace (getCategoryContext t) ++ - " is defined " ++ show (length ds) ++ " times") !!> - mapErrorsM_ (\d -> compilerErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds - checkSupefluous es2 - | null es2 = return () - | otherwise = compilerErrorM $ "External categories either not concrete or not present: " ++ - intercalate ", " (map show es2) - checkStreamlined = mapErrorsM_ streamlinedError $ Set.toList $ Set.difference (Set.fromList ss) (Set.fromList ex) - streamlinedError n = - compilerErrorM $ "Category " ++ show n ++ " cannot be streamlined because it was not declared external" - -compileTestsModule :: (Ord c, Show c, CollectErrorsM m) => - LanguageModule c -> Namespace -> [String] -> [AnyCategory c] -> [DefinedCategory c] -> - [TestProcedure c] -> m ([CxxOutput],CxxOutput,[(FunctionName,[c])]) -compileTestsModule cm ns args cs ds ts = do - let xs = PrivateSource { - psNamespace = ns, - psTesting = True, - psCategory = cs, - psDefine = ds - } - xx <- compileLanguageModule cm [xs] - (main,fs) <- compileTestMain cm args xs ts - return (xx,main,fs) - -compileTestMain :: (Ord c, Show c, CollectErrorsM m) => - LanguageModule c -> [String] -> PrivateSource c -> [TestProcedure c] -> - m (CxxOutput,[(FunctionName,[c])]) -compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ _ em) args ts2 tests = do - tm' <- tm - (CompiledData req main) <- createTestFile tm' em args tests - let output = CxxOutput Nothing testFilename NoNamespace (psNamespace ts2 `Set.insert` Set.unions [ns0,ns1,ns2]) req main - let tests' = map (\t -> (tpName t,tpContext t)) tests - return (output,tests') where - tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2] - -compileModuleMain :: (Ord c, Show c, CollectErrorsM m) => - LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput -compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 _ cs1 ps1 _ _ _ em) xa n f = do - let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine $ filter (not . psTesting) xa - reconcile resolved - tm' <- tm - let cs = filter (\c -> getCategoryName c == n) $ concat $ map psCategory xa - tm'' <- includeNewTypes tm' cs - (ns,main) <- createMainFile tm'' em n f - return $ CxxOutput Nothing mainFilename NoNamespace (ns `Set.insert` Set.unions [ns0,ns1,ns2]) (Set.fromList [n]) main where - tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1] - reconcile [_] = return () - reconcile [] = compilerErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)" - reconcile ds = - "Multiple matches for main category " ++ show n !!> - mapErrorsM_ (\d -> compilerErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds - -compileCategoryDeclaration :: (Ord c, Show c, CollectErrorsM m) => - Bool -> CategoryMap c -> Set.Set Namespace -> AnyCategory c -> m CxxOutput -compileCategoryDeclaration testing _ ns t = - return $ CxxOutput (Just $ getCategoryName t) - (headerFilename name) - (getCategoryNamespace t) - (getCategoryNamespace t `Set.insert` ns) - (cdRequired file) - (cdOutput file) where - file = mconcat $ [ - CompiledData depends [], - onlyCodes guardTop, - onlyCodes $ (if testing then testsOnlyCategoryGuard (getCategoryName t) else []), - onlyCodes baseHeaderIncludes, - addNamespace t content, - onlyCodes guardBottom - ] - depends = getCategoryDeps t - content = onlyCodes $ collection ++ labels ++ getCategory2 ++ getType - name = getCategoryName t - guardTop = ["#ifndef " ++ guardName,"#define " ++ guardName] - guardBottom = ["#endif // " ++ guardName] - guardName = "HEADER_" ++ guardNamespace ++ show name - guardNamespace - | isStaticNamespace $ getCategoryNamespace t = show (getCategoryNamespace t) ++ "_" - | otherwise = "" - labels = map label $ filter ((== name) . sfType) $ getCategoryFunctions t - label f = "extern " ++ functionLabelType f ++ " " ++ functionName f ++ ";" - collection - | isValueConcrete t = [] - | otherwise = ["extern const void* const " ++ collectionName name ++ ";"] - getCategory2 - | isInstanceInterface t = [] - | otherwise = declareGetCategory t - getType - | isInstanceInterface t = [] - | otherwise = declareGetType t - -compileInterfaceDefinition :: CollectErrorsM m => Bool -> AnyCategory c -> m CxxOutput -compileInterfaceDefinition testing t = do - te <- typeConstructor - commonDefineAll testing t Set.empty Nothing emptyCode emptyCode emptyCode te [] - where - typeConstructor = do - let ps = map vpParam $ getCategoryParams t - let argParent = categoryName (getCategoryName t) ++ "& p" - let argsPassed = "Params<" ++ show (length ps) ++ ">::Type params" - let allArgs = intercalate ", " [argParent,argsPassed] - let initParent = "parent(p)" - let initPassed = map (\(i,p) -> paramName p ++ "(std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps - let allInit = intercalate ", " $ initParent:initPassed - return $ onlyCode $ typeName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" - -compileConcreteTemplate :: (Ord c, Show c, CollectErrorsM m) => - Bool -> CategoryMap c -> CategoryName -> m CxxOutput -compileConcreteTemplate testing ta n = do - (_,t) <- getConcreteCategory ta ([],n) - compileConcreteDefinition testing ta Map.empty Set.empty Nothing (defined t) - Bool -> CategoryMap c -> CategoryName -> m [CxxOutput] -compileConcreteStreamlined testing ta n = "In streamlined compilation of " ++ show n ??> do - (_,t) <- getConcreteCategory ta ([],n) - let guard = if testing - then testsOnlySourceGuard - else noTestsOnlySourceGuard - -- TODO: Implement this. - let hxx = CxxOutput (Just $ getCategoryName t) - (headerStreamlined $ getCategoryName t) - (getCategoryNamespace t) - (Set.fromList [getCategoryNamespace t]) - (Set.fromList $ getCategoryMentions t) - guard - let cxx = CxxOutput (Just $ getCategoryName t) - (sourceStreamlined $ getCategoryName t) - (getCategoryNamespace t) - (Set.fromList [getCategoryNamespace t]) - (Set.fromList $ getCategoryMentions t) - [] - return [hxx,cxx] - -compileConcreteDefinition :: (Ord c, Show c, CollectErrorsM m) => - Bool -> CategoryMap c -> ExprMap c -> Set.Set Namespace -> Maybe [ValueRefine c] -> - DefinedCategory c -> m CxxOutput -compileConcreteDefinition testing ta em ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do - (_,t) <- getConcreteCategory ta (c,n) - let r = CategoryResolver ta - [cp,tp,vp] <- getProcedureScopes ta em dd - let (cm,tm,vm) = partitionByScope dmScope ms - let filters = getCategoryFilters t - let filters2 = fi - allFilters <- getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2 - -- Functions explicitly declared externally. - let externalFuncs = Set.fromList $ map sfName $ filter ((== n) . sfType) $ getCategoryFunctions t - -- Functions explicitly declared internally. - let overrideFuncs = Map.fromList $ map (\f -> (sfName f,f)) fs - -- Functions only declared internally. - let internalFuncs = Map.filter (not . (`Set.member` externalFuncs) . sfName) overrideFuncs - let fe = Map.elems internalFuncs - let allFuncs = getCategoryFunctions t ++ fe - cf <- collectAllM $ applyProcedureScope compileExecutableProcedure cp - ce <- concatM [ - categoryConstructor t cm, - categoryDispatch allFuncs, - return $ mconcat $ map fst cf, - concatM $ map (createMemberLazy r allFilters) cm - ] - tf <- collectAllM $ applyProcedureScope compileExecutableProcedure tp - disallowTypeMembers tm - te <- concatM [ - typeConstructor t tm, - typeDispatch allFuncs, - return $ mconcat $ map fst tf, - concatM $ map (createMember r allFilters) tm - ] - vf <- collectAllM $ applyProcedureScope compileExecutableProcedure vp - let internalCount = length pi - let memberCount = length vm - top <- concatM [ - return $ onlyCode $ "class " ++ valueName n ++ ";", - declareInternalValue n internalCount memberCount - ] - defineValue <- concatM [ - return $ onlyCode $ "struct " ++ valueName n ++ " : public " ++ valueBase ++ " {", - fmap indentCompiled $ valueConstructor vm, - fmap indentCompiled $ valueDispatch allFuncs, - return $ indentCompiled $ defineCategoryName ValueScope n, - return $ indentCompiled $ mconcat $ map fst vf, - fmap indentCompiled $ concatM $ map (createMember r allFilters) vm, - fmap indentCompiled $ createParams, - return $ indentCompiled $ onlyCode $ "const S<" ++ typeName n ++ "> parent;", - return $ indentCompiled $ onlyCodes $ traceCreation (psProcedures vp), - return $ onlyCode "};" - ] - bottom <- concatM $ [ - return $ defineValue, - defineInternalValue n internalCount memberCount - ] ++ map (return . snd) (cf ++ tf ++ vf) - commonDefineAll testing t ns rs top bottom ce te fe - where - disallowTypeMembers :: (Ord c, Show c, CollectErrorsM m) => - [DefinedMember c] -> m () - disallowTypeMembers tm = - collectAllM_ $ flip map tm - (\m -> compilerErrorM $ "Member " ++ show (dmName m) ++ - " is not allowed to be @type-scoped" ++ - formatFullContextBrace (dmContext m)) - createParams = concatM $ map createParam pi - createParam p = return $ onlyCode $ paramType ++ " " ++ paramName (vpParam p) ++ ";" - -- TODO: Can probably remove this if @type members are disallowed. Or, just - -- skip it if there are no @type members. - getCycleCheck n2 = [ - "CycleCheck<" ++ n2 ++ ">::Check();", - "CycleCheck<" ++ n2 ++ "> marker(*this);" - ] - categoryConstructor t ms2 = do - ctx <- getContextForInit ta em t dd CategoryScope - initMembers <- runDataCompiler (sequence $ map compileLazyInit ms2) ctx - let initMembersStr = intercalate ", " $ cdOutput initMembers - let initColon = if null initMembersStr then "" else " : " - concatM [ - return $ onlyCode $ categoryName n ++ "()" ++ initColon ++ initMembersStr ++ " {", - return $ indentCompiled $ onlyCodes $ getCycleCheck (categoryName n), - return $ indentCompiled $ onlyCode $ startInitTracing n CategoryScope, - return $ onlyCode "}", - return $ clearCompiled initMembers -- Inherit required types. - ] - typeConstructor t ms2 = do - let ps2 = map vpParam $ getCategoryParams t - let argParent = categoryName n ++ "& p" - let paramsPassed = "Params<" ++ show (length ps2) ++ ">::Type params" - let allArgs = intercalate ", " [argParent,paramsPassed] - let initParent = "parent(p)" - let initPassed = map (\(i,p) -> paramName p ++ "(std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps2 - let allInit = intercalate ", " $ initParent:initPassed - ctx <- getContextForInit ta em t dd TypeScope - initMembers <- runDataCompiler (sequence $ map compileRegularInit ms2) ctx - concatM [ - return $ onlyCode $ typeName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {", - return $ indentCompiled $ onlyCodes $ getCycleCheck (typeName n), - return $ indentCompiled $ onlyCode $ startInitTracing n TypeScope, - return $ indentCompiled $ initMembers, - return $ onlyCode "}" - ] - valueConstructor ms2 = do - let argParent = "S<" ++ typeName n ++ "> p" - let paramsPassed = "const ParamTuple& params" - let argsPassed = "const ValueTuple& args" - let allArgs = intercalate ", " [argParent,paramsPassed,argsPassed] - let initParent = "parent(p)" - let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(params.At(" ++ show i ++ "))") $ zip ([0..] :: [Int]) pi - let initArgs = map (\(i,m) -> variableName (dmName m) ++ "(" ++ unwrappedArg i m ++ ")") $ zip ([0..] :: [Int]) ms2 - let allInit = intercalate ", " $ initParent:(initParams ++ initArgs) - return $ onlyCode $ valueName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" - unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") - createMember r filters m = do - validateGeneralInstance r filters (vtType $ dmType m) & self, " ++ - "const TypeFunction& label, " ++ - "const ParamTuple& params, " ++ - "const ValueTuple& args) final {" - ] ++ createFunctionDispatch n TypeScope fs2 ++ ["}"] - valueDispatch fs2 = - return $ onlyCodes $ [ - "ReturnTuple Dispatch(" ++ - "const S& self, " ++ - "const ValueFunction& label, " ++ - "const ParamTuple& params," ++ - "const ValueTuple& args) final {" - ] ++ createFunctionDispatch n ValueScope fs2 ++ ["}"] - traceCreation vp - | any isTraceCreation $ concat $ map (epPragmas . snd) vp = [captureCreationTrace] - | otherwise = [] - -commonDefineAll :: CollectErrorsM m => - Bool -> AnyCategory c -> Set.Set Namespace -> Maybe [ValueRefine c] -> - CompiledData [String] -> CompiledData [String] -> CompiledData [String] -> - CompiledData [String] -> [ScopedFunction c] -> m CxxOutput -commonDefineAll testing t ns rs top bottom ce te fe = do - let filename = sourceFilename name - (CompiledData req out) <- fmap (addNamespace t) $ concatM $ [ - return $ CompiledData (Set.fromList (name:getCategoryMentions t)) [], - return $ mconcat [createCollection,createAllLabels] - ] ++ conditionalContent - let rs' = case rs of - Nothing -> [] - Just rs2 -> rs2 - let guard = if testing - then testsOnlySourceGuard - else noTestsOnlySourceGuard - let inherited = Set.unions $ (map (categoriesFromRefine . vrType) (getCategoryRefines t ++ rs')) ++ - (map (categoriesFromDefine . vdType) $ getCategoryDefines t) - let includes = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $ - Set.toList $ Set.union req inherited - return $ CxxOutput (Just $ getCategoryName t) - filename - (getCategoryNamespace t) - (getCategoryNamespace t `Set.insert` ns) - req - (guard ++ baseSourceIncludes ++ includes ++ out) - where - conditionalContent - | isInstanceInterface t = [] - | otherwise = [ - return $ onlyCode $ "namespace {", - declareTypes, - declareInternalType name paramCount, - return top, - commonDefineCategory t ce, - return $ onlyCodes getInternal, - commonDefineType t rs te, - defineInternalType name paramCount, - return bottom, - return $ onlyCode $ "} // namespace", - return $ onlyCodes $ getCategory2 ++ getType - ] - declareTypes = - return $ onlyCodes $ map (\f -> "class " ++ f name ++ ";") [categoryName,typeName] - paramCount = length $ getCategoryParams t - name = getCategoryName t - createCollection = onlyCodes [ - "namespace {", - "const int " ++ collectionValName ++ " = 0;", - "} // namespace", - "const void* const " ++ collectionName name ++ " = &" ++ collectionValName ++ ";" - ] - collectionValName = "collection_" ++ show name - (fc,ft,fv) = partitionByScope sfScope $ getCategoryFunctions t ++ fe - createAllLabels = onlyCodes $ concat $ map createLabels [fc,ft,fv] - createLabels = map (uncurry createLabelForFunction) . zip [0..] . sortBy compareName . filter ((== name) . sfType) - getInternal = defineInternalCategory t - getCategory2 = defineGetCatetory t - getType = defineGetType t - compareName x y = sfName x `compare` sfName y - -addNamespace :: AnyCategory c -> CompiledData [String] -> CompiledData [String] -addNamespace t cs - | isStaticNamespace $ getCategoryNamespace t = mconcat [ - onlyCode $ "namespace " ++ show (getCategoryNamespace t) ++ " {", - cs, - onlyCode $ "} // namespace " ++ show (getCategoryNamespace t), - onlyCode $ "using namespace " ++ show (getCategoryNamespace t) ++ ";" - ] - | isPublicNamespace $ getCategoryNamespace t = mconcat [ - onlyCode $ "#ifdef " ++ publicNamespaceMacro, - onlyCode $ "namespace " ++ publicNamespaceMacro ++ " {", - onlyCode $ "#endif // " ++ publicNamespaceMacro, - cs, - onlyCode $ "#ifdef " ++ publicNamespaceMacro, - onlyCode $ "} // namespace " ++ publicNamespaceMacro, - onlyCode $ "using namespace " ++ publicNamespaceMacro ++ ";", - onlyCode $ "#endif // " ++ publicNamespaceMacro - ] - | isPrivateNamespace $ getCategoryNamespace t = mconcat [ - onlyCode $ "#ifdef " ++ privateNamespaceMacro, - onlyCode $ "namespace " ++ privateNamespaceMacro ++ " {", - onlyCode $ "#endif // " ++ privateNamespaceMacro, - cs, - onlyCode $ "#ifdef " ++ privateNamespaceMacro, - onlyCode $ "} // namespace " ++ privateNamespaceMacro, - onlyCode $ "using namespace " ++ privateNamespaceMacro ++ ";", - onlyCode $ "#endif // " ++ privateNamespaceMacro - ] - | otherwise = cs - -createLabelForFunction :: Int -> ScopedFunction c -> String -createLabelForFunction i f = functionLabelType f ++ " " ++ functionName f ++ - " = " ++ newFunctionLabel i f ++ ";" - -createFunctionDispatch :: CategoryName -> SymbolScope -> [ScopedFunction c] -> [String] -createFunctionDispatch n s fs = [typedef] ++ concat (map table $ byCategory) ++ - concat (map dispatch $ byCategory) ++ [fallback] where - filtered = filter ((== s) . sfScope) fs - flatten f = f:(concat $ map flatten $ sfMerges f) - flattened = concat $ map flatten filtered - byCategory = Map.toList $ Map.fromListWith (++) $ map (\f -> (sfType f,[f])) flattened - typedef - | s == CategoryScope = " using CallType = ReturnTuple(" ++ categoryName n ++ - "::*)(const ParamTuple&, const ValueTuple&);" - | s == TypeScope = " using CallType = ReturnTuple(" ++ typeName n ++ - "::*)(const S&, const ParamTuple&, const ValueTuple&);" - | s == ValueScope = " using CallType = ReturnTuple(" ++ valueName n ++ - "::*)(const S&, const ParamTuple&, const ValueTuple&);" - | otherwise = undefined - name f - | s == CategoryScope = categoryName n ++ "::" ++ callName f - | s == TypeScope = typeName n ++ "::" ++ callName f - | s == ValueScope = valueName n ++ "::" ++ callName f - | otherwise = undefined - table (n2,fs2) = - [" static const CallType " ++ tableName n2 ++ "[] = {"] ++ - map (\f -> " &" ++ name f ++ ",") (Set.toList $ Set.fromList $ map sfName fs2) ++ - [" };"] - dispatch (n2,_) = [ - " if (label.collection == " ++ collectionName n2 ++ ") {", - " if (label.function_num < 0 || label.function_num >= sizeof " ++ tableName n2 ++ " / sizeof(CallType)) {", - " FAIL() << \"Bad function call \" << label;", - " }", - " return (this->*" ++ tableName n2 ++ "[label.function_num])(" ++ args ++ ");", - " }" - ] - args - | s == CategoryScope = "params, args" - | s == TypeScope = "self, params, args" - | s == ValueScope = "self, params, args" - | otherwise = undefined - fallback - | s == CategoryScope = " return TypeCategory::Dispatch(label, params, args);" - | s == TypeScope = " return TypeInstance::Dispatch(self, label, params, args);" - | s == ValueScope = " return TypeValue::Dispatch(self, label, params, args);" - | otherwise = undefined - -commonDefineCategory :: CollectErrorsM m => - AnyCategory c -> CompiledData [String] -> m (CompiledData [String]) -commonDefineCategory t extra = do - concatM $ [ - return $ onlyCode $ "struct " ++ categoryName name ++ " : public " ++ categoryBase ++ " {", - return $ indentCompiled $ defineCategoryName CategoryScope name, - return $ indentCompiled extra, - return $ onlyCode "};" - ] - where - name = getCategoryName t - -commonDefineType :: CollectErrorsM m => - AnyCategory c -> Maybe [ValueRefine c] -> CompiledData [String] -> m (CompiledData [String]) -commonDefineType t rs extra = do - let rs' = case rs of - Nothing -> getCategoryRefines t - Just rs2 -> rs2 - concatM [ - return $ CompiledData depends [], - return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", - return $ indentCompiled $ defineCategoryName TypeScope name, - return $ indentCompiled $ defineTypeName name (map vpParam $ getCategoryParams t), - return $ indentCompiled $ onlyCode $ categoryName (getCategoryName t) ++ "& parent;", - return $ indentCompiled createParams, - return $ indentCompiled canConvertFrom, - return $ indentCompiled $ typeArgsForParent rs', - return $ indentCompiled extra, - return $ onlyCode "};" - ] - where - name = getCategoryName t - depends = getCategoryDeps t - createParams = mconcat $ map createParam $ getCategoryParams t - createParam p = onlyCode $ paramType ++ " " ++ paramName (vpParam p) ++ ";" - canConvertFrom - | isInstanceInterface t = emptyCode - | otherwise = onlyCodes $ [ - "bool CanConvertFrom(const S& from) const final {", - -- TODO: This should be a typedef. - " std::vector> args;", - " if (!from->TypeArgsForParent(parent, args)) return false;", - -- TODO: Create a helper function for this error. - " if(args.size() != " ++ show (length params) ++ ") {", - " FAIL() << \"Wrong number of args (\" << args.size() << \") for \" << CategoryName();", - " }" - ] ++ checks ++ [" return true;","}"] - params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t - checks = concat $ map singleCheck $ zip ([0..] :: [Int]) params - singleCheck (i,(p,Covariant)) = [checkCov i p] - singleCheck (i,(p,Contravariant)) = [checkCon i p] - singleCheck (i,(p,Invariant)) = [checkCov i p,checkCon i p] - checkCov i p = " if (!TypeInstance::CanConvert(args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;" - checkCon i p = " if (!TypeInstance::CanConvert(" ++ paramName p ++ ", args[" ++ show i ++ "])) return false;" - typeArgsForParent rs2 - | isInstanceInterface t = emptyCode - | otherwise = onlyCodes $ [ - "bool TypeArgsForParent(" ++ - "const TypeCategory& category, " ++ - "std::vector>& args) const final {" - ] ++ allCats rs2 ++ [" return false;","}"] - myType = (getCategoryName t,map (singleType . JustParamName False . fst) params) - refines rs2 = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType rs2 - allCats rs2 = concat $ map singleCat (myType:refines rs2) - singleCat (t2,ps) = [ - " if (&category == &" ++ categoryGetter t2 ++ "()) {", - " args = std::vector>{" ++ expanded ++ "};", - " return true;", - " }" - ] - where - expanded = intercalate ", " $ map expandLocalType ps - --- Similar to Procedure.expandGeneralInstance but doesn't account for scope. -expandLocalType :: GeneralInstance -> String -expandLocalType t - | t == minBound = allGetter ++ "()" - | t == maxBound = anyGetter ++ "()" -expandLocalType t = reduceMergeTree getAny getAll getSingle t where - getAny ts = unionGetter ++ combine ts - getAll ts = intersectGetter ++ combine ts - getSingle (JustTypeInstance (TypeInstance t2 ps)) = - typeGetter t2 ++ "(T_get(" ++ intercalate ", " (map expandLocalType $ pValues ps) ++ "))" - getSingle (JustParamName _ p) = paramName p - getSingle (JustInferredType p) = paramName p - combine ps = "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps) ++ "))" - -defineCategoryName :: SymbolScope -> CategoryName -> CompiledData [String] -defineCategoryName TypeScope _ = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }" -defineCategoryName ValueScope _ = onlyCode $ "std::string CategoryName() const final { return parent->CategoryName(); }" -defineCategoryName _ t = onlyCode $ "std::string CategoryName() const final { return \"" ++ show t ++ "\"; }" - -defineTypeName :: CategoryName -> [ParamName] -> CompiledData [String] -defineTypeName _ ps = - onlyCodes [ - "void BuildTypeName(std::ostream& output) const final {", - " return TypeInstance::TypeNameFrom(output, parent" ++ concat (map ((", " ++) . paramName) ps) ++ ");", - "}" - ] - -declareGetCategory :: AnyCategory c -> [String] -declareGetCategory t = [categoryBase ++ "& " ++ categoryGetter (getCategoryName t) ++ "();"] - -defineGetCatetory :: AnyCategory c -> [String] -defineGetCatetory t = [ - categoryBase ++ "& " ++ categoryGetter (getCategoryName t) ++ "() {", - " return " ++ categoryCreator (getCategoryName t) ++ "();", - "}" - ] - -declareGetType :: AnyCategory c -> [String] -declareGetType t = ["S<" ++ typeBase ++ "> " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ - show (length $getCategoryParams t) ++ ">::Type params);"] - -defineGetType :: AnyCategory c -> [String] -defineGetType t = [ - "S<" ++ typeBase ++ "> " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ - show (length $ getCategoryParams t) ++ ">::Type params) {", - " return " ++ typeCreator (getCategoryName t) ++ "(params);", - "}" - ] - -defineInternalCategory :: AnyCategory c -> [String] -defineInternalCategory t = [ - internal ++ "& " ++ categoryCreator (getCategoryName t) ++ "() {", - " static auto& category = *new " ++ internal ++ "();", - " return category;", - "}" - ] - where - internal = categoryName (getCategoryName t) - -declareInternalType :: Monad m => - CategoryName -> Int -> m (CompiledData [String]) -declareInternalType t n = - return $ onlyCode $ "S<" ++ typeName t ++ "> " ++ typeCreator t ++ - "(Params<" ++ show n ++ ">::Type params);" - -defineInternalType :: Monad m => - CategoryName -> Int -> m (CompiledData [String]) -defineInternalType t n - | n < 1 = - return $ onlyCodes [ - "S<" ++ typeName t ++ "> " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params) {", - " static const auto cached = S_get(new " ++ typeName t ++ "(" ++ categoryCreator t ++ "(), Params<" ++ show n ++ ">::Type()));", - " return cached;", - "}" - ] - | otherwise = - return $ onlyCodes [ - "S<" ++ typeName t ++ "> " ++ typeCreator t ++ "(Params<" ++ show n ++ ">::Type params) {", - " static auto& cache = *new WeakInstanceMap<" ++ show n ++ ", " ++ typeName t ++ ">();", - " static auto& cache_mutex = *new std::mutex;", - " std::lock_guard lock(cache_mutex);", - " auto& cached = cache[GetKeyFromParams<" ++ show n ++ ">(params)];", - " S<" ++ typeName t ++ "> type = cached;", - " if (!type) { cached = type = S_get(new " ++ typeName t ++ "(" ++ categoryCreator t ++ "(), params)); }", - " return type;", - "}" - ] - -declareInternalValue :: Monad m => - CategoryName -> Int -> Int -> m (CompiledData [String]) -declareInternalValue t _ _ = - return $ onlyCodes [ - "S " ++ valueCreator t ++ - "(S<" ++ typeName t ++ "> parent, " ++ - "const ParamTuple& params, const ValueTuple& args);" - ] - -defineInternalValue :: Monad m => - CategoryName -> Int -> Int -> m (CompiledData [String]) -defineInternalValue t _ _ = - return $ onlyCodes [ - "S " ++ valueCreator t ++ "(S<" ++ typeName t ++ "> parent, " ++ - "const ParamTuple& params, const ValueTuple& args) {", - " return S_get(new " ++ valueName t ++ "(parent, params, args));", - "}" - ] - -createMainCommon :: String -> CompiledData [String] -> CompiledData [String] -> [String] -createMainCommon n (CompiledData req0 out0) (CompiledData req1 out1) = - baseSourceIncludes ++ mainSourceIncludes ++ depIncludes (req0 `Set.union` req1) ++ out0 ++ [ - "int main(int argc, const char** argv) {", - " SetSignalHandler();", - " " ++ startFunctionTracing CategoryNone (FunctionName n) - ] ++ map (" " ++) out1 ++ ["}"] where - depIncludes req2 = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $ - Set.toList req2 - -createMainFile :: (Ord c, Show c, CollectErrorsM m) => - CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) -createMainFile tm em n f = "In the creation of the main binary procedure" ??> do - ca <- compileMainProcedure tm em expr - let file = noTestsOnlySourceGuard ++ createMainCommon "main" emptyCode (argv <> ca) - (_,t) <- getConcreteCategory tm ([],n) - return (getCategoryNamespace t,file) where - funcCall = FunctionCall [] f (Positional []) (Positional []) - mainType = JustTypeInstance $ TypeInstance n (Positional []) - expr = Expression [] (TypeCall [] mainType funcCall) [] - argv = onlyCode "ProgramArgv program_argv(argc, argv);" - -createTestFile :: (Ord c, Show c, CollectErrorsM m) => - CategoryMap c -> ExprMap c -> [String] -> [TestProcedure c] -> m (CompiledData [String]) -createTestFile tm em args ts = "In the creation of the test binary procedure" ??> do - ts' <- fmap mconcat $ mapErrorsM (compileTestProcedure tm em) ts - (include,sel) <- selectTestFromArgv1 $ map tpName ts - let (CompiledData req _) = ts' <> sel - let file = testsOnlySourceGuard ++ createMainCommon "testcase" (onlyCodes include <> ts') (argv <> sel) - return $ CompiledData req file where - args' = map escapeChars args - argv = onlyCodes [ - "const char* argv2[] = { \"testcase\" " ++ concat (map (", " ++) args') ++ " };", - "ProgramArgv program_argv(sizeof argv2 / sizeof(char*), argv2);" - ] - -getCategoryMentions :: AnyCategory c -> [CategoryName] -getCategoryMentions t = fromRefines (getCategoryRefines t) ++ - fromDefines (getCategoryDefines t) ++ - fromFunctions (getCategoryFunctions t) ++ - fromFilters (getCategoryFilters t) where - fromRefines rs = Set.toList $ Set.unions $ map (categoriesFromRefine . vrType) rs - fromDefines ds = Set.toList $ Set.unions $ map (categoriesFromDefine . vdType) ds - fromDefine (DefinesInstance d ps) = d:(fromGenerals $ pValues ps) - fromFunctions fs = concat $ map fromFunction fs - fromFunction (ScopedFunction _ _ t2 _ as rs _ fs _) = - [t2] ++ (fromGenerals $ map (vtType . pvType) (pValues as ++ pValues rs)) ++ fromFilters fs - fromFilters fs = concat $ map (fromFilter . pfFilter) fs - fromFilter (TypeFilter _ t2) = Set.toList $ categoriesFromTypes t2 - fromFilter (DefinesFilter t2) = fromDefine t2 - fromGenerals = Set.toList . Set.unions . map categoriesFromTypes diff --git a/src/CompilerCxx/CategoryContext.hs b/src/CompilerCxx/CategoryContext.hs --- a/src/CompilerCxx/CategoryContext.hs +++ b/src/CompilerCxx/CategoryContext.hs @@ -59,32 +59,32 @@ let builtin = Map.filter ((== LocalScope) . vvScope) $ builtinVariables typeInstance members <- mapMembers $ filter ((<= s) . dmScope) (dcMembers d) return $ ProcedureContext { - pcScope = s, - pcType = getCategoryName t, - pcExtParams = ps, - pcIntParams = Positional [], - pcMembers = ms, - pcCategories = tm, - pcAllFilters = fm, - pcExtFilters = pa, - pcIntFilters = [], - pcParamScopes = sa, - pcFunctions = fa, - pcVariables = Map.union builtin members, - pcReturns = ValidatePositions (Positional []), - pcJumpType = NextStatement, - pcIsNamed = False, - pcPrimNamed = [], - pcRequiredTypes = Set.empty, - pcOutput = [], - pcDisallowInit = True, - pcLoopSetup = NotInLoop, - pcCleanupBlocks = [], - pcInCleanup = False, - pcUsedVars = [], - pcExprMap = em, - pcReservedMacros = [], - pcNoTrace = False + _pcScope = s, + _pcType = getCategoryName t, + _pcExtParams = ps, + _pcIntParams = Positional [], + _pcMembers = ms, + _pcCategories = tm, + _pcAllFilters = fm, + _pcExtFilters = pa, + _pcIntFilters = [], + _pcParamScopes = sa, + _pcFunctions = fa, + _pcVariables = Map.union builtin members, + _pcReturns = ValidatePositions (Positional []), + _pcJumpType = NextStatement, + _pcIsNamed = False, + _pcPrimNamed = [], + _pcRequiredTypes = Set.empty, + _pcOutput = [], + _pcDisallowInit = True, + _pcLoopSetup = NotInLoop, + _pcCleanupBlocks = [], + _pcInCleanup = False, + _pcUsedVars = [], + _pcExprMap = em, + _pcReservedMacros = [], + _pcNoTrace = False } getProcedureContext :: (Show c, CollectErrorsM m) => @@ -121,63 +121,63 @@ else zipWith3 ReturnVariable [0..] (map ovName $ pValues $ nrNames rs2) (map pvType $ pValues rs1) let ns = filter (isPrimType . rvType) ns0 return $ ProcedureContext { - pcScope = s, - pcType = t, - pcExtParams = ps, - pcIntParams = pi, - pcMembers = ms, - pcCategories = tm, - pcAllFilters = allFilters, - pcExtFilters = pa', + _pcScope = s, + _pcType = t, + _pcExtParams = ps, + _pcIntParams = pi, + _pcMembers = ms, + _pcCategories = tm, + _pcAllFilters = allFilters, + _pcExtFilters = pa', -- fs is duplicated so value initialization checks work properly. - pcIntFilters = fi ++ fs, - pcParamScopes = sa, - pcFunctions = fa, - pcVariables = va'', - pcReturns = rs', - pcJumpType = NextStatement, - pcIsNamed = not (isUnnamedReturns rs2), - pcPrimNamed = ns, - pcRequiredTypes = Set.empty, - pcOutput = [], - pcDisallowInit = False, - pcLoopSetup = NotInLoop, - pcCleanupBlocks = [], - pcInCleanup = False, - pcUsedVars = [], - pcExprMap = em, - pcReservedMacros = [], - pcNoTrace = False + _pcIntFilters = fi ++ fs, + _pcParamScopes = sa, + _pcFunctions = fa, + _pcVariables = va'', + _pcReturns = rs', + _pcJumpType = NextStatement, + _pcIsNamed = not (isUnnamedReturns rs2), + _pcPrimNamed = ns, + _pcRequiredTypes = Set.empty, + _pcOutput = [], + _pcDisallowInit = False, + _pcLoopSetup = NotInLoop, + _pcCleanupBlocks = [], + _pcInCleanup = False, + _pcUsedVars = [], + _pcExprMap = em, + _pcReservedMacros = [], + _pcNoTrace = False } where pairOutput (PassedValue c1 t2) (OutputValue c2 n2) = return $ (n2,PassedValue (c2++c1) t2) getMainContext :: CollectErrorsM m => CategoryMap c -> ExprMap c -> m (ProcedureContext c) getMainContext tm em = return $ ProcedureContext { - pcScope = LocalScope, - pcType = CategoryNone, - pcExtParams = Positional [], - pcIntParams = Positional [], - pcMembers = [], - pcCategories = tm, - pcAllFilters = Map.empty, - pcExtFilters = [], - pcIntFilters = [], - pcParamScopes = Map.empty, - pcFunctions = Map.empty, - pcVariables = Map.empty, - pcReturns = ValidatePositions (Positional []), - pcJumpType = NextStatement, - pcIsNamed = False, - pcPrimNamed = [], - pcRequiredTypes = Set.empty, - pcOutput = [], - pcDisallowInit = False, - pcLoopSetup = NotInLoop, - pcCleanupBlocks = [], - pcInCleanup = False, - pcUsedVars = [], - pcExprMap = em, - pcReservedMacros = [], - pcNoTrace = False + _pcScope = LocalScope, + _pcType = CategoryNone, + _pcExtParams = Positional [], + _pcIntParams = Positional [], + _pcMembers = [], + _pcCategories = tm, + _pcAllFilters = Map.empty, + _pcExtFilters = [], + _pcIntFilters = [], + _pcParamScopes = Map.empty, + _pcFunctions = Map.empty, + _pcVariables = Map.empty, + _pcReturns = ValidatePositions (Positional []), + _pcJumpType = NextStatement, + _pcIsNamed = False, + _pcPrimNamed = [], + _pcRequiredTypes = Set.empty, + _pcOutput = [], + _pcDisallowInit = False, + _pcLoopSetup = NotInLoop, + _pcCleanupBlocks = [], + _pcInCleanup = False, + _pcUsedVars = [], + _pcExprMap = em, + _pcReservedMacros = [], + _pcNoTrace = False } diff --git a/src/CompilerCxx/CxxFiles.hs b/src/CompilerCxx/CxxFiles.hs new file mode 100644 --- /dev/null +++ b/src/CompilerCxx/CxxFiles.hs @@ -0,0 +1,904 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +module CompilerCxx.CxxFiles ( + CxxOutput(..), + FileContext(..), + generateMainFile, + generateNativeConcrete, + generateNativeInterface, + generateStreamlinedExtension, + generateStreamlinedTemplate, + generateTestFile, + generateVerboseExtension, +) where + +import Data.List (intercalate,sortBy) +import Prelude hiding (pi) +import qualified Data.Map as Map +import qualified Data.Set as Set + +#if MIN_VERSION_base(4,11,0) +#else +import Data.Semigroup +#endif + +import Base.CompilerError +import Base.GeneralType +import Base.MergeTree +import Base.Positional +import Compilation.CompilerState +import Compilation.ProcedureContext (ExprMap) +import Compilation.ScopeContext +import CompilerCxx.CategoryContext +import CompilerCxx.Code +import CompilerCxx.Naming +import CompilerCxx.Procedure +import Types.Builtin +import Types.DefinedCategory +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance +import Types.Variance + + +data CxxOutput = + CxxOutput { + coCategory :: Maybe CategoryName, + coFilename :: String, + coNamespace :: Namespace, + coUsesNamespace :: Set.Set Namespace, + coUsesCategory :: Set.Set CategoryName, + coOutput :: [String] + } + deriving (Show) + +data FileContext c = + FileContext { + fcTesting :: Bool, + fcCategories :: CategoryMap c, + fcNamespaces :: Set.Set Namespace, + fcExprMap :: ExprMap c + } + +generateNativeConcrete :: (Ord c, Show c, CollectErrorsM m) => + FileContext c -> (AnyCategory c,DefinedCategory c) -> m [CxxOutput] +generateNativeConcrete (FileContext testing tm ns em) (t,d) = do + dec <- compileCategoryDeclaration testing ns t + def <- generateCategoryDefinition testing (NativeConcrete t d tm ns em) + return (dec:def) + +generateNativeInterface :: (Ord c, Show c, CollectErrorsM m) => + Bool -> AnyCategory c -> m [CxxOutput] +generateNativeInterface testing t = do + dec <- compileCategoryDeclaration testing Set.empty t + def <- generateCategoryDefinition testing (NativeInterface t) + return (dec:def) + +generateStreamlinedExtension :: (Ord c, Show c, CollectErrorsM m) => + Bool -> AnyCategory c -> m [CxxOutput] +generateStreamlinedExtension testing t = do + dec <- compileCategoryDeclaration testing Set.empty t + def <- generateCategoryDefinition testing (StreamlinedExtension t) + return (dec:def) + +generateVerboseExtension :: (Ord c, Show c, CollectErrorsM m) => + Bool -> AnyCategory c -> m [CxxOutput] +generateVerboseExtension testing t = + fmap (:[]) $ compileCategoryDeclaration testing Set.empty t + +generateStreamlinedTemplate :: (Ord c, Show c, CollectErrorsM m) => + FileContext c -> AnyCategory c -> m [CxxOutput] +generateStreamlinedTemplate (FileContext testing tm _ _) t = + generateCategoryDefinition testing (StreamlinedTemplate t tm) + +compileCategoryDeclaration :: (Ord c, Show c, CollectErrorsM m) => + Bool -> Set.Set Namespace -> AnyCategory c -> m CxxOutput +compileCategoryDeclaration testing ns t = + return $ CxxOutput (Just $ getCategoryName t) + (headerFilename name) + (getCategoryNamespace t) + (getCategoryNamespace t `Set.insert` ns) + (cdRequired file) + (cdOutput file) where + file = mconcat $ [ + CompiledData depends [], + onlyCodes guardTop, + onlyCodes $ (if testing then testsOnlyCategoryGuard (getCategoryName t) else []), + onlyCodes baseHeaderIncludes, + addNamespace t content, + onlyCodes guardBottom + ] + depends = getCategoryDeps t + content = mconcat [collection,labels,getCategory2,getType] + name = getCategoryName t + guardTop = ["#ifndef " ++ guardName,"#define " ++ guardName] + guardBottom = ["#endif // " ++ guardName] + guardName = "HEADER_" ++ guardNamespace ++ show name + guardNamespace + | isStaticNamespace $ getCategoryNamespace t = show (getCategoryNamespace t) ++ "_" + | otherwise = "" + labels = onlyCodes $ map label $ filter ((== name) . sfType) $ getCategoryFunctions t + label f = "extern " ++ functionLabelType f ++ " " ++ functionName f ++ ";" + collection + | isValueConcrete t = emptyCode + | otherwise = onlyCodes ["extern const void* const " ++ collectionName name ++ ";"] + getCategory2 + | isInstanceInterface t = emptyCode + | otherwise = declareGetCategory t + getType + | isInstanceInterface t = emptyCode + | otherwise = declareGetType t + +data CategoryDefinition c = + NativeInterface { + niCategory :: AnyCategory c + } | + NativeConcrete { + ncCategory :: AnyCategory c, + ncDefined :: DefinedCategory c, + ncCategories :: CategoryMap c, + ncNamespaces :: Set.Set Namespace, + ncExprMap :: ExprMap c + } | + StreamlinedExtension { + seCategory :: AnyCategory c + } | + StreamlinedTemplate { + stCategory :: AnyCategory c, + stCategories :: CategoryMap c + } + +generateCategoryDefinition :: (Ord c, Show c, CollectErrorsM m) => + Bool -> CategoryDefinition c -> m [CxxOutput] +generateCategoryDefinition testing = common where + common :: (Ord c, Show c, CollectErrorsM m) => CategoryDefinition c -> m [CxxOutput] + common (NativeInterface t) = fmap (:[]) singleSource where + singleSource = do + let filename = sourceFilename (getCategoryName t) + let (cf,tf,vf) = partitionByScope sfScope $ getCategoryFunctions t + (CompiledData req out) <- fmap (addNamespace t) $ concatM [ + defineFunctions t cf tf vf, + declareInternalGetters t, + defineInterfaceCategory t, + defineInterfaceType t, + defineCategoryOverrides t [], + defineTypeOverrides t [], + defineInternalGetters t, + defineExternalGetters t + ] + let req' = req `Set.union` getCategoryMentions t + return $ CxxOutput (Just $ getCategoryName t) + filename + (getCategoryNamespace t) + (Set.fromList [getCategoryNamespace t]) + req' + (allowTestsOnly $ addSourceIncludes $ addCategoryHeader t $ addIncludes req' out) + common (StreamlinedExtension t) = sequence [streamlinedHeader,streamlinedSource] where + streamlinedHeader = do + let filename = headerStreamlined (getCategoryName t) + (CompiledData req out) <- fmap (addNamespace t) $ concatM [ + defineAbstractCategory t, + defineAbstractType t, + defineAbstractValue t defined, + declareAbstractGetters t + ] + return $ CxxOutput (Just $ getCategoryName t) + filename + (getCategoryNamespace t) + (Set.fromList [getCategoryNamespace t]) + req + (headerGuard (getCategoryName t) $ allowTestsOnly $ addSourceIncludes $ addCategoryHeader t $ addIncludes req out) + defined = DefinedCategory { + dcContext = [], + dcName = getCategoryName t, + dcParams = [], + dcRefines = [], + dcDefines = [], + dcParamFilter = [], + dcMembers = [], + dcProcedures = [], + dcFunctions = [] + } + streamlinedSource = do + let filename = sourceStreamlined (getCategoryName t) + let (cf,tf,vf) = partitionByScope sfScope $ getCategoryFunctions t + (CompiledData req out) <- fmap (addNamespace t) $ concatM [ + defineFunctions t cf tf vf, + defineCategoryOverrides t (getCategoryFunctions t), + defineTypeOverrides t (getCategoryFunctions t), + defineValueOverrides t (getCategoryFunctions t), + defineExternalGetters t + ] + let req' = Set.unions [req,getCategoryMentions t,defaultCategoryDeps] + return $ CxxOutput (Just $ getCategoryName t) + filename + (getCategoryNamespace t) + (Set.fromList [getCategoryNamespace t]) + req' + (addSourceIncludes $ addStreamlinedHeader t $ addIncludes req' out) + common (StreamlinedTemplate t tm) = fmap (:[]) streamlinedTemplate where + streamlinedTemplate = do + let filename = templateStreamlined (getCategoryName t) + [cp,tp,vp] <- getProcedureScopes tm Map.empty defined + (CompiledData req out) <- fmap (addNamespace t) $ concatM [ + declareCustomValueGetter t, + defineCustomCategory t cp, + defineCustomType t tp, + defineCustomValue t vp, + defineCustomGetters t, + defineCustomValueGetter t + ] + return $ CxxOutput (Just $ getCategoryName t) + filename + (getCategoryNamespace t) + (Set.fromList [getCategoryNamespace t]) + req + (addSourceIncludes $ addStreamlinedHeader t $ addIncludes req out) + defined = DefinedCategory { + dcContext = [], + dcName = getCategoryName t, + dcParams = [], + dcRefines = [], + dcDefines = [], + dcParamFilter = [], + dcMembers = [], + dcProcedures = map defaultFail (getCategoryFunctions t), + dcFunctions = [] + } + defaultFail f = ExecutableProcedure { + epContext = [], + epPragmas = [], + epEnd = [], + epName = sfName f, + epArgs = ArgValues [] $ Positional $ map createArg [1..(length $ pValues $ sfArgs f)], + epReturns = UnnamedReturns [], + epProcedure = failProcedure f + } + createArg = InputValue [] . VariableName . ("arg" ++) . show + failProcedure f = Procedure [] [ + NoValueExpression [] $ LineComment $ "TODO: Implement " ++ funcName f ++ ".", + FailCall [] (Literal (StringLiteral [] $ funcName f ++ " is not implemented")) + ] + funcName f = show (sfType f) ++ "." ++ show (sfName f) + common (NativeConcrete t d@(DefinedCategory _ _ pi _ _ fi ms _ _) ta ns em) = fmap (:[]) singleSource where + singleSource = do + let filename = sourceFilename (getCategoryName t) + ta' <- mergeInternalInheritance ta d + let r = CategoryResolver ta' + [cp,tp,vp] <- getProcedureScopes ta' em d + let (_,tm,_) = partitionByScope dmScope ms + disallowTypeMembers tm + let filters = getCategoryFilters t + let filters2 = fi + allFilters <- getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2 + let cf = map fst $ psProcedures cp + let tf = map fst $ psProcedures tp + let vf = map fst $ psProcedures vp + (CompiledData req out) <- fmap (addNamespace t) $ concatM [ + defineFunctions t cf tf vf, + declareInternalGetters t, + defineConcreteCategory r allFilters cf ta' em t d, + defineConcreteType tf t, + defineConcreteValue r allFilters vf t d, + defineCategoryOverrides t cf, + defineTypeOverrides t tf, + defineValueOverrides t vf, + defineCategoryFunctions t cp, + defineTypeFunctions t tp, + defineValueFunctions t vp, + defineInternalGetters t, + defineExternalGetters t + ] + let req' = req `Set.union` getCategoryMentions t + return $ CxxOutput (Just $ getCategoryName t) + filename + (getCategoryNamespace t) + (getCategoryNamespace t `Set.insert` ns) + req' + (allowTestsOnly $ addSourceIncludes $ addCategoryHeader t $ addIncludes req' out) + + defineFunctions t cf tf vf = concatM [createCollection,createAllLabels] where + name = getCategoryName t + createCollection = return $ onlyCodes [ + "namespace {", + "const int " ++ collectionValName ++ " = 0;", + "} // namespace", + "const void* const " ++ collectionName name ++ " = &" ++ collectionValName ++ ";" + ] + createAllLabels = return $ onlyCodes $ concat $ map createLabels [cf,tf,vf] + collectionValName = "collection_" ++ show name + createLabels = map (uncurry createLabelForFunction) . zip [0..] . sortBy compareName . filter ((== name) . sfType) + compareName x y = sfName x `compare` sfName y + + declareInternalGetters t = concatM [ + return $ onlyCode $ "struct " ++ categoryName (getCategoryName t) ++ ";", + return $ declareInternalCategory t, + return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ ";", + return $ declareInternalType t (length $ getCategoryParams t), + return $ valueGetter + ] where + valueGetter + | isValueConcrete t = mconcat [ + onlyCode $ "struct " ++ valueName (getCategoryName t) ++ ";", + declareInternalValue t + ] + | otherwise = emptyCode + defineInternalGetters t = concatM [ + return $ defineInternalCategory t, + return $ defineInternalType t (length $ getCategoryParams t), + return $ valueGetter + ] where + valueGetter + | isValueConcrete t = defineInternalValue t + | otherwise = emptyCode + + declareCustomValueGetter t = concatM [ + return $ declareInternalValue t + ] + defineCustomValueGetter t = concatM [ + return $ defineInternalValue2 (valueCustom $ getCategoryName t) t + ] + + declareAbstractGetters t = concatM [ + return $ onlyCode $ "struct " ++ categoryName (getCategoryName t) ++ ";", + return $ declareInternalCategory t, + return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ ";", + return $ declareInternalType t (length $ getCategoryParams t) + ] + + defineExternalGetters t = concatM [ + return $ defineGetCatetory t, + return $ defineGetType t + ] + defineCustomGetters t = concatM [ + return $ defineInternalCategory2 (categoryCustom (getCategoryName t)) t, + return $ defineInternalType2 (typeCustom (getCategoryName t)) t (length $ getCategoryParams t) + ] + + defineInterfaceCategory t = concatM [ + return $ onlyCode $ "struct " ++ categoryName (getCategoryName t) ++ " : public " ++ categoryBase ++ " {", + return declareCategoryOverrides, + return $ onlyCode "};" + ] + defineInterfaceType t = concatM [ + return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", + fmap indentCompiled $ inlineTypeConstructor t, + return declareTypeOverrides, + return $ indentCompiled $ createParams $ getCategoryParams t, + return $ onlyCode $ " " ++ categoryName (getCategoryName t) ++ "& parent;", + return $ onlyCode "};" + ] + + defineConcreteCategory r allFilters fs tm em t d = concatM [ + return $ onlyCode $ "struct " ++ categoryName (getCategoryName t) ++ " : public " ++ categoryBase ++ " {", + fmap indentCompiled $ inlineCategoryConstructor t d tm em, + return declareCategoryOverrides, + fmap indentCompiled $ concatM $ map (procedureDeclaration False) fs, + fmap indentCompiled $ concatM $ map (createMemberLazy r allFilters) members, + return $ onlyCode "};" + ] where + members = filter ((== CategoryScope). dmScope) $ dcMembers d + defineConcreteType fs t = concatM [ + return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", + fmap indentCompiled $ inlineTypeConstructor t, + return declareTypeOverrides, + fmap indentCompiled $ concatM $ map (procedureDeclaration False) fs, + return $ indentCompiled $ createParams $ getCategoryParams t, + return $ onlyCode $ " " ++ categoryName (getCategoryName t) ++ "& parent;", + return $ onlyCode "};" + ] + defineConcreteValue r allFilters fs t d = concatM [ + return $ onlyCode $ "struct " ++ valueName (getCategoryName t) ++ " : public " ++ valueBase ++ " {", + fmap indentCompiled $ inlineValueConstructor t d, + return declareValueOverrides, + fmap indentCompiled $ concatM $ map (procedureDeclaration False) fs, + fmap indentCompiled $ concatM $ map (createMember r allFilters) members, + return $ indentCompiled $ createParams $ dcParams d, + return $ onlyCode $ " const S<" ++ typeName (getCategoryName t) ++ "> parent;", + return $ onlyCodes traceCreation, + return $ onlyCode "};" + ] where + members = filter ((== ValueScope). dmScope) $ dcMembers d + procedures = dcProcedures d + traceCreation + | any isTraceCreation $ concat $ map epPragmas procedures = [captureCreationTrace] + | otherwise = [] + + defineAbstractCategory t = concatM [ + return $ onlyCode $ "struct " ++ categoryName (getCategoryName t) ++ " : public " ++ categoryBase ++ " {", + return declareCategoryOverrides, + fmap indentCompiled $ concatM $ map (procedureDeclaration True) $ filter ((== CategoryScope). sfScope) $ getCategoryFunctions t, + return $ onlyCode $ " virtual inline ~" ++ categoryName (getCategoryName t) ++ "() {}", + return $ onlyCode "};" + ] + defineAbstractType t = concatM [ + return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {", + fmap indentCompiled $ inlineTypeConstructor t, + return declareTypeOverrides, + fmap indentCompiled $ concatM $ map (procedureDeclaration True) $ filter ((== TypeScope). sfScope) $ getCategoryFunctions t, + return $ onlyCode $ " virtual inline ~" ++ typeName (getCategoryName t) ++ "() {}", + return $ indentCompiled $ createParams $ getCategoryParams t, + return $ onlyCode $ " " ++ categoryName (getCategoryName t) ++ "& parent;", + return $ onlyCode "};" + ] + defineAbstractValue t d = concatM [ + return $ onlyCode $ "struct " ++ valueName (getCategoryName t) ++ " : public " ++ valueBase ++ " {", + fmap indentCompiled $ abstractValueConstructor t d, + return declareValueOverrides, + fmap indentCompiled $ concatM $ map (procedureDeclaration True) $ filter ((== ValueScope). sfScope) $ getCategoryFunctions t, + return $ onlyCode $ " virtual inline ~" ++ valueName (getCategoryName t) ++ "() {}", + return $ onlyCode $ " const S<" ++ typeName (getCategoryName t) ++ "> parent;", + return $ onlyCode "};" + ] + + defineCustomCategory :: (Ord c, Show c, CollectErrorsM m) => AnyCategory c -> ProcedureScope c -> m (CompiledData [String]) + defineCustomCategory t ps = concatM [ + return $ onlyCode $ "struct " ++ categoryCustom (getCategoryName t) ++ " : public " ++ categoryName (getCategoryName t) ++ " {", + fmap indentCompiled $ concatM $ applyProcedureScope (compileExecutableProcedure Nothing) ps, + return $ onlyCode "};" + ] + defineCustomType :: (Ord c, Show c, CollectErrorsM m) => AnyCategory c -> ProcedureScope c -> m (CompiledData [String]) + defineCustomType t ps = concatM [ + return $ onlyCode $ "struct " ++ typeCustom (getCategoryName t) ++ " : public " ++ typeName (getCategoryName t) ++ " {", + fmap indentCompiled $ customTypeConstructor t, + fmap indentCompiled $ concatM $ applyProcedureScope (compileExecutableProcedure Nothing) ps, + return $ onlyCode "};" + ] + defineCustomValue :: (Ord c, Show c, CollectErrorsM m) => AnyCategory c -> ProcedureScope c -> m (CompiledData [String]) + defineCustomValue t ps = concatM [ + return $ onlyCode $ "struct " ++ valueCustom (getCategoryName t) ++ " : public " ++ valueName (getCategoryName t) ++ " {", + fmap indentCompiled $ customValueConstructor t, + fmap indentCompiled $ concatM $ applyProcedureScope (compileExecutableProcedure Nothing) ps, + return $ onlyCode "};" + ] + + defineCategoryFunctions :: (Ord c, Show c, CollectErrorsM m) => AnyCategory c -> ProcedureScope c -> m (CompiledData [String]) + defineCategoryFunctions t = concatM . applyProcedureScope (compileExecutableProcedure $ Just $ categoryName $ getCategoryName t) + defineTypeFunctions :: (Ord c, Show c, CollectErrorsM m) => AnyCategory c -> ProcedureScope c -> m (CompiledData [String]) + defineTypeFunctions t = concatM . applyProcedureScope (compileExecutableProcedure $ Just $ typeName $ getCategoryName t) + defineValueFunctions :: (Ord c, Show c, CollectErrorsM m) => AnyCategory c -> ProcedureScope c -> m (CompiledData [String]) + defineValueFunctions t = concatM . applyProcedureScope (compileExecutableProcedure $ Just $ valueName $ getCategoryName t) + + declareCategoryOverrides = onlyCodes [ + " std::string CategoryName() const final;", + " ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final;" + ] + declareTypeOverrides = onlyCodes [ + " std::string CategoryName() const final;", + " void BuildTypeName(std::ostream& output) const final;", + " bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final;", + " ReturnTuple Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) final;", + " bool CanConvertFrom(const S& from) const final;" + ] + declareValueOverrides = onlyCodes [ + " std::string CategoryName() const final;", + " ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params, const ValueTuple& args) final;" + ] + + defineCategoryOverrides t fs = return $ mconcat [ + onlyCode $ "std::string " ++ className ++ "::CategoryName() const { return \"" ++ show (getCategoryName t) ++ "\"; }", + onlyCode $ "ReturnTuple " ++ className ++ "::Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) {", + createFunctionDispatch (getCategoryName t) CategoryScope fs, + onlyCode "}" + ] where + className = categoryName (getCategoryName t) + defineTypeOverrides t fs = return $ mconcat [ + onlyCode $ "std::string " ++ className ++ "::CategoryName() const { return parent.CategoryName(); }", + onlyCode $ "void " ++ className ++ "::BuildTypeName(std::ostream& output) const {", + defineTypeName params, + onlyCode "}", + onlyCode $ "bool " ++ className ++ "::TypeArgsForParent(const TypeCategory& category, std::vector>& args) const {", + createTypeArgsForParent t, + onlyCode $ "}", + onlyCode $ "ReturnTuple " ++ className ++ "::Dispatch(const S& self, const TypeFunction& label, const ParamTuple& params, const ValueTuple& args) {", + createFunctionDispatch (getCategoryName t) TypeScope fs, + onlyCode $ "}", + onlyCode $ "bool " ++ className ++ "::CanConvertFrom(const S& from) const {", + createCanConvertFrom t, + onlyCode "}" + ] where + className = typeName (getCategoryName t) + params = map vpParam $ getCategoryParams t + defineValueOverrides t fs = return $ mconcat [ + onlyCode $ "std::string " ++ className ++ "::CategoryName() const { return parent->CategoryName(); }", + onlyCode $ "ReturnTuple " ++ className ++ "::Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params, const ValueTuple& args) {", + createFunctionDispatch (getCategoryName t) ValueScope fs, + onlyCode $ "}" + ] where + className = valueName (getCategoryName t) + + createMember r filters m = do + validateGeneralInstance r filters (vtType $ dmType m) ::Type params" + let allArgs = intercalate ", " [argParent,paramsPassed] + let initParent = "parent(p)" + let initPassed = map (\(i,p) -> paramName p ++ "(std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps2 + let allInit = intercalate ", " $ initParent:initPassed + return $ mconcat [ + onlyCode $ "inline " ++ typeName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {", + indentCompiled $ onlyCodes $ getCycleCheck (typeName (getCategoryName t)), + indentCompiled $ onlyCode $ startInitTracing (getCategoryName t) TypeScope, + onlyCode "}" + ] + inlineValueConstructor t d = do + let argParent = "S<" ++ typeName (getCategoryName t) ++ "> p" + let paramsPassed = "const ParamTuple& params" + let argsPassed = "const ValueTuple& args" + let allArgs = intercalate ", " [argParent,paramsPassed,argsPassed] + let initParent = "parent(p)" + let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(params.At(" ++ show i ++ "))") $ zip ([0..] :: [Int]) $ dcParams d + let initArgs = map (\(i,m) -> variableName (dmName m) ++ "(" ++ unwrappedArg i m ++ ")") $ zip ([0..] :: [Int]) members + let allInit = intercalate ", " $ initParent:(initParams ++ initArgs) + return $ onlyCode $ "inline " ++ valueName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" where + unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") + members = filter ((== ValueScope). dmScope) $ dcMembers d + + abstractValueConstructor t d = do + let argParent = "S<" ++ typeName (getCategoryName t) ++ "> p" + let paramsPassed = "const ParamTuple& params" + let allArgs = intercalate ", " [argParent,paramsPassed] + let initParent = "parent(p)" + let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(params.At(" ++ show i ++ "))") $ zip ([0..] :: [Int]) $ dcParams d + let allInit = intercalate ", " $ initParent:initParams + return $ onlyCode $ "inline " ++ valueName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" + + customTypeConstructor t = do + let ps2 = map vpParam $ getCategoryParams t + let argParent = categoryName (getCategoryName t) ++ "& p" + let paramsPassed = "Params<" ++ show (length ps2) ++ ">::Type params" + let allArgs = intercalate ", " [argParent,paramsPassed] + let allInit = typeName (getCategoryName t) ++ "(p, params)" + return $ onlyCode $ "inline " ++ typeCustom (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" + customValueConstructor t = do + let argParent = "S<" ++ typeName (getCategoryName t) ++ "> p" + let paramsPassed = "const ParamTuple& params" + let argsPassed = "const ValueTuple& args" + let allArgs = intercalate ", " [argParent,paramsPassed,argsPassed] + let allInit = valueName (getCategoryName t) ++ "(p, params)" + return $ onlyCode $ "inline " ++ valueCustom (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" + + allowTestsOnly + | testing = (testsOnlySourceGuard ++) + | otherwise = (noTestsOnlySourceGuard ++) + addSourceIncludes = (baseSourceIncludes ++) + addCategoryHeader t = (["#include \"" ++ headerFilename (getCategoryName t) ++ "\""] ++) + addStreamlinedHeader t = (["#include \"" ++ headerStreamlined (getCategoryName t) ++ "\""] ++) + addIncludes req = (map (\i -> "#include \"" ++ headerFilename i ++ "\"") (Set.toList req) ++) + headerGuard t out = guardTop ++ out ++ guardBottom where + guardTop = ["#ifndef " ++ guardName,"#define " ++ guardName] + guardBottom = ["#endif // " ++ guardName] + guardName = "STREAMLINED_" ++ show t + disallowTypeMembers :: (Ord c, Show c, CollectErrorsM m) => [DefinedMember c] -> m () + disallowTypeMembers tm = + collectAllM_ $ flip map tm + (\m -> compilerErrorM $ "Member " ++ show (dmName m) ++ + " is not allowed to be @type-scoped" ++ + formatFullContextBrace (dmContext m)) + getCycleCheck n2 = [ + "CycleCheck<" ++ n2 ++ ">::Check();", + "CycleCheck<" ++ n2 ++ "> marker(*this);" + ] + +createMainCommon :: String -> CompiledData [String] -> CompiledData [String] -> [String] +createMainCommon n (CompiledData req0 out0) (CompiledData req1 out1) = + baseSourceIncludes ++ mainSourceIncludes ++ depIncludes (req0 `Set.union` req1) ++ out0 ++ [ + "int main(int argc, const char** argv) {", + " SetSignalHandler();", + " " ++ startFunctionTracing CategoryNone (FunctionName n) + ] ++ map (" " ++) out1 ++ ["}"] where + depIncludes req2 = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $ + Set.toList req2 + +generateMainFile :: (Ord c, Show c, CollectErrorsM m) => + CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) +generateMainFile tm em n f = "In the creation of the main binary procedure" ??> do + ca <- compileMainProcedure tm em expr + let file = noTestsOnlySourceGuard ++ createMainCommon "main" emptyCode (argv <> ca) + (_,t) <- getConcreteCategory tm ([],n) + return (getCategoryNamespace t,file) where + funcCall = FunctionCall [] f (Positional []) (Positional []) + mainType = JustTypeInstance $ TypeInstance n (Positional []) + expr = Expression [] (TypeCall [] mainType funcCall) [] + argv = onlyCode "ProgramArgv program_argv(argc, argv);" + +generateTestFile :: (Ord c, Show c, CollectErrorsM m) => + CategoryMap c -> ExprMap c -> [String] -> [TestProcedure c] -> m (CompiledData [String]) +generateTestFile tm em args ts = "In the creation of the test binary procedure" ??> do + ts' <- fmap mconcat $ mapErrorsM (compileTestProcedure tm em) ts + (include,sel) <- selectTestFromArgv1 $ map tpName ts + let (CompiledData req _) = ts' <> sel + let file = testsOnlySourceGuard ++ createMainCommon "testcase" (onlyCodes include <> ts') (argv <> sel) + return $ CompiledData req file where + args' = map escapeChars args + argv = onlyCodes [ + "const char* argv2[] = { \"testcase\" " ++ concat (map (", " ++) args') ++ " };", + "ProgramArgv program_argv(sizeof argv2 / sizeof(char*), argv2);" + ] + +addNamespace :: AnyCategory c -> CompiledData [String] -> CompiledData [String] +addNamespace t cs + | isStaticNamespace $ getCategoryNamespace t = mconcat [ + onlyCode $ "namespace " ++ show (getCategoryNamespace t) ++ " {", + cs, + onlyCode $ "} // namespace " ++ show (getCategoryNamespace t), + onlyCode $ "using namespace " ++ show (getCategoryNamespace t) ++ ";" + ] + | isPublicNamespace $ getCategoryNamespace t = mconcat [ + onlyCode $ "#ifdef " ++ publicNamespaceMacro, + onlyCode $ "namespace " ++ publicNamespaceMacro ++ " {", + onlyCode $ "#endif // " ++ publicNamespaceMacro, + cs, + onlyCode $ "#ifdef " ++ publicNamespaceMacro, + onlyCode $ "} // namespace " ++ publicNamespaceMacro, + onlyCode $ "using namespace " ++ publicNamespaceMacro ++ ";", + onlyCode $ "#endif // " ++ publicNamespaceMacro + ] + | isPrivateNamespace $ getCategoryNamespace t = mconcat [ + onlyCode $ "#ifdef " ++ privateNamespaceMacro, + onlyCode $ "namespace " ++ privateNamespaceMacro ++ " {", + onlyCode $ "#endif // " ++ privateNamespaceMacro, + cs, + onlyCode $ "#ifdef " ++ privateNamespaceMacro, + onlyCode $ "} // namespace " ++ privateNamespaceMacro, + onlyCode $ "using namespace " ++ privateNamespaceMacro ++ ";", + onlyCode $ "#endif // " ++ privateNamespaceMacro + ] + | otherwise = cs + +createLabelForFunction :: Int -> ScopedFunction c -> String +createLabelForFunction i f = functionLabelType f ++ " " ++ functionName f ++ + " = " ++ newFunctionLabel i f ++ ";" + +createFunctionDispatch :: CategoryName -> SymbolScope -> [ScopedFunction c] -> CompiledData [String] +createFunctionDispatch n s fs = onlyCodes $ [typedef] ++ + concat (map table $ byCategory) ++ + concat (map dispatch $ byCategory) ++ + [fallback] where + filtered = filter ((== s) . sfScope) fs + flatten f = f:(concat $ map flatten $ sfMerges f) + flattened = concat $ map flatten filtered + byCategory = Map.toList $ Map.fromListWith (++) $ map (\f -> (sfType f,[f])) flattened + typedef + | s == CategoryScope = " using CallType = ReturnTuple(" ++ categoryName n ++ + "::*)(const ParamTuple&, const ValueTuple&);" + | s == TypeScope = " using CallType = ReturnTuple(" ++ typeName n ++ + "::*)(const S&, const ParamTuple&, const ValueTuple&);" + | s == ValueScope = " using CallType = ReturnTuple(" ++ valueName n ++ + "::*)(const S&, const ParamTuple&, const ValueTuple&);" + | otherwise = undefined + name f + | s == CategoryScope = categoryName n ++ "::" ++ callName f + | s == TypeScope = typeName n ++ "::" ++ callName f + | s == ValueScope = valueName n ++ "::" ++ callName f + | otherwise = undefined + table (n2,fs2) = + [" static const CallType " ++ tableName n2 ++ "[] = {"] ++ + map (\f -> " &" ++ name f ++ ",") (Set.toList $ Set.fromList $ map sfName fs2) ++ + [" };"] + dispatch (n2,_) = [ + " if (label.collection == " ++ collectionName n2 ++ ") {", + " if (label.function_num < 0 || label.function_num >= sizeof " ++ tableName n2 ++ " / sizeof(CallType)) {", + " FAIL() << \"Bad function call \" << label;", + " }", + " return (this->*" ++ tableName n2 ++ "[label.function_num])(" ++ args ++ ");", + " }" + ] + args + | s == CategoryScope = "params, args" + | s == TypeScope = "self, params, args" + | s == ValueScope = "self, params, args" + | otherwise = undefined + fallback + | s == CategoryScope = " return TypeCategory::Dispatch(label, params, args);" + | s == TypeScope = " return TypeInstance::Dispatch(self, label, params, args);" + | s == ValueScope = " return TypeValue::Dispatch(self, label, params, args);" + | otherwise = undefined + +createCanConvertFrom :: AnyCategory c -> CompiledData [String] +createCanConvertFrom t + | isInstanceInterface t = onlyCode $ " return " ++ typeBase ++ "::CanConvertFrom(from);" + | otherwise = onlyCodes $ [ + " std::vector> args;", + " if (!from->TypeArgsForParent(parent, args)) return false;", + " if(args.size() != " ++ show (length params) ++ ") {", + " FAIL() << \"Wrong number of args (\" << args.size() << \") for \" << CategoryName();", + " }" + ] ++ checks ++ [" return true;"] where + params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t + checks = concat $ map singleCheck $ zip ([0..] :: [Int]) params + singleCheck (i,(p,Covariant)) = [checkCov i p] + singleCheck (i,(p,Contravariant)) = [checkCon i p] + singleCheck (i,(p,Invariant)) = [checkCov i p,checkCon i p] + checkCov i p = " if (!TypeInstance::CanConvert(args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;" + checkCon i p = " if (!TypeInstance::CanConvert(" ++ paramName p ++ ", args[" ++ show i ++ "])) return false;" + +createTypeArgsForParent :: AnyCategory c -> CompiledData [String] +createTypeArgsForParent t + | isInstanceInterface t = onlyCode $ " return " ++ typeBase ++ "::TypeArgsForParent(category, args);" + | otherwise = onlyCodes $ allCats ++ [" return false;"] where + params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t + myType = (getCategoryName t,map (singleType . JustParamName False . fst) params) + refines = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType $ getCategoryRefines t + allCats = concat $ map singleCat (myType:refines) + singleCat (t2,ps) = [ + " if (&category == &" ++ categoryGetter t2 ++ "()) {", + " args = std::vector>{" ++ expanded ++ "};", + " return true;", + " }" + ] + where + expanded = intercalate ", " $ map expandLocalType ps + +-- Similar to Procedure.expandGeneralInstance but doesn't account for scope. +expandLocalType :: GeneralInstance -> String +expandLocalType t + | t == minBound = allGetter ++ "()" + | t == maxBound = anyGetter ++ "()" +expandLocalType t = reduceMergeTree getAny getAll getSingle t where + getAny ts = unionGetter ++ combine ts + getAll ts = intersectGetter ++ combine ts + getSingle (JustTypeInstance (TypeInstance t2 ps)) = + typeGetter t2 ++ "(T_get(" ++ intercalate ", " (map expandLocalType $ pValues ps) ++ "))" + getSingle (JustParamName _ p) = paramName p + getSingle (JustInferredType p) = paramName p + combine ps = "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps) ++ "))" + +defineCategoryName :: SymbolScope -> CategoryName -> CompiledData [String] +defineCategoryName TypeScope _ = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }" +defineCategoryName ValueScope _ = onlyCode $ "std::string CategoryName() const final { return parent->CategoryName(); }" +defineCategoryName _ t = onlyCode $ "std::string CategoryName() const final { return \"" ++ show t ++ "\"; }" + +defineTypeName :: [ParamName] -> CompiledData [String] +defineTypeName ps = onlyCode $ " return TypeInstance::TypeNameFrom(output, parent" ++ concat (map ((", " ++) . paramName) ps) ++ ");" + +declareGetCategory :: AnyCategory c -> CompiledData [String] +declareGetCategory t = onlyCodes [categoryBase ++ "& " ++ categoryGetter (getCategoryName t) ++ "();"] + +defineGetCatetory :: AnyCategory c -> CompiledData [String] +defineGetCatetory t = onlyCodes [ + categoryBase ++ "& " ++ categoryGetter (getCategoryName t) ++ "() {", + " return " ++ categoryCreator (getCategoryName t) ++ "();", + "}" + ] + +declareGetType :: AnyCategory c -> CompiledData [String] +declareGetType t = onlyCodes [ + "S<" ++ typeBase ++ "> " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ + show (length $getCategoryParams t) ++ ">::Type params);" + ] + +defineGetType :: AnyCategory c -> CompiledData [String] +defineGetType t = onlyCodes [ + "S<" ++ typeBase ++ "> " ++ typeGetter (getCategoryName t) ++ "(Params<" ++ + show (length $ getCategoryParams t) ++ ">::Type params) {", + " return " ++ typeCreator (getCategoryName t) ++ "(params);", + "}" + ] + +declareInternalCategory :: AnyCategory c -> CompiledData [String] +declareInternalCategory t = onlyCodes [ + categoryName (getCategoryName t) ++ "& " ++ categoryCreator (getCategoryName t) ++ "();" + ] + +defineInternalCategory :: AnyCategory c -> CompiledData [String] +defineInternalCategory t = defineInternalCategory2 (categoryName (getCategoryName t)) t + +defineInternalCategory2 :: String -> AnyCategory c -> CompiledData [String] +defineInternalCategory2 className t = onlyCodes [ + categoryName (getCategoryName t) ++ "& " ++ categoryCreator (getCategoryName t) ++ "() {", + " static auto& category = *new " ++ className ++ "();", + " return category;", + "}" + ] + +declareInternalType :: AnyCategory c -> Int -> CompiledData [String] +declareInternalType t n = onlyCodes [ + "S<" ++ typeName (getCategoryName t) ++ "> " ++ typeCreator (getCategoryName t) ++ + "(Params<" ++ show n ++ ">::Type params);" + ] + +defineInternalType :: AnyCategory c -> Int -> CompiledData [String] +defineInternalType t = defineInternalType2 (typeName (getCategoryName t)) t + +defineInternalType2 :: String -> AnyCategory c -> Int -> CompiledData [String] +defineInternalType2 className t n + | n < 1 = + onlyCodes [ + "S<" ++ typeName (getCategoryName t) ++ "> " ++ typeCreator (getCategoryName t) ++ "(Params<" ++ show n ++ ">::Type params) {", + " static const auto cached = S_get(new " ++ className ++ "(" ++ categoryCreator (getCategoryName t) ++ "(), Params<" ++ show n ++ ">::Type()));", + " return cached;", + "}" + ] + | otherwise = + onlyCodes [ + "S<" ++ typeName (getCategoryName t) ++ "> " ++ typeCreator (getCategoryName t) ++ "(Params<" ++ show n ++ ">::Type params) {", + " static auto& cache = *new WeakInstanceMap<" ++ show n ++ ", " ++ typeName (getCategoryName t) ++ ">();", + " static auto& cache_mutex = *new std::mutex;", + " std::lock_guard lock(cache_mutex);", + " auto& cached = cache[GetKeyFromParams<" ++ show n ++ ">(params)];", + " S<" ++ typeName (getCategoryName t) ++ "> type = cached;", + " if (!type) { cached = type = S_get(new " ++ className ++ "(" ++ categoryCreator (getCategoryName t) ++ "(), params)); }", + " return type;", + "}" + ] + +declareInternalValue :: AnyCategory c -> CompiledData [String] +declareInternalValue t = + onlyCodes [ + "S " ++ valueCreator (getCategoryName t) ++ + "(S<" ++ typeName (getCategoryName t) ++ "> parent, " ++ + "const ParamTuple& params, const ValueTuple& args);" + ] + +defineInternalValue :: AnyCategory c -> CompiledData [String] +defineInternalValue t = defineInternalValue2 (valueName (getCategoryName t)) t + +defineInternalValue2 :: String -> AnyCategory c -> CompiledData [String] +defineInternalValue2 className t = + onlyCodes [ + "S " ++ valueCreator (getCategoryName t) ++ "(S<" ++ typeName (getCategoryName t) ++ "> parent, " ++ + "const ParamTuple& params, const ValueTuple& args) {", + " return S_get(new " ++ className ++ "(parent, params, args));", + "}" + ] + +getCategoryMentions :: AnyCategory c -> Set.Set CategoryName +getCategoryMentions t = Set.fromList $ fromRefines (getCategoryRefines t) ++ + fromDefines (getCategoryDefines t) ++ + fromFunctions (getCategoryFunctions t) ++ + fromFilters (getCategoryFilters t) where + fromRefines rs = Set.toList $ Set.unions $ map (categoriesFromRefine . vrType) rs + fromDefines ds = Set.toList $ Set.unions $ map (categoriesFromDefine . vdType) ds + fromDefine (DefinesInstance d ps) = d:(fromGenerals $ pValues ps) + fromFunctions fs = concat $ map fromFunction fs + fromFunction (ScopedFunction _ _ t2 _ as rs _ fs _) = + [t2] ++ (fromGenerals $ map (vtType . pvType) (pValues as ++ pValues rs)) ++ fromFilters fs + fromFilters fs = concat $ map (fromFilter . pfFilter) fs + fromFilter (TypeFilter _ t2) = Set.toList $ categoriesFromTypes t2 + fromFilter (DefinesFilter t2) = fromDefine t2 + fromGenerals = Set.toList . Set.unions . map categoriesFromTypes diff --git a/src/CompilerCxx/LanguageModule.hs b/src/CompilerCxx/LanguageModule.hs new file mode 100644 --- /dev/null +++ b/src/CompilerCxx/LanguageModule.hs @@ -0,0 +1,215 @@ +{- ----------------------------------------------------------------------------- +Copyright 2019-2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module CompilerCxx.LanguageModule ( + LanguageModule(..), + PrivateSource(..), + compileLanguageModule, + compileModuleMain, + compileTestsModule, +) where + +import Control.Monad (foldM,foldM_,when) +import Data.List (intercalate,nub) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Base.CompilerError +import Compilation.CompilerState +import Compilation.ProcedureContext (ExprMap) +import CompilerCxx.CxxFiles +import CompilerCxx.Naming +import Types.Builtin +import Types.DefinedCategory +import Types.Procedure +import Types.TypeCategory +import Types.TypeInstance + + +data LanguageModule c = + LanguageModule { + lmPublicNamespaces :: Set.Set Namespace, + lmPrivateNamespaces :: Set.Set Namespace, + lmLocalNamespaces :: Set.Set Namespace, + lmPublicDeps :: [AnyCategory c], + lmPrivateDeps :: [AnyCategory c], + lmTestingDeps :: [AnyCategory c], + lmPublicLocal :: [AnyCategory c], + lmPrivateLocal :: [AnyCategory c], + lmTestingLocal :: [AnyCategory c], + lmExternal :: [CategoryName], + lmStreamlined :: [CategoryName], + lmExprMap :: ExprMap c + } + +data PrivateSource c = + PrivateSource { + psNamespace :: Namespace, + psTesting :: Bool, + psCategory :: [AnyCategory c], + psDefine :: [DefinedCategory c] + } + +compileLanguageModule :: (Ord c, Show c, CollectErrorsM m) => + LanguageModule c -> [PrivateSource c] -> m [CxxOutput] +compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex ss em) xa = do + let dm = mapDefByName $ concat $ map psDefine xa + checkDefined dm extensions $ filter isValueConcrete (cs1 ++ ps1 ++ ts1) + checkSupefluous $ Set.toList $ extensions `Set.difference` ca + tmPublic <- foldM includeNewTypes defaultCategories [cs0,cs1] + tmPrivate <- foldM includeNewTypes tmPublic [ps0,ps1] + tmTesting <- foldM includeNewTypes tmPrivate [ts0,ts1] + let nsPublic = ns0 `Set.union` ns2 + let nsPrivate = ns1 `Set.union` nsPublic + let nsTesting = nsPrivate + xxInterfaces <- fmap concat $ collectAllM $ + map (generateNativeInterface False) (onlyNativeInterfaces cs1) ++ + map (generateNativeInterface False) (onlyNativeInterfaces ps1) ++ + map (generateNativeInterface True) (onlyNativeInterfaces ts1) + xxPrivate <- fmap concat $ mapErrorsM (compilePrivate (tmPrivate,nsPrivate) (tmTesting,nsTesting)) xa + xxStreamlined <- fmap concat $ mapErrorsM (streamlined tmTesting) $ nub ss + xxVerbose <- fmap concat $ mapErrorsM (verbose tmTesting) $ nub ex + let allFiles = xxInterfaces ++ xxPrivate ++ xxStreamlined ++ xxVerbose + noDuplicateFiles $ map (\f -> (coFilename f,coNamespace f)) allFiles + return allFiles where + extensions = Set.fromList $ ex ++ ss + testingCats = Set.fromList $ map getCategoryName ts1 + onlyNativeInterfaces = filter (not . (`Set.member` extensions) . getCategoryName) . filter (not . isValueConcrete) + localCats = Set.fromList $ map getCategoryName $ cs1 ++ ps1 ++ ts1 + streamlined tm n = do + checkLocal localCats ([] :: [String]) n + (_,t) <- getConcreteCategory tm ([],n) + generateStreamlinedExtension (n `Set.member` testingCats) t + verbose tm n = do + checkLocal localCats ([] :: [String]) n + (_,t) <- getConcreteCategory tm ([],n) + generateVerboseExtension (n `Set.member` testingCats) t + compilePrivate (tmPrivate,nsPrivate) (tmTesting,nsTesting) (PrivateSource ns3 testing cs2 ds) = do + let (tm,ns) = if testing + then (tmTesting,nsTesting) + else (tmPrivate,nsPrivate) + let cs = Set.fromList $ map getCategoryName $ if testing + then cs2 ++ cs1 ++ ps1 ++ ts1 + else cs2 ++ cs1 ++ ps1 + tm' <- includeNewTypes tm cs2 + let ctx = FileContext testing tm' (ns3 `Set.insert` ns) em + checkLocals ds $ Map.keysSet tm' + when testing $ checkTests ds (cs1 ++ ps1) + let dm = mapDefByName ds + checkDefined dm Set.empty $ filter isValueConcrete cs2 + xxInterfaces <- fmap concat $ mapErrorsM (generateNativeInterface testing) (filter (not . isValueConcrete) cs2) + xxConcrete <- fmap concat $ mapErrorsM (generateConcrete cs ctx) ds + return $ xxInterfaces ++ xxConcrete + generateConcrete cs (FileContext testing tm ns em2) d = do + tm' <- mergeInternalInheritance tm d + t <- getCategoryDecl cs tm d + let ctx = FileContext testing tm' ns em2 + generateNativeConcrete ctx (t,d) + getCategoryDecl cs tm d = do + checkLocal cs (dcContext d) (dcName d) + fmap snd $ getConcreteCategory tm (dcContext d,dcName d) + mapDefByName = Map.fromListWith (++) . map (\d -> (dcName d,[d])) + ca = Set.fromList $ map getCategoryName $ filter isValueConcrete (cs1 ++ ps1 ++ ts1) + checkLocals ds tm = mapErrorsM_ (\d -> checkLocal tm (dcContext d) (dcName d)) ds + checkLocal cs2 c n = + when (not $ n `Set.member` cs2) $ + compilerErrorM ("Category " ++ show n ++ + formatFullContextBrace c ++ + " does not correspond to a visible category in this module") + checkTests ds ps = do + let pa = Map.fromList $ map (\c -> (getCategoryName c,getCategoryContext c)) $ filter isValueConcrete ps + mapErrorsM_ (checkTest pa) ds + checkTest pa d = + case dcName d `Map.lookup` pa of + Nothing -> return () + Just c -> + compilerErrorM ("Category " ++ show (dcName d) ++ + formatFullContextBrace (dcContext d) ++ + " was not declared as $TestsOnly$" ++ formatFullContextBrace c) + checkDefined dm ext = mapErrorsM_ (checkSingle dm ext) + checkSingle dm ext t = + case (getCategoryName t `Set.member` ext,getCategoryName t `Map.lookup` dm) of + (False,Just [_]) -> return () + (True,Nothing) -> return () + (True,Just [d]) -> + compilerErrorM ("Category " ++ show (getCategoryName t) ++ + formatFullContextBrace (getCategoryContext t) ++ + " was declared external but is also defined at " ++ formatFullContext (dcContext d)) + (False,Nothing) -> + compilerErrorM ("Category " ++ show (getCategoryName t) ++ + formatFullContextBrace (getCategoryContext t) ++ + " has not been defined or declared external") + (_,Just ds) -> + ("Category " ++ show (getCategoryName t) ++ + formatFullContextBrace (getCategoryContext t) ++ + " is defined " ++ show (length ds) ++ " times") !!> + mapErrorsM_ (\d -> compilerErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds + checkSupefluous es2 + | null es2 = return () + | otherwise = compilerErrorM $ "External categories either not concrete or not present: " ++ + intercalate ", " (map show es2) + noDuplicateFiles = foldM_ checkFileUsed Set.empty + checkFileUsed used (f,ns3) = do + when ((f,ns3) `Set.member` used) $ + compilerErrorM $ "Filename " ++ f ++ " in namespace " ++ show ns3 ++ + " was already generated (internal compiler error)" + return $ (f,ns3) `Set.insert` used + +compileTestsModule :: (Ord c, Show c, CollectErrorsM m) => + LanguageModule c -> Namespace -> [String] -> [AnyCategory c] -> [DefinedCategory c] -> + [TestProcedure c] -> m ([CxxOutput],CxxOutput,[(FunctionName,[c])]) +compileTestsModule cm ns args cs ds ts = do + let xs = PrivateSource { + psNamespace = ns, + psTesting = True, + psCategory = cs, + psDefine = ds + } + xx <- compileLanguageModule cm [xs] + (main,fs) <- compileTestMain cm args xs ts + return (xx,main,fs) + +compileTestMain :: (Ord c, Show c, CollectErrorsM m) => + LanguageModule c -> [String] -> PrivateSource c -> [TestProcedure c] -> + m (CxxOutput,[(FunctionName,[c])]) +compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ _ em) args ts2 tests = do + tm' <- tm + (CompiledData req main) <- generateTestFile tm' em args tests + let output = CxxOutput Nothing testFilename NoNamespace (psNamespace ts2 `Set.insert` Set.unions [ns0,ns1,ns2]) req main + let tests' = map (\t -> (tpName t,tpContext t)) tests + return (output,tests') where + tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2] + +compileModuleMain :: (Ord c, Show c, CollectErrorsM m) => + LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput +compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 _ cs1 ps1 _ _ _ em) xa n f = do + let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine $ filter (not . psTesting) xa + reconcile resolved + tm' <- tm + let cs = filter (\c -> getCategoryName c == n) $ concat $ map psCategory xa + tm'' <- includeNewTypes tm' cs + (ns,main) <- generateMainFile tm'' em n f + return $ CxxOutput Nothing mainFilename NoNamespace (ns `Set.insert` Set.unions [ns0,ns1,ns2]) (Set.fromList [n]) main where + tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1] + reconcile [_] = return () + reconcile [] = compilerErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)" + reconcile ds = + "Multiple matches for main category " ++ show n !!> + mapErrorsM_ (\d -> compilerErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds diff --git a/src/CompilerCxx/Naming.hs b/src/CompilerCxx/Naming.hs --- a/src/CompilerCxx/Naming.hs +++ b/src/CompilerCxx/Naming.hs @@ -25,6 +25,7 @@ baseSourceIncludes, callName, categoryCreator, + categoryCustom, categoryGetter, categoryName, collectionName, @@ -44,13 +45,16 @@ sourceFilename, sourceStreamlined, tableName, + templateStreamlined, testFilename, testFunctionName, typeCreator, + typeCustom, typeGetter, typeName, unionGetter, valueCreator, + valueCustom, valueName, variableName, ) where @@ -75,6 +79,9 @@ sourceStreamlined :: CategoryName -> String sourceStreamlined n = "Streamlined_" ++ show n ++ ".cpp" +templateStreamlined :: CategoryName -> String +templateStreamlined n = "Extension_" ++ show n ++ ".cpp" + mainFilename :: String mainFilename = "main.cpp" @@ -125,6 +132,15 @@ valueName :: CategoryName -> String valueName n = "Value_" ++ show n + +categoryCustom :: CategoryName -> String +categoryCustom n = "ExtCategory_" ++ show n + +typeCustom :: CategoryName -> String +typeCustom n = "ExtType_" ++ show n + +valueCustom :: CategoryName -> String +valueCustom n = "ExtValue_" ++ show n callName :: FunctionName -> String callName f = "Call_" ++ show f diff --git a/src/CompilerCxx/Procedure.hs b/src/CompilerCxx/Procedure.hs --- a/src/CompilerCxx/Procedure.hs +++ b/src/CompilerCxx/Procedure.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -30,6 +30,7 @@ compileLazyInit, compileRegularInit, compileTestProcedure, + procedureDeclaration, selectTestFromArgv1, ) where @@ -54,23 +55,41 @@ import Types.Builtin import Types.DefinedCategory import Types.Function -import Types.Pragma import Types.Procedure import Types.TypeCategory import Types.TypeInstance import Types.Variance +procedureDeclaration :: Monad m => Bool -> ScopedFunction c -> m (CompiledData [String]) +procedureDeclaration abstract f = return $ onlyCode func where + func + | abstract = "virtual " ++ proto ++ " = 0;" + | otherwise = proto ++ ";" + name = callName (sfName f) + proto + | sfScope f == CategoryScope = + "ReturnTuple " ++ name ++ "(const ParamTuple& params, const ValueTuple& args)" + | sfScope f == TypeScope = + "ReturnTuple " ++ name ++ + -- NOTE: Don't use Var_self, since self isn't accessible to @type functions. + "(const S& self, const ParamTuple& params, const ValueTuple& args)" + | sfScope f == ValueScope = + "ReturnTuple " ++ name ++ + "(const S& Var_self, const ParamTuple& params, const ValueTuple& args)" + | otherwise = undefined + compileExecutableProcedure :: (Ord c, Show c, CollectErrorsM m) => - ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> - m (CompiledData [String],CompiledData [String]) -compileExecutableProcedure ctx ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _) - pp@(ExecutableProcedure c pragmas c2 n as2 rs2 p) = do + Maybe String -> ScopeContext c -> ScopedFunction c -> + ExecutableProcedure c -> m (CompiledData [String]) +compileExecutableProcedure className ctx + ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _) + pp@(ExecutableProcedure c pragmas c2 n as2 rs2 p) = do ctx' <- getProcedureContext ctx ff pp output <- runDataCompiler compileWithReturn ctx' procedureTrace <- setProcedureTrace creationTrace <- setCreationTrace - return (onlyCode header,wrapProcedure output procedureTrace creationTrace) + return $ wrapProcedure output procedureTrace creationTrace where t = scName ctx compileWithReturn = do @@ -80,9 +99,11 @@ when (not unreachable) $ doImplicitReturn c2 & self, const ParamTuple& params, const ValueTuple& args);" - | s == ValueScope = - returnType ++ " " ++ name ++ - "(const S& Var_self, const ParamTuple& params, const ValueTuple& args);" - | otherwise = undefined - header2 + prefix = case className of + Nothing -> "" + Just cn -> cn ++ "::" + proto | s == CategoryScope = - returnType ++ " " ++ categoryName t ++ "::" ++ name ++ "(const ParamTuple& params, const ValueTuple& args) {" + returnType ++ " " ++ prefix ++ name ++ "(const ParamTuple& params, const ValueTuple& args) {" | s == TypeScope = - returnType ++ " " ++ typeName t ++ "::" ++ name ++ + returnType ++ " " ++ prefix ++ name ++ -- NOTE: Don't use Var_self, since self isn't accessible to @type functions. "(const S& self, const ParamTuple& params, const ValueTuple& args) {" | s == ValueScope = - returnType ++ " " ++ valueName t ++ "::" ++ name ++ + returnType ++ " " ++ prefix ++ name ++ "(const S& Var_self, const ParamTuple& params, const ValueTuple& args) {" | otherwise = undefined returnType = "ReturnTuple" @@ -275,13 +288,11 @@ -- TODO: Call csAddRequired for t1. (Maybe needs a helper function.) lift $ collectAllM_ [validateGeneralInstance r fa (vtType t1), checkValueAssignment r fa t2 t1] - csAddVariable (UsedVariable c2 n) (VariableValue c2 LocalScope t1 True) + csAddVariable (UsedVariable c2 n) (VariableValue c2 LocalScope t1 VariableDefault) csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"] createVariable r fa (ExistingVariable (InputValue c2 n)) t2 = "In assignment to " ++ show n ++ " at " ++ formatFullContext c2 ??> do - (VariableValue _ _ t1 w) <- csGetVariable (UsedVariable c2 n) - when (not w) $ compilerErrorM $ "Cannot assign to read-only variable " ++ - show n ++ formatFullContextBrace c2 + (VariableValue _ _ t1 _) <- getWritableVariable c2 n -- TODO: Also show original context. lift $ (checkValueAssignment r fa t2 t1) csUpdateAssigned n @@ -303,6 +314,8 @@ writeStoredVariable t (UnwrappedSingle $ "r.At(" ++ show i ++ ")") ++ ";"] assignMulti _ = return () compileStatement (NoValueExpression _ v) = compileVoidExpression v +compileStatement (MarkReadOnly c vs) = mapM_ (\v -> csSetReadOnly (UsedVariable c v)) vs +compileStatement (MarkHidden c vs) = mapM_ (\v -> csSetHidden (UsedVariable c v)) vs compileStatement (RawCodeLine s) = csWrite [s] compileRegularInit :: (Ord c, Show c, CollectErrorsM m, @@ -310,10 +323,21 @@ DefinedMember c -> CompilerState a m () compileRegularInit (DefinedMember _ _ _ _ Nothing) = return () compileRegularInit (DefinedMember c2 s t n2 (Just e)) = resetBackgroundM $ do - csAddVariable (UsedVariable c2 n2) (VariableValue c2 s t True) + csAddVariable (UsedVariable c2 n2) (VariableValue c2 s t VariableDefault) let assign = Assignment c2 (Positional [ExistingVariable (InputValue c2 n2)]) e compileStatement assign +getWritableVariable :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) => + [c] -> VariableName -> CompilerState a m (VariableValue c) +getWritableVariable c n = do + v@(VariableValue _ _ _ ro) <- csGetVariable (UsedVariable c n) + case ro of + VariableReadOnly [] -> compilerErrorM $ "Variable " ++ show n ++ + formatFullContextBrace c ++ " is read-only" + VariableReadOnly c2 -> compilerErrorM $ "Variable " ++ show n ++ + formatFullContextBrace c ++ " is marked read-only at " ++ formatFullContext c2 + _ -> return v + compileLazyInit :: (Ord c, Show c, CollectErrorsM m, CompilerContext c m [String] a) => DefinedMember c -> CompilerState a m () @@ -408,7 +432,7 @@ -- Make variables to be created visible *after* p has been compiled so that p -- can't refer to them. ctxP <- lift $ execStateT (sequence $ map showVariable vs) ctxP0 - ctxCl0 <- lift $ ccClearOutput ctxP >>= ccStartCleanup + ctxCl0 <- lift $ ccClearOutput ctxP >>= flip ccStartCleanup c2 ctxP' <- case cl of -- Insert cleanup into the context for the in block. @@ -437,7 +461,7 @@ csWrite [variableStoredType t ++ " " ++ variableName n ++ ";"] showVariable (c,t,n) = do -- TODO: Call csAddRequired for t. (Maybe needs a helper function.) - csAddVariable (UsedVariable c n) (VariableValue c LocalScope t True) + csAddVariable (UsedVariable c n) (VariableValue c LocalScope t VariableDefault) -- Don't merge if the second scope has cleanup, so that the latter can't -- refer to variables defined in the first scope. rewriteScoped (ScopedBlock _ p cl@(Just _) _ @@ -793,9 +817,7 @@ compileExpressionStart (BuiltinCall _ _) = undefined compileExpressionStart (ParensExpression _ e) = compileExpression e compileExpressionStart (InlineAssignment c n e) = do - (VariableValue _ s t0 w) <- csGetVariable (UsedVariable c n) - when (not w) $ compilerErrorM $ "Cannot assign to read-only variable " ++ - show n ++ formatFullContextBrace c + (VariableValue _ s t0 _) <- getWritableVariable c n (Positional [t],e') <- compileExpression e -- TODO: Get rid of the Positional matching here. r <- csResolver fa <- csAllFilters diff --git a/src/Module/CompileMetadata.hs b/src/Module/CompileMetadata.hs --- a/src/Module/CompileMetadata.hs +++ b/src/Module/CompileMetadata.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -30,8 +30,7 @@ import Cli.CompileOptions import Cli.Programs (VersionHash) import Parser.TextParser (SourceContext) -import Types.Pragma (MacroName) -import Types.Procedure (Expression) +import Types.Procedure (Expression,MacroName) import Types.TypeCategory (Namespace) import Types.TypeInstance (CategoryName) diff --git a/src/Module/ParseMetadata.hs b/src/Module/ParseMetadata.hs --- a/src/Module/ParseMetadata.hs +++ b/src/Module/ParseMetadata.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -35,8 +35,7 @@ import Parser.TypeCategory () import Parser.TypeInstance () import Text.Regex.TDFA -import Types.Pragma (MacroName) -import Types.Procedure (Expression) +import Types.Procedure (Expression,MacroName) import Types.TypeCategory (FunctionName(..),Namespace(..)) import Types.TypeInstance (CategoryName(..)) diff --git a/src/Module/ProcessMetadata.hs b/src/Module/ProcessMetadata.hs --- a/src/Module/ProcessMetadata.hs +++ b/src/Module/ProcessMetadata.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -63,14 +63,13 @@ import Cli.CompileOptions import Cli.Programs (VersionHash(..)) import Compilation.ProcedureContext (ExprMap) -import CompilerCxx.Category (CxxOutput(..)) +import CompilerCxx.CxxFiles (CxxOutput(..)) import Module.CompileMetadata import Module.ParseMetadata import Module.Paths import Parser.SourceFile import Parser.TextParser (SourceContext) -import Types.Pragma -import Types.Procedure (Expression(Literal),ValueLiteral(..)) +import Types.Procedure import Types.TypeCategory import Types.TypeInstance diff --git a/src/Parser/Pragma.hs b/src/Parser/Pragma.hs --- a/src/Parser/Pragma.hs +++ b/src/Parser/Pragma.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -17,14 +17,9 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] module Parser.Pragma ( + autoPragma, parsePragmas, - pragmaComment, - pragmaExprLookup, - pragmaNoTrace, - pragmaModuleOnly, - pragmaSourceContext, - pragmaTestsOnly, - pragmaTraceCreation, + unknownPragma, ) where import Control.Monad (when) @@ -32,52 +27,10 @@ import Base.CompilerError import Parser.Common import Parser.TextParser -import Types.Pragma parsePragmas :: [TextParser a] -> TextParser [a] -parsePragmas = many . foldr ((<|>)) unknownPragma - -pragmaModuleOnly :: TextParser (Pragma SourceContext) -pragmaModuleOnly = autoPragma "ModuleOnly" $ Left parseAt where - parseAt c = PragmaVisibility [c] ModuleOnly - -instance ParseFromSource MacroName where - sourceParser = labeled "macro name" $ do - h <- upperChar <|> char '_' - t <- many (upperChar <|> digitChar <|> char '_') - optionalSpace - return $ MacroName (h:t) - -pragmaExprLookup :: TextParser (Pragma SourceContext) -pragmaExprLookup = autoPragma "ExprLookup" $ Right parseAt where - parseAt c = do - name <- sourceParser - return $ PragmaExprLookup [c] name - -pragmaSourceContext :: TextParser (Pragma SourceContext) -pragmaSourceContext = autoPragma "SourceContext" $ Left parseAt where - parseAt c = PragmaSourceContext c - -pragmaNoTrace :: TextParser (Pragma SourceContext) -pragmaNoTrace = autoPragma "NoTrace" $ Left parseAt where - parseAt c = PragmaTracing [c] NoTrace - -pragmaTraceCreation :: TextParser (Pragma SourceContext) -pragmaTraceCreation = autoPragma "TraceCreation" $ Left parseAt where - parseAt c = PragmaTracing [c] TraceCreation - -pragmaTestsOnly :: TextParser (Pragma SourceContext) -pragmaTestsOnly = autoPragma "TestsOnly" $ Left parseAt where - parseAt c = PragmaVisibility [c] TestsOnly - -pragmaComment :: TextParser (Pragma SourceContext) -pragmaComment = autoPragma "Comment" $ Right parseAt where - parseAt c = do - string_ "\"" - ss <- manyTill stringChar (string_ "\"") - optionalSpace - return $ PragmaComment [c] ss +parsePragmas = many . foldr ((<|>)) (try unknownPragma) unknownPragma :: TextParser a unknownPragma = do diff --git a/src/Parser/Procedure.hs b/src/Parser/Procedure.hs --- a/src/Parser/Procedure.hs +++ b/src/Parser/Procedure.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -20,6 +20,15 @@ {-# LANGUAGE FlexibleInstances #-} module Parser.Procedure ( + MarkType(..), + PragmaExpr(..), + PragmaStatement(..), + pragmaExprLookup, + pragmaHidden, + pragmaNoTrace, + pragmaReadOnly, + pragmaSourceContext, + pragmaTraceCreation, ) where import Control.Monad (when) @@ -32,7 +41,6 @@ import Parser.TextParser import Parser.TypeCategory () import Parser.TypeInstance () -import Types.Pragma import Types.Procedure import Types.TypeCategory @@ -118,6 +126,7 @@ parseFailCall <|> parseVoid <|> parseAssign <|> + parsePragma <|> parseIgnore where parseAssign = labeled "statement" $ do c <- getSourceContext @@ -163,6 +172,11 @@ c <- getSourceContext e <- sourceParser return $ NoValueExpression [c] e + parsePragma = do + p <- pragmaReadOnly <|> pragmaHidden <|> unknownPragma + case p of + PragmaMarkVars c ReadOnly vs -> return $ MarkReadOnly c vs + PragmaMarkVars c Hidden vs -> return $ MarkHidden c vs instance ParseFromSource (Assignable SourceContext) where sourceParser = existing <|> create where @@ -345,7 +359,6 @@ else if bothInOperatorSet o1 o2 rightAssocInfix then return False -- Logical operators are right-associative. else return True -- Default is left-associative. - where checkAmbiguous :: (Show c, ErrorContextM m) => Operator c -> Operator c -> m () checkAmbiguous o1 o2 = checked where @@ -639,3 +652,60 @@ n <- sourceParser f <- parseFunctionCall c n return $ ConvertedCall [c] t f + +instance ParseFromSource MacroName where + sourceParser = labeled "macro name" $ do + h <- upperChar <|> char '_' + t <- many (upperChar <|> digitChar <|> char '_') + optionalSpace + return $ MacroName (h:t) + +pragmaNoTrace :: TextParser (PragmaProcedure SourceContext) +pragmaNoTrace = autoPragma "NoTrace" $ Left parseAt where + parseAt c = PragmaTracing [c] NoTrace + +pragmaTraceCreation :: TextParser (PragmaProcedure SourceContext) +pragmaTraceCreation = autoPragma "TraceCreation" $ Left parseAt where + parseAt c = PragmaTracing [c] TraceCreation + +data PragmaExpr c = + PragmaExprLookup { + pelContext :: [c], + pelName :: MacroName + } | + PragmaSourceContext { + pscContext :: c + } + deriving (Show) + +pragmaExprLookup :: TextParser (PragmaExpr SourceContext) +pragmaExprLookup = autoPragma "ExprLookup" $ Right parseAt where + parseAt c = do + name <- sourceParser + return $ PragmaExprLookup [c] name + +pragmaSourceContext :: TextParser (PragmaExpr SourceContext) +pragmaSourceContext = autoPragma "SourceContext" $ Left parseAt where + parseAt c = PragmaSourceContext c + +data MarkType = ReadOnly | Hidden deriving (Show) + +data PragmaStatement c = + PragmaMarkVars { + pmvContext :: [c], + pmvType :: MarkType, + pmvVars :: [VariableName] + } + deriving (Show) + +pragmaReadOnly :: TextParser (PragmaStatement SourceContext) +pragmaReadOnly = autoPragma "ReadOnly" $ Right parseAt where + parseAt c = do + vs <- labeled "variable names" $ sepBy sourceParser (sepAfter $ string ",") + return $ PragmaMarkVars [c] ReadOnly vs + +pragmaHidden :: TextParser (PragmaStatement SourceContext) +pragmaHidden = autoPragma "Hidden" $ Right parseAt where + parseAt c = do + vs <- labeled "variable names" $ sepBy sourceParser (sepAfter $ string ",") + return $ PragmaMarkVars [c] Hidden vs diff --git a/src/Parser/SourceFile.hs b/src/Parser/SourceFile.hs --- a/src/Parser/SourceFile.hs +++ b/src/Parser/SourceFile.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -17,11 +17,23 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] module Parser.SourceFile ( + CodeVisibility(..), + PragmaSource(..), + WithVisibility(..), + hasCodeVisibility, + isModuleOnly, + isTestsOnly, + mapCodeVisibility, parseInternalSource, parsePublicSource, parseTestSource, + pragmaModuleOnly, + pragmaTestsOnly, + updateCodeVisibility, ) where +import qualified Data.Set as Set + import Base.CompilerError import Parser.Common import Parser.DefinedCategory () @@ -31,12 +43,11 @@ import Parser.TypeCategory () import Types.DefinedCategory import Types.IntegrationTest -import Types.Pragma import Types.TypeCategory parseInternalSource :: ErrorContextM m => - (FilePath,String) -> m ([Pragma SourceContext],[AnyCategory SourceContext],[DefinedCategory SourceContext]) + (FilePath,String) -> m ([PragmaSource SourceContext],[AnyCategory SourceContext],[DefinedCategory SourceContext]) parseInternalSource (f,s) = runTextParser (between optionalSpace endOfDoc withPragmas) f s where withPragmas = do pragmas <- parsePragmas internalSourcePragmas @@ -44,7 +55,7 @@ (cs,ds) <- parseAny2 sourceParser sourceParser return (pragmas,cs,ds) -parsePublicSource :: ErrorContextM m => (FilePath,String) -> m ([Pragma SourceContext],[AnyCategory SourceContext]) +parsePublicSource :: ErrorContextM m => (FilePath,String) -> m ([PragmaSource SourceContext],[AnyCategory SourceContext]) parsePublicSource (f,s) = runTextParser (between optionalSpace endOfDoc withPragmas) f s where withPragmas = do pragmas <- parsePragmas publicSourcePragmas @@ -52,7 +63,7 @@ cs <- sepBy sourceParser optionalSpace return (pragmas,cs) -parseTestSource :: ErrorContextM m => (FilePath,String) -> m ([Pragma SourceContext],[IntegrationTest SourceContext]) +parseTestSource :: ErrorContextM m => (FilePath,String) -> m ([PragmaSource SourceContext],[IntegrationTest SourceContext]) parseTestSource (f,s) = runTextParser (between optionalSpace endOfDoc withPragmas) f s where withPragmas = do pragmas <- parsePragmas testSourcePragmas @@ -60,11 +71,53 @@ ts <- sepBy sourceParser optionalSpace return (pragmas,ts) -publicSourcePragmas :: [TextParser (Pragma SourceContext)] +publicSourcePragmas :: [TextParser (PragmaSource SourceContext)] publicSourcePragmas = [pragmaModuleOnly,pragmaTestsOnly] -internalSourcePragmas :: [TextParser (Pragma SourceContext)] +internalSourcePragmas :: [TextParser (PragmaSource SourceContext)] internalSourcePragmas = [pragmaTestsOnly] -testSourcePragmas :: [TextParser (Pragma SourceContext)] +testSourcePragmas :: [TextParser (PragmaSource SourceContext)] testSourcePragmas = [] + +pragmaModuleOnly :: TextParser (PragmaSource SourceContext) +pragmaModuleOnly = autoPragma "ModuleOnly" $ Left parseAt where + parseAt c = PragmaVisibility [c] ModuleOnly + +pragmaTestsOnly :: TextParser (PragmaSource SourceContext) +pragmaTestsOnly = autoPragma "TestsOnly" $ Left parseAt where + parseAt c = PragmaVisibility [c] TestsOnly + +data CodeVisibility = ModuleOnly | TestsOnly | FromDependency deriving (Eq,Ord,Show) + +data WithVisibility a = + WithVisibility { + wvVisibility :: Set.Set CodeVisibility, + wvData :: a + } + deriving (Show) + +hasCodeVisibility :: CodeVisibility -> WithVisibility a -> Bool +hasCodeVisibility v = Set.member v . wvVisibility + +mapCodeVisibility :: (a -> b) -> WithVisibility a -> WithVisibility b +mapCodeVisibility f (WithVisibility v x) = WithVisibility v (f x) + +updateCodeVisibility :: (Set.Set CodeVisibility -> Set.Set CodeVisibility) -> + WithVisibility a -> WithVisibility a +updateCodeVisibility f (WithVisibility v x) = WithVisibility (f v) x + +data PragmaSource c = + PragmaVisibility { + pvContext :: [c], + pvScopes :: CodeVisibility + } + deriving (Show) + +isModuleOnly :: PragmaSource c -> Bool +isModuleOnly (PragmaVisibility _ ModuleOnly) = True +isModuleOnly _ = False + +isTestsOnly :: PragmaSource c -> Bool +isTestsOnly (PragmaVisibility _ TestsOnly) = True +isTestsOnly _ = False diff --git a/src/Test/Common.hs b/src/Test/Common.hs --- a/src/Test/Common.hs +++ b/src/Test/Common.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -20,6 +20,8 @@ checkDefinesFail, checkDefinesSuccess, checkEquals, + checkParseError, + checkParseMatch, checkTypeFail, checkTypeSuccess, containsAtLeast, @@ -43,6 +45,7 @@ import System.Exit import System.FilePath import System.IO +import Text.Regex.TDFA import qualified Data.Map as Map import qualified Data.Set as Set @@ -179,3 +182,28 @@ loadFile :: String -> IO String loadFile f = readFile ("src" "Test" f) + +checkParseMatch :: Show a => String -> TextParser a -> (a -> Bool) -> IO (TrackedErrors ()) +checkParseMatch s p m = return $ do + let parsed = readSingleWith p "(string)" s + check parsed + e <- parsed + when (not $ m e) $ + compilerErrorM $ "No match in '" ++ s ++ "':\n" ++ show e + where + check c + | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) + | otherwise = return () + +checkParseError :: Show a => String -> String -> TextParser a -> IO (TrackedErrors ()) +checkParseError s m p = return $ do + let parsed = readSingleWith p "(string)" s + check parsed + where + check c + | isCompilerError c = do + let text = show (getCompilerError c) + when (not $ text =~ m) $ + compilerErrorM $ "Expected pattern " ++ show m ++ " in error output but got\n" ++ text + | otherwise = + compilerErrorM $ "Expected write failure but got\n" ++ show (getCompilerSuccess c) diff --git a/src/Test/ParseMetadata.hs b/src/Test/ParseMetadata.hs --- a/src/Test/ParseMetadata.hs +++ b/src/Test/ParseMetadata.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -30,7 +30,6 @@ import Module.ParseMetadata import System.FilePath import Test.Common -import Types.Pragma import Types.Procedure import Types.TypeCategory (FunctionName(..),Namespace(..)) import Types.TypeInstance (CategoryName(..)) diff --git a/src/Test/Parser.hs b/src/Test/Parser.hs --- a/src/Test/Parser.hs +++ b/src/Test/Parser.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -66,7 +66,7 @@ checkParseFail (operator ">>??!" >> many asciiChar) ">>??!!!" ] -checkParsesAs :: (Eq a, Show a) => TextParser a -> [Char] -> a -> IO (TrackedErrors ()) +checkParsesAs :: (Eq a, Show a) => TextParser a -> String -> a -> IO (TrackedErrors ()) checkParsesAs p s m = return $ do let parsed = readSingleWith p "(string)" s check parsed @@ -78,7 +78,7 @@ | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) | otherwise = return () -checkParseFail :: Show a => TextParser a -> [Char] -> IO (TrackedErrors ()) +checkParseFail :: Show a => TextParser a -> String -> IO (TrackedErrors ()) checkParseFail p s = do let parsed = readSingleWith p "(string)" s return $ check parsed diff --git a/src/Test/Pragma.hs b/src/Test/Pragma.hs --- a/src/Test/Pragma.hs +++ b/src/Test/Pragma.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -18,106 +18,34 @@ module Test.Pragma (tests) where -import Control.Monad (when) -import Text.Regex.TDFA - -import Base.CompilerError import Base.TrackedErrors +import Parser.Common import Parser.Pragma import Parser.TextParser import Test.Common -import Types.Pragma tests :: [IO (TrackedErrors ())] tests = [ - checkParsesAs "$ModuleOnly$" (fmap (:[]) pragmaModuleOnly) - (\e -> case e of - [PragmaVisibility _ ModuleOnly] -> True - _ -> False), - - checkParsesAs "$TestsOnly$" (fmap (:[]) pragmaTestsOnly) - (\e -> case e of - [PragmaVisibility _ TestsOnly] -> True - _ -> False), - - checkParsesAs "$SourceContext$" (fmap (:[]) pragmaSourceContext) - (\e -> case e of - [PragmaSourceContext _] -> True - _ -> False), - - checkParsesAs "$NoTrace$" (fmap (:[]) pragmaNoTrace) - (\e -> case e of - [PragmaTracing _ NoTrace] -> True - _ -> False), - - checkParsesAs "$TraceCreation$" (fmap (:[]) pragmaTraceCreation) - (\e -> case e of - [PragmaTracing _ TraceCreation] -> True - _ -> False), - - checkParsesAs "$Comment[ \"this is a pragma with args\" ]$" (fmap (:[]) pragmaComment) + checkParseMatch "$Comment[ \"this is a pragma with args\" ]$" (fmap (:[]) pragmaComment) (\e -> case e of [PragmaComment _ "this is a pragma with args"] -> True _ -> False), - checkParsesAs "$ExprLookup[ \nMODULE_PATH /*comment*/\n ]$" (fmap (:[]) pragmaExprLookup) - (\e -> case e of - [PragmaExprLookup _ (MacroName "MODULE_PATH")] -> True - _ -> False), - - checkParsesAs "/*only comments*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly]) - (\e -> case e of - [] -> True - _ -> False), - - checkParsesAs "$ModuleOnly$ // comment" (parsePragmas [pragmaTestsOnly,pragmaModuleOnly]) - (\e -> case e of - [PragmaVisibility _ ModuleOnly] -> True - _ -> False), - - checkParsesAs "$TestsOnly$ /*comment*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly]) - (\e -> case e of - [PragmaVisibility _ TestsOnly] -> True - _ -> False), - - checkParsesAs "$TestsOnly$\n$TestsOnly$\n$ModuleOnly$" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly]) - (\e -> case e of - [PragmaVisibility _ TestsOnly, - PragmaVisibility _ TestsOnly, - PragmaVisibility _ ModuleOnly] -> True - _ -> False), - - checkParseError "$ModuleOnly[ extra ]$" "does not allow arguments" pragmaModuleOnly, - - checkParseError "$TestsOnly[ extra ]$" "does not allow arguments" pragmaTestsOnly, - - checkParseError "$Comment$" "requires arguments" pragmaComment, - - checkParseError "$ExprLookup[ \"bad stuff\" ]$" "macro name" pragmaExprLookup + checkParseError "$Comment$" "requires arguments" pragmaComment ] -checkParsesAs :: String -> TextParser [Pragma SourceContext] -> ([Pragma SourceContext] -> Bool) -> IO (TrackedErrors ()) -checkParsesAs s p m = return $ do - let parsed = readSingleWith p "(string)" s - check parsed - e <- parsed - when (not $ m e) $ - compilerErrorM $ "No match in '" ++ s ++ "':\n" ++ show e - where - check c - | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) - | otherwise = return () +data PragmaComment c = + PragmaComment { + pcContext :: [c], + pcComment :: String + } + deriving (Show) -checkParseError :: String -> String -> TextParser (Pragma SourceContext) -> IO (TrackedErrors ()) -checkParseError s m p = return $ do - let parsed = readSingleWith p "(string)" s - check parsed - where - check c - | isCompilerError c = do - let text = show (getCompilerError c) - when (not $ text =~ m) $ - compilerErrorM $ "Expected pattern " ++ show m ++ " in error output but got\n" ++ text - | otherwise = - compilerErrorM $ "Expected write failure but got\n" ++ show (getCompilerSuccess c) +pragmaComment :: TextParser (PragmaComment SourceContext) +pragmaComment = autoPragma "Comment" $ Right parseAt where + parseAt c = do + string_ "\"" + ss <- manyTill stringChar (string_ "\"") + optionalSpace + return $ PragmaComment [c] ss diff --git a/src/Test/Procedure.hs b/src/Test/Procedure.hs --- a/src/Test/Procedure.hs +++ b/src/Test/Procedure.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -24,7 +24,7 @@ import Base.CompilerError import Base.Positional import Base.TrackedErrors -import Parser.Procedure () +import Parser.Procedure import Parser.TextParser (SourceContext) import Test.Common import Types.Procedure @@ -406,7 +406,41 @@ checkParsesAs "1.2345E-4" (\e -> case e of (Literal (DecimalLiteral _ 12345 (-8))) -> True - _ -> False) + _ -> False), + + checkParseMatch "$NoTrace$" pragmaNoTrace + (\e -> case e of + PragmaTracing _ NoTrace -> True + _ -> False), + + checkParseMatch "$TraceCreation$" pragmaTraceCreation + (\e -> case e of + PragmaTracing _ TraceCreation -> True + _ -> False), + + checkParseMatch "$ReadOnly[foo,bar]$" pragmaReadOnly + (\e -> case e of + PragmaMarkVars _ ReadOnly [VariableName "foo", VariableName "bar"] -> True + _ -> False), + + checkParseMatch "$Hidden[foo,bar]$" pragmaHidden + (\e -> case e of + PragmaMarkVars _ Hidden [VariableName "foo", VariableName "bar"] -> True + _ -> False), + + checkParseMatch "$SourceContext$" pragmaSourceContext + (\e -> case e of + PragmaSourceContext _ -> True + _ -> False), + + checkParseMatch "$ExprLookup[ \nMODULE_PATH /*comment*/\n ]$" pragmaExprLookup + (\e -> case e of + PragmaExprLookup _ (MacroName "MODULE_PATH") -> True + _ -> False), + + checkParseError "$ExprLookup[ \"bad stuff\" ]$" "macro name" pragmaExprLookup, + checkParseError "$ReadOnly$" "requires arguments" pragmaReadOnly, + checkParseError "$Hidden$" "requires arguments" pragmaHidden ] checkParseSuccess :: String -> IO (TrackedErrors ()) diff --git a/src/Test/SourceFile.hs b/src/Test/SourceFile.hs --- a/src/Test/SourceFile.hs +++ b/src/Test/SourceFile.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -22,12 +22,48 @@ import Base.CompilerError import Base.TrackedErrors +import Parser.Pragma (parsePragmas) import Parser.SourceFile import Test.Common tests :: [IO (TrackedErrors ())] tests = [ + checkParseMatch "$ModuleOnly$" (fmap (:[]) pragmaModuleOnly) + (\e -> case e of + [PragmaVisibility _ ModuleOnly] -> True + _ -> False), + + checkParseMatch "$TestsOnly$" (fmap (:[]) pragmaTestsOnly) + (\e -> case e of + [PragmaVisibility _ TestsOnly] -> True + _ -> False), + + checkParseMatch "/*only comments*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly]) + (\e -> case e of + [] -> True + _ -> False), + + checkParseMatch "$ModuleOnly$ // comment" (parsePragmas [pragmaTestsOnly,pragmaModuleOnly]) + (\e -> case e of + [PragmaVisibility _ ModuleOnly] -> True + _ -> False), + + checkParseMatch "$TestsOnly$ /*comment*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly]) + (\e -> case e of + [PragmaVisibility _ TestsOnly] -> True + _ -> False), + + checkParseMatch "$TestsOnly$\n$TestsOnly$\n$ModuleOnly$" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly]) + (\e -> case e of + [PragmaVisibility _ TestsOnly, + PragmaVisibility _ TestsOnly, + PragmaVisibility _ ModuleOnly] -> True + _ -> False), + + checkParseError "$ModuleOnly[ extra ]$" "does not allow arguments" pragmaModuleOnly, + checkParseError "$TestsOnly[ extra ]$" "does not allow arguments" pragmaTestsOnly, + checkParseSuccess ("testfiles" "public.0rp") parsePublicSource, checkParseSuccess ("testfiles" "internal.0rx") parseInternalSource, checkParseSuccess ("testfiles" "test.0rt") parseTestSource diff --git a/src/Types/Builtin.hs b/src/Types/Builtin.hs --- a/src/Types/Builtin.hs +++ b/src/Types/Builtin.hs @@ -22,6 +22,7 @@ boolRequiredValue, charRequiredValue, defaultCategories, + defaultCategoryDeps, emptyValue, floatRequiredValue, formattedRequiredValue, @@ -30,6 +31,7 @@ ) where import qualified Data.Map as Map +import qualified Data.Set as Set import Types.TypeCategory import Types.TypeInstance @@ -37,6 +39,9 @@ defaultCategories :: CategoryMap c defaultCategories = Map.empty + +defaultCategoryDeps :: Set.Set CategoryName +defaultCategoryDeps = Set.fromList [BuiltinBool,BuiltinString,BuiltinChar,BuiltinInt,BuiltinFloat,BuiltinFormatted] boolRequiredValue :: ValueType boolRequiredValue = requiredSingleton BuiltinBool diff --git a/src/Types/DefinedCategory.hs b/src/Types/DefinedCategory.hs --- a/src/Types/DefinedCategory.hs +++ b/src/Types/DefinedCategory.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -21,6 +21,7 @@ module Types.DefinedCategory ( DefinedCategory(..), DefinedMember(..), + VariableRule(..), VariableValue(..), isInitialized, mapMembers, @@ -69,14 +70,29 @@ check Nothing = False check _ = True +data VariableRule c = + VariableDefault | + VariableReadOnly { + vroContext :: [c] + } | + VariableHidden { + vhContext :: [c] + } + data VariableValue c = VariableValue { vvContext :: [c], vvScope :: SymbolScope, vvType :: ValueType, - vvWritable :: Bool + vvReadOnlyAt :: VariableRule c } +instance Show c => Show (VariableValue c) where + show (VariableValue c _ t ro) = show t ++ formatFullContextBrace c ++ format ro where + format (VariableReadOnly c2) = " (read-only at " ++ formatFullContext c2 ++ ")" + format (VariableHidden c2) = " (hidden at " ++ formatFullContext c2 ++ ")" + format _ = "" + setInternalFunctions :: (Show c, CollectErrorsM m, TypeResolver r) => r -> AnyCategory c -> [ScopedFunction c] -> m (Map.Map FunctionName (ScopedFunction c)) @@ -158,7 +174,7 @@ formatFullContextBrace (dmContext m) ++ " is already defined" ++ formatFullContextBrace (vvContext m0) - return $ Map.insert (dmName m) (VariableValue (dmContext m) (dmScope m) (dmType m) True) ma' + return $ Map.insert (dmName m) (VariableValue (dmContext m) (dmScope m) (dmType m) VariableDefault) ma' -- TODO: Most of this duplicates parts of flattenAllConnections. mergeInternalInheritance :: (Show c, CollectErrorsM m) => diff --git a/src/Types/Pragma.hs b/src/Types/Pragma.hs deleted file mode 100644 --- a/src/Types/Pragma.hs +++ /dev/null @@ -1,124 +0,0 @@ -{- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry - -Licensed 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. ------------------------------------------------------------------------------ -} - --- Author: Kevin P. Barry [ta0kira@gmail.com] - -{-# LANGUAGE Safe #-} - -module Types.Pragma ( - CodeVisibility(..), - MacroName(..), - Pragma(..), - TraceType(..), - WithVisibility(..), - getPragmaContext, - hasCodeVisibility, - isExprLookup, - isModuleOnly, - isNoTrace, - isSourceContext, - isTestsOnly, - isTraceCreation, - mapCodeVisibility, - updateCodeVisibility, -) where - -import qualified Data.Set as Set - - -data CodeVisibility = ModuleOnly | TestsOnly | FromDependency deriving (Eq,Ord,Show) - -data WithVisibility a = - WithVisibility { - wvVisibility :: Set.Set CodeVisibility, - wvData :: a - } - deriving (Show) - -hasCodeVisibility :: CodeVisibility -> WithVisibility a -> Bool -hasCodeVisibility v = Set.member v . wvVisibility - -mapCodeVisibility :: (a -> b) -> WithVisibility a -> WithVisibility b -mapCodeVisibility f (WithVisibility v x) = WithVisibility v (f x) - -updateCodeVisibility :: (Set.Set CodeVisibility -> Set.Set CodeVisibility) -> - WithVisibility a -> WithVisibility a -updateCodeVisibility f (WithVisibility v x) = WithVisibility (f v) x - -data TraceType = NoTrace | TraceCreation deriving (Show) - -newtype MacroName = - MacroName { - mnName :: String - } - deriving (Eq,Ord) - -instance Show MacroName where - show = mnName - -data Pragma c = - PragmaVisibility { - pvContext :: [c], - pvScopes :: CodeVisibility - } | - PragmaExprLookup { - pelContext :: [c], - pelName :: MacroName - } | - PragmaSourceContext { - pscContext :: c - } | - PragmaTracing { - ptContext :: [c], - ptType :: TraceType - } | - -- This is mostly for testing purposes. - PragmaComment { - pcContext :: [c], - pcComment :: String - } - deriving (Show) - -getPragmaContext :: Pragma c -> [c] -getPragmaContext (PragmaVisibility c _) = c -getPragmaContext (PragmaExprLookup c _) = c -getPragmaContext (PragmaSourceContext c) = [c] -getPragmaContext (PragmaTracing c _) = c -getPragmaContext (PragmaComment c _) = c - -isModuleOnly :: Pragma c -> Bool -isModuleOnly (PragmaVisibility _ ModuleOnly) = True -isModuleOnly _ = False - -isExprLookup :: Pragma c -> Bool -isExprLookup (PragmaExprLookup _ _) = True -isExprLookup _ = False - -isSourceContext :: Pragma c -> Bool -isSourceContext (PragmaSourceContext _) = True -isSourceContext _ = False - -isNoTrace :: Pragma c -> Bool -isNoTrace (PragmaTracing _ NoTrace) = True -isNoTrace _ = False - -isTraceCreation :: Pragma c -> Bool -isTraceCreation (PragmaTracing _ TraceCreation) = True -isTraceCreation _ = False - -isTestsOnly :: Pragma c -> Bool -isTestsOnly (PragmaVisibility _ TestsOnly) = True -isTestsOnly _ = False diff --git a/src/Types/Procedure.hs b/src/Types/Procedure.hs --- a/src/Types/Procedure.hs +++ b/src/Types/Procedure.hs @@ -1,5 +1,5 @@ {- ----------------------------------------------------------------------------- -Copyright 2019-2020 Kevin P. Barry +Copyright 2019-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -30,13 +30,16 @@ IfElifElse(..), InputValue(..), InstanceOrInferred(..), + MacroName(..), Operator(..), OutputValue(..), + PragmaProcedure(..), Procedure(..), ReturnValues(..), ScopedBlock(..), Statement(..), TestProcedure(..), + TraceType(..), ValueLiteral(..), ValueOperation(..), VariableName(..), @@ -50,6 +53,8 @@ isDiscardedInput, isFunctionOperator, isLiteralCategory, + isNoTrace, + isTraceCreation, isRawCodeLine, isUnnamedReturns, ) where @@ -57,7 +62,6 @@ import Data.List (intercalate) import Base.Positional -import Types.Pragma import Types.TypeCategory import Types.TypeInstance @@ -67,7 +71,7 @@ data ExecutableProcedure c = ExecutableProcedure { epContext :: [c], - epPragmas :: [Pragma c], + epPragmas :: [PragmaProcedure c], epEnd :: [c], epName :: FunctionName, epArgs :: ArgValues c, @@ -165,6 +169,8 @@ IgnoreValues [c] (Expression c) | Assignment [c] (Positional (Assignable c)) (Expression c) | NoValueExpression [c] (VoidExpression c) | + MarkReadOnly [c] [VariableName] | + MarkHidden [c] [VariableName] | RawCodeLine String deriving (Show) @@ -181,6 +187,8 @@ getStatementContext (IgnoreValues c _) = c getStatementContext (Assignment c _ _) = c getStatementContext (NoValueExpression c _) = c +getStatementContext (MarkReadOnly c _) = c +getStatementContext (MarkHidden c _) = c getStatementContext (RawCodeLine _) = [] data Assignable c = @@ -308,3 +316,29 @@ ConvertedCall [c] TypeInstance (FunctionCall c) | ValueCall [c] (FunctionCall c) deriving (Show) + +newtype MacroName = + MacroName { + mnName :: String + } + deriving (Eq,Ord) + +instance Show MacroName where + show = mnName + +data TraceType = NoTrace | TraceCreation deriving (Show) + +data PragmaProcedure c = + PragmaTracing { + ptContext :: [c], + ptType :: TraceType + } + deriving (Show) + +isNoTrace :: PragmaProcedure c -> Bool +isNoTrace (PragmaTracing _ NoTrace) = True +isNoTrace _ = False + +isTraceCreation :: PragmaProcedure c -> Bool +isTraceCreation (PragmaTracing _ TraceCreation) = True +isTraceCreation _ = False diff --git a/tests/cli-tests.sh b/tests/cli-tests.sh --- a/tests/cli-tests.sh +++ b/tests/cli-tests.sh @@ -75,7 +75,7 @@ test_tests_only() { local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/tests-only -f || true) - if ! echo "$output" | egrep -q 'Definition for Type1 .+ visible category'; then + if ! echo "$output" | egrep -q 'Type1 .+ visible category'; then show_message 'Expected Type1 definition error from tests/tests-only:' echo "$output" 1>&2 return 1 @@ -108,6 +108,26 @@ } +test_tests_only4() { + local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/tests-only4 -f || true) + if ! echo "$output" | egrep -q 'Type2 .+ \$TestsOnly\$'; then + show_message 'Expected Type2 import error from tests/tests-only4:' + echo "$output" 1>&2 + return 1 + fi + if ! echo "$output" | egrep -q 'In compilation of .+/source2\.cpp'; then + show_message 'Expected source2.cpp import error from tests/tests-only4:' + echo "$output" 1>&2 + return 1 + fi + if echo "$output" | egrep -q 'In compilation of .+/source1\.cpp'; then + show_message 'Unexpected source1.cpp import error from tests/tests-only4:' + echo "$output" 1>&2 + return 1 + fi +} + + test_module_only() { local output=$(do_zeolite -p "$ZEOLITE_PATH" -R tests/module-only -f || true) if ! echo "$output" | egrep -q 'Type1 not found'; then @@ -185,7 +205,7 @@ test_templates() { - execute rm -f $ZEOLITE_PATH/tests/templates/Category_Templated.cpp + execute rm -f $ZEOLITE_PATH/tests/templates/Extension_Templated.cpp do_zeolite -p "$ZEOLITE_PATH" --templates tests/templates do_zeolite -p "$ZEOLITE_PATH" -r tests/templates do_zeolite -p "$ZEOLITE_PATH" -t tests/templates @@ -342,6 +362,7 @@ test_tests_only test_tests_only2 test_tests_only3 + test_tests_only4 test_module_only test_module_only2 test_module_only3 diff --git a/tests/internal-inheritance.0rt b/tests/internal-inheritance.0rt --- a/tests/internal-inheritance.0rt +++ b/tests/internal-inheritance.0rt @@ -92,7 +92,29 @@ } -testcase "internal define is private" { +testcase "internal define links properly for dispatching" { + success +} + +unittest test {} + +concrete Value {} + +define Value { + refines Formatted + defines Equals + + formatted () { + return "Value" + } + + equals (_,_) { + return true + } +} + + +testcase "internal define is visible privately" { success } diff --git a/tests/local-rules.0rt b/tests/local-rules.0rt new file mode 100644 --- /dev/null +++ b/tests/local-rules.0rt @@ -0,0 +1,258 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +testcase "ReadOnly causes error" { + error + require "foo.+read-only" +} + +unittest test { + Int foo <- 1 + scoped { + } in { + $ReadOnly[foo]$ + foo <- 2 + } +} + + +testcase "ReadOnly with bad variable name" { + error + require "foo.+not defined" +} + +unittest test { + $ReadOnly[foo]$ +} + + +testcase "ReadOnly is scoped" { + success +} + +unittest test { + Int foo <- 1 + scoped { + } in { + $ReadOnly[foo]$ + } + foo <- 2 + \ Testing.checkEquals(foo,2) +} + + +testcase "ReadOnly is passed to nested scope" { + error + require "foo.+read-only" +} + +unittest test { + Int foo <- 1 + $ReadOnly[foo]$ + if (true) { + foo <- 2 + } +} + + +testcase "ReadOnly is idempotent" { + success +} + +unittest test { + Int foo <- 1 + scoped { + } in { + $ReadOnly[foo]$ + $ReadOnly[foo]$ + } + foo <- 2 + \ Testing.checkEquals(foo,2) +} + + +testcase "ReadOnly respects order" { + success +} + +unittest test { + Int foo <- 1 + scoped { + } in { + foo <- 2 + $ReadOnly[foo]$ + } + \ Testing.checkEquals(foo,2) + foo <- 3 + \ Testing.checkEquals(foo,3) +} + + +testcase "ReadOnly with member" { + error + require "foo.+read-only" +} + +unittest test { + \ Value.test() +} + +concrete Value { + @type test () -> () +} + +define Value { + @category Int foo <- 1 + + test () { + $ReadOnly[foo]$ + foo <- 2 + } +} + + +testcase "ReadOnly in while does not affect update" { + success +} + +unittest test { + scoped { + Int foo <- 0 + } in while (foo < 10) { + $ReadOnly[foo]$ + continue + } update { + foo <- foo+1 + } +} + + +testcase "ReadOnly in scoped does not affect cleanup" { + success +} + +unittest test { + Int foo <- 1 + cleanup { + foo <- 2 + } in $ReadOnly[foo]$ + \ Testing.checkEquals(foo,2) +} + + +testcase "Hidden causes error" { + error + require "foo.+hidden" +} + +unittest test { + Int foo <- 1 + scoped { + } in { + $Hidden[foo]$ + \ foo + } +} + + +testcase "Hidden is scoped" { + success +} + +unittest test { + Int foo <- 1 + scoped { + } in { + $Hidden[foo]$ + } + foo <- 2 + \ Testing.checkEquals(foo,2) +} + + +testcase "Hidden is passed to nested scope" { + error + require "foo.+hidden" +} + +unittest test { + Int foo <- 1 + $Hidden[foo]$ + if (true) { + foo <- 2 + } +} + + +testcase "Hidden is not idempotent" { + error + require "foo.+hidden" +} + +unittest test { + Int foo <- 1 + scoped { + } in { + $Hidden[foo]$ + $Hidden[foo]$ + } +} + + +testcase "ReadOnly cannot be applied to Hidden" { + error + require "foo.+hidden" +} + +unittest test { + Int foo <- 1 + scoped { + } in { + $Hidden[foo]$ + $ReadOnly[foo]$ + } +} + + +testcase "Hidden respects order" { + success +} + +unittest test { + Int foo <- 1 + scoped { + } in { + foo <- 2 + $Hidden[foo]$ + } + \ Testing.checkEquals(foo,2) + foo <- 3 + \ Testing.checkEquals(foo,3) +} + + +testcase "Hidden does not allow reusing a variable name" { + error + require "foo.+already defined" +} + +unittest test { + Int foo <- 1 + $Hidden[foo]$ + Int foo <- 1 +} diff --git a/tests/module-only3/README.md b/tests/module-only3/README.md --- a/tests/module-only3/README.md +++ b/tests/module-only3/README.md @@ -18,7 +18,6 @@ ^~~~~~~~~~~~~~~~~~~~ 1 error generated. Execution of /usr/bin/clang++ failed - ``` Importantly, there *should not* be any errors related to `Type2`; only `Type1`. diff --git a/tests/module-only4/common-source.cpp b/tests/module-only4/common-source.cpp --- a/tests/module-only4/common-source.cpp +++ b/tests/module-only4/common-source.cpp @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -17,6 +17,8 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] #include "category-source.hpp" +#include "Streamlined_Type1.hpp" +#include "Streamlined_Type3.hpp" #include "Category_Formatted.hpp" #include "Category_String.hpp" #include "Category_Type1.hpp" @@ -27,135 +29,43 @@ namespace ZEOLITE_PRIVATE_NAMESPACE { #endif // ZEOLITE_PRIVATE_NAMESPACE -namespace { - -const int collection_Type1 = 0; -} // namespace - -const void* const Functions_Type1 = &collection_Type1; -const TypeFunction& Function_Type1_create = (*new TypeFunction{ 0, 0, 1, "Type1", "create", Functions_Type1, 0 }); -const ValueFunction& Function_Type1_get = (*new ValueFunction{ 0, 0, 1, "Type1", "get", Functions_Type1, 0 }); - -namespace { - -class Category_Type1; -class Type_Type1; -S CreateType_Type1(Params<0>::Type params); -class Value_Type1; -S CreateValue_Type1(Type_Type1& parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_Type1(S parent, const ParamTuple& params, const ValueTuple& args); -struct Category_Type1 : public TypeCategory { - std::string CategoryName() const final { return "Type1"; } - Category_Type1() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Type1 (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_Type1::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } +struct ExtCategory_Type1 : public Category_Type1 { }; -Category_Type1& CreateCategory_Type1() { - static auto& category = *new Category_Type1(); - return category; -} +struct ExtType_Type1 : public Type_Type1 { + inline ExtType_Type1(Category_Type1& p, Params<0>::Type params) : Type_Type1(p, params) {} -struct Type_Type1 : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_Type1& parent; - bool CanConvertFrom(const S& from) const final { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_Type1()) { - args = std::vector>{}; - return true; - } - return false; - } - Type_Type1(Category_Type1& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Type1 (init @type)") - } - ReturnTuple Dispatch(const S& self, const TypeFunction& label, - const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_Type1::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_Type1[] = { - &Type_Type1::Call_create, - }; - if (label.collection == Functions_Type1) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Type1[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); + ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type1.create") + return ReturnTuple(CreateValue_Type1(CreateType_Type1(Params<0>::Type()), ParamTuple(), + TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); } - ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args); }; -S CreateType_Type1(Params<0>::Type params) { - static const auto cached = S_get(new Type_Type1(CreateCategory_Type1(), Params<0>::Type())); - return cached; -} - -struct Value_Type1 : public TypeValue { - Value_Type1(Type_Type1& p, const ParamTuple& params, const ValueTuple& args) - : parent(p), value(args.Only()) {} +struct ExtValue_Type1 : public Value_Type1 { + inline ExtValue_Type1(S p, const ParamTuple& params, const ValueTuple& args) + : Value_Type1(p, params), value(args.At(0)) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_Type1::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_Type1[] = { - &Value_Type1::Call_get, - }; - if (label.collection == Functions_Type1) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Type1[label.function_num])(self, params, args); - } - return TypeValue::Dispatch(self, label, params, args); + ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type1.get") + return ReturnTuple(TypeValue::Call(value, Function_Type2_get, ParamTuple(), ArgTuple())); } - std::string CategoryName() const final { return parent.CategoryName(); } - ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_Type1& parent; + const S value; }; -S CreateValue_Type1(Type_Type1& parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Value_Type1(parent, params, args)); -} - -ReturnTuple Type_Type1::Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Type1.create") - return ReturnTuple(CreateValue_Type1(*this, ParamTuple(), - TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); -} - -ReturnTuple Value_Type1::Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Type1.get") - return ReturnTuple(TypeValue::Call(value, Function_Type2_get, ParamTuple(), ArgTuple())); +Category_Type1& CreateCategory_Type1() { + static auto& category = *new ExtCategory_Type1(); + return category; } - -} // namespace - -TypeCategory& GetCategory_Type1() { - return CreateCategory_Type1(); +S CreateType_Type1(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_Type1(CreateCategory_Type1(), Params<0>::Type())); + return cached; } - -S GetType_Type1(Params<0>::Type params) { - return CreateType_Type1(params); +S CreateValue_Type1(S parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new ExtValue_Type1(parent, params, args)); } #ifdef ZEOLITE_PRIVATE_NAMESPACE @@ -168,135 +78,43 @@ namespace ZEOLITE_PUBLIC_NAMESPACE { #endif // ZEOLITE_PUBLIC_NAMESPACE -namespace { - -const int collection_Type3 = 0; -} // namespace - -const void* const Functions_Type3 = &collection_Type3; -const TypeFunction& Function_Type3_create = (*new TypeFunction{ 0, 0, 1, "Type3", "create", Functions_Type3, 0 }); -const ValueFunction& Function_Type3_get = (*new ValueFunction{ 0, 0, 1, "Type3", "get", Functions_Type3, 0 }); - -namespace { - -class Category_Type3; -class Type_Type3; -S CreateType_Type3(Params<0>::Type params); -class Value_Type3; -S CreateValue_Type3(Type_Type3& parent, const ParamTuple& params, const ValueTuple& args); +S CreateValue_Type3(S parent, const ParamTuple& params, const ValueTuple& args); -struct Category_Type3 : public TypeCategory { - std::string CategoryName() const final { return "Type3"; } - Category_Type3() { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Type3 (init @category)") - } - ReturnTuple Dispatch(const CategoryFunction& label, const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Category_Type3::*)(const ParamTuple&, const ValueTuple&); - return TypeCategory::Dispatch(label, params, args); - } +struct ExtCategory_Type3 : public Category_Type3 { }; -Category_Type3& CreateCategory_Type3() { - static auto& category = *new Category_Type3(); - return category; -} +struct ExtType_Type3 : public Type_Type3 { + inline ExtType_Type3(Category_Type3& p, Params<0>::Type params) : Type_Type3(p, params) {} -struct Type_Type3 : public TypeInstance { - std::string CategoryName() const final { return parent.CategoryName(); } - void BuildTypeName(std::ostream& output) const final { - return TypeInstance::TypeNameFrom(output, parent); - } - Category_Type3& parent; - bool CanConvertFrom(const S& from) const final { - std::vector> args; - if (!from->TypeArgsForParent(parent, args)) return false; - if(args.size() != 0) { - FAIL() << "Wrong number of args (" << args.size() << ") for " << CategoryName(); - } - return true; - } - bool TypeArgsForParent(const TypeCategory& category, std::vector>& args) const final { - if (&category == &GetCategory_Type3()) { - args = std::vector>{}; - return true; - } - return false; - } - Type_Type3(Category_Type3& p, Params<0>::Type params) : parent(p) { - CycleCheck::Check(); - CycleCheck marker(*this); - TRACE_FUNCTION("Type3 (init @type)") - } - ReturnTuple Dispatch(const S& self, const TypeFunction& label, - const ParamTuple& params, const ValueTuple& args) final { - using CallType = ReturnTuple(Type_Type3::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_Type3[] = { - &Type_Type3::Call_create, - }; - if (label.collection == Functions_Type3) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Type3[label.function_num])(self, params, args); - } - return TypeInstance::Dispatch(self, label, params, args); + ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type3.create") + return ReturnTuple(CreateValue_Type3(CreateType_Type3(Params<0>::Type()), ParamTuple(), + TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); } - ReturnTuple Call_create(const S& self, const ParamTuple& params, const ValueTuple& args); }; -S CreateType_Type3(Params<0>::Type params) { - static const auto cached = S_get(new Type_Type3(CreateCategory_Type3(), Params<0>::Type())); - return cached; -} - -struct Value_Type3 : public TypeValue { - Value_Type3(Type_Type3& p, const ParamTuple& params, const ValueTuple& args) - : parent(p), value(args.Only()) {} +struct ExtValue_Type3 : public Value_Type3 { + inline ExtValue_Type3(S p, const ParamTuple& params, const ValueTuple& args) + : Value_Type3(p, params), value(args.At(0)) {} - ReturnTuple Dispatch(const S& self, const ValueFunction& label, const ParamTuple& params,const ValueTuple& args) final { - using CallType = ReturnTuple(Value_Type3::*)(const S&, const ParamTuple&, const ValueTuple&); - static const CallType Table_Type3[] = { - &Value_Type3::Call_get, - }; - if (label.collection == Functions_Type3) { - if (label.function_num < 0 || label.function_num >= 1) { - FAIL() << "Bad function call " << label; - } - return (this->*Table_Type3[label.function_num])(self, params, args); - } - return TypeValue::Dispatch(self, label, params, args); + ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { + TRACE_FUNCTION("Type3.get") + return ReturnTuple(TypeValue::Call(value, Function_Type2_get, ParamTuple(), ArgTuple())); } - std::string CategoryName() const final { return parent.CategoryName(); } - ReturnTuple Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args); - Type_Type3& parent; + const S value; }; -S CreateValue_Type3(Type_Type3& parent, const ParamTuple& params, const ValueTuple& args) { - return S_get(new Value_Type3(parent, params, args)); -} - -ReturnTuple Type_Type3::Call_create(const S& self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Type3.create") - return ReturnTuple(CreateValue_Type3(*this, ParamTuple(), - TypeInstance::Call(GetType_Type2(Params<0>::Type()), Function_Type2_create, ParamTuple(), ArgTuple()))); -} - -ReturnTuple Value_Type3::Call_get(const S& Var_self, const ParamTuple& params, const ValueTuple& args) { - TRACE_FUNCTION("Type3.get") - return ReturnTuple(TypeValue::Call(value, Function_Type2_get, ParamTuple(), ArgTuple())); +Category_Type3& CreateCategory_Type3() { + static auto& category = *new ExtCategory_Type3(); + return category; } - -} // namespace - -TypeCategory& GetCategory_Type3() { - return CreateCategory_Type3(); +S CreateType_Type3(Params<0>::Type params) { + static const auto cached = S_get(new ExtType_Type3(CreateCategory_Type3(), Params<0>::Type())); + return cached; } - -S GetType_Type3(Params<0>::Type params) { - return CreateType_Type3(params); +S CreateValue_Type3(S parent, const ParamTuple& params, const ValueTuple& args) { + return S_get(new ExtValue_Type3(parent, params, args)); } #ifdef ZEOLITE_PUBLIC_NAMESPACE diff --git a/tests/reduce.0rt b/tests/reduce.0rt --- a/tests/reduce.0rt +++ b/tests/reduce.0rt @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry +Copyright 2020-2021 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. @@ -755,4 +755,53 @@ create () { return Value{ } } +} + + +testcase "partial matches in nested types" { + success +} + +@value interface A {} +@value interface B {} +@value interface C {} + +concrete AB { + refines A + refines B + @type create () -> (AB) +} + +define AB { + create () { return AB{ } } +} + +concrete AC { + refines A + refines C + @type create () -> (AC) +} + +define AC { + create () { return AC{ } } +} + +unittest leftNestedInRight { + \ Testing.checkEquals(present(reduce<[A&B],[[A&B]|C]>(AB.create())),true) +} + +unittest rightNestedInLeft { + \ Testing.checkEquals(present(reduce<[[A|B]&C],[A|B]>(AC.create())),true) +} + +unittest unionToUnion { + \ Testing.checkEquals(present(reduce<[[A&B]|C],[[A&B]|C]>(AB.create())),true) +} + +unittest intersectToIntersect { + \ Testing.checkEquals(present(reduce<[[A|B]&C],[[A|B]&C]>(AC.create())),true) +} + +unittest unionToIntersect { + \ Testing.checkEquals(present(reduce<[A|B],[A&B]>(AB.create())),false) } diff --git a/tests/simple.0rt b/tests/simple.0rt --- a/tests/simple.0rt +++ b/tests/simple.0rt @@ -89,6 +89,17 @@ define String {} +testcase "attempt to define interface" { + error + require "Type" + require "concrete" +} + +@value interface Type {} + +define Type {} + + testcase "no deadlock with recursive type" { success } diff --git a/tests/templates/.zeolite-module b/tests/templates/.zeolite-module --- a/tests/templates/.zeolite-module +++ b/tests/templates/.zeolite-module @@ -2,7 +2,7 @@ path: "tests/templates" extra_files: [ category_source { - source: "tests/templates/Category_Templated.cpp" + source: "tests/templates/Extension_Templated.cpp" categories: [Templated] } ] diff --git a/tests/templates/README.md b/tests/templates/README.md --- a/tests/templates/README.md +++ b/tests/templates/README.md @@ -6,10 +6,10 @@ ```shell ZEOLITE_PATH=$(zeolite --get-path) -rm -f $ZEOLITE_PATH/tests/templates/Category_Templated.cpp # Remove the old template. -zeolite -p $ZEOLITE_PATH --templates tests/templates # Create a new template. -zeolite -p $ZEOLITE_PATH -r tests/templates # Recompile. -zeolite -p $ZEOLITE_PATH -t tests/templates # Run the test. +rm -f $ZEOLITE_PATH/tests/templates/Extension_Templated.cpp # Remove the old template. +zeolite -p $ZEOLITE_PATH --templates tests/templates # Create a new template. +zeolite -p $ZEOLITE_PATH -r tests/templates # Recompile. +zeolite -p $ZEOLITE_PATH -t tests/templates # Run the test. ``` The most important step above is to delete the *old* template first. diff --git a/tests/tests-only4/.zeolite-module b/tests/tests-only4/.zeolite-module new file mode 100644 --- /dev/null +++ b/tests/tests-only4/.zeolite-module @@ -0,0 +1,13 @@ +root: "../.." +path: "tests/tests-only4" +extra_files: [ + category_source { + source: "tests/tests-only4/source1.cpp" + categories: [Type1] + } + category_source { + source: "tests/tests-only4/source2.cpp" + categories: [Type3] + } +] +mode: incremental {} diff --git a/tests/tests-only4/README.md b/tests/tests-only4/README.md new file mode 100644 --- /dev/null +++ b/tests/tests-only4/README.md @@ -0,0 +1,25 @@ +# `$TestsOnly$` Pragma Test - Enforcement in C++ + +Compiling this module should **always fail**. It tests that the `$TestsOnly$` +pragma is enforced even in C++ source files. + +To compile: + +```shell +ZEOLITE_PATH=$(zeolite --get-path) +zeolite -p $ZEOLITE_PATH -R tests/tests-only4 +``` + +The compiler errors should look something like this: + +```text +In file included from tests/tests-only4/source2.cpp:20: +Category_Type2.hpp:4:2: error: Category Type2 can only be used by $TestsOnly$ categories +#error Category Type2 can only be used by $TestsOnly$ categories + ^ +1 error generated. +Execution of /usr/bin/clang++ failed +``` + +Importantly, there *should not* be any errors related to `source1.cpp`; only +`source2.cpp`. diff --git a/tests/tests-only4/normal.0rp b/tests/tests-only4/normal.0rp new file mode 100644 --- /dev/null +++ b/tests/tests-only4/normal.0rp @@ -0,0 +1,19 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +concrete Type3 {} diff --git a/tests/tests-only4/source1.cpp b/tests/tests-only4/source1.cpp new file mode 100644 --- /dev/null +++ b/tests/tests-only4/source1.cpp @@ -0,0 +1,20 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "Streamlined_Type1.hpp" // $TestsOnly$ +#include "Category_Type2.hpp" diff --git a/tests/tests-only4/source2.cpp b/tests/tests-only4/source2.cpp new file mode 100644 --- /dev/null +++ b/tests/tests-only4/source2.cpp @@ -0,0 +1,20 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +#include "Streamlined_Type3.hpp" // NOT $TestsOnly$ +#include "Category_Type2.hpp" diff --git a/tests/tests-only4/testing.0rp b/tests/tests-only4/testing.0rp new file mode 100644 --- /dev/null +++ b/tests/tests-only4/testing.0rp @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- +Copyright 2021 Kevin P. Barry + +Licensed 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. +----------------------------------------------------------------------------- */ + +// Author: Kevin P. Barry [ta0kira@gmail.com] + +$TestsOnly$ + +concrete Type1 {} + +@value interface Type2 {} diff --git a/zeolite-lang.cabal b/zeolite-lang.cabal --- a/zeolite-lang.cabal +++ b/zeolite-lang.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: zeolite-lang -version: 0.12.0.0 +version: 0.13.0.0 synopsis: Zeolite is a statically-typed, general-purpose programming language. description: @@ -49,7 +49,7 @@ license-file: LICENSE author: Kevin P. Barry maintainer: Kevin P. Barry -copyright: (c) Kevin P. Barry 2019-2020 +copyright: (c) Kevin P. Barry 2019-2021 category: Compiler build-type: Simple @@ -93,7 +93,6 @@ lib/math/*.0rp, lib/math/*.0rt, lib/math/*.cpp, - lib/math/*.hpp, lib/testing/.zeolite-module, lib/testing/*.0rp, lib/testing/*.0rt, @@ -148,6 +147,10 @@ tests/tests-only3/.zeolite-module, tests/tests-only3/*.0rp, tests/tests-only3/*.0rx, + tests/tests-only4/README.md, + tests/tests-only4/.zeolite-module, + tests/tests-only4/*.cpp, + tests/tests-only4/*.0rp, tests/visibility/.zeolite-module, tests/visibility/*.0rp, tests/visibility/*.0rx, @@ -195,9 +198,10 @@ Compilation.CompilerState, Compilation.ProcedureContext, Compilation.ScopeContext, - CompilerCxx.Category, CompilerCxx.CategoryContext, CompilerCxx.Code, + CompilerCxx.CxxFiles, + CompilerCxx.LanguageModule, CompilerCxx.Naming, CompilerCxx.Procedure, Config.LoadConfig, @@ -231,7 +235,6 @@ Types.DefinedCategory, Types.Function, Types.IntegrationTest, - Types.Pragma, Types.Procedure, Types.TypeCategory, Types.TypeInstance, @@ -259,6 +262,8 @@ filepath >= 1.0 && < 1.5, hashable >= 1.0 && < 1.4, megaparsec >= 7.0 && < 9.1, + microlens >= 0.4.9 && < 0.5, + microlens-th >= 0.1.0.0 && < 0.5, mtl >= 1.0 && < 2.3, parser-combinators >= 0.2 && < 2.0, regex-tdfa >= 1.0 && < 1.4,