From 3501d56a7945ce8fa67e01f7e70562c950e98e78 Mon Sep 17 00:00:00 2001 From: mike lowis Date: Thu, 8 Apr 2021 19:46:22 -0400 Subject: [PATCH 1/1] initial commit --- COPYING | 674 ++ README | 65 + VERSION | 1 + bin/micb | 279 + bin/micb-includes | 61 + bin/obnc-path-test | 46 + bin/obnc-test | 114 + bin/obncdoc-extract | 361 + bin/obncdoc-index | 43 + bin/obncdoc-markup | 85 + bin/obncdoc-test | 47 + build | 323 + install | 225 + lib/obnc/Files.c | 768 +++ lib/obnc/Files.obn | 170 + lib/obnc/FilesTest.obn | 453 ++ lib/obnc/In.c | 196 + lib/obnc/In.obn | 61 + lib/obnc/InTest.obn | 80 + lib/obnc/InTest.sh | 35 + lib/obnc/Input.c | 136 + lib/obnc/Input.env | 2 + lib/obnc/Input.obn | 42 + lib/obnc/Input0.c | 220 + lib/obnc/Input0.obn | 30 + lib/obnc/Input0Test.obn | 71 + lib/obnc/Input0Test.sh | 22 + lib/obnc/InputTest.obn | 102 + lib/obnc/InputTest.sh | 39 + lib/obnc/LICENSE | 373 + lib/obnc/Math.c | 148 + lib/obnc/Math.env | 1 + lib/obnc/Math.obn | 132 + lib/obnc/MathTest.obn | 94 + lib/obnc/OBNC.c | 234 + lib/obnc/OBNC.env | 1 + lib/obnc/OBNC.h | 338 + lib/obnc/OBNCTest.c | 236 + lib/obnc/Out.c | 62 + lib/obnc/Out.obn | 48 + lib/obnc/OutTest.obn | 41 + lib/obnc/OutTest.sh | 91 + lib/obnc/Strings.obn | 164 + lib/obnc/StringsTest.obn | 117 + lib/obnc/XYplane.c | 212 + lib/obnc/XYplane.env | 2 + lib/obnc/XYplane.obn | 85 + lib/obnc/XYplaneTest.obn | 92 + lib/obnc/obncdoc/Files.def | 99 + lib/obnc/obncdoc/Files.def.html | 114 + lib/obnc/obncdoc/FilesTest.def | 2 + lib/obnc/obncdoc/FilesTest.def.html | 17 + lib/obnc/obncdoc/In.def | 40 + lib/obnc/obncdoc/In.def.html | 55 + lib/obnc/obncdoc/InTest.def | 2 + lib/obnc/obncdoc/InTest.def.html | 17 + lib/obnc/obncdoc/Input.def | 23 + lib/obnc/obncdoc/Input.def.html | 38 + lib/obnc/obncdoc/Input0.def | 17 + lib/obnc/obncdoc/Input0.def.html | 32 + lib/obnc/obncdoc/Input0Test.def | 2 + lib/obnc/obncdoc/Input0Test.def.html | 17 + lib/obnc/obncdoc/InputTest.def | 2 + lib/obnc/obncdoc/InputTest.def.html | 17 + lib/obnc/obncdoc/Math.def | 67 + lib/obnc/obncdoc/Math.def.html | 82 + lib/obnc/obncdoc/MathTest.def | 2 + lib/obnc/obncdoc/MathTest.def.html | 17 + lib/obnc/obncdoc/Out.def | 27 + lib/obnc/obncdoc/Out.def.html | 42 + lib/obnc/obncdoc/OutTest.def | 2 + lib/obnc/obncdoc/OutTest.def.html | 17 + lib/obnc/obncdoc/Strings.def | 30 + lib/obnc/obncdoc/Strings.def.html | 45 + lib/obnc/obncdoc/StringsTest.def | 2 + lib/obnc/obncdoc/StringsTest.def.html | 17 + lib/obnc/obncdoc/XYplane.def | 62 + lib/obnc/obncdoc/XYplane.def.html | 77 + lib/obnc/obncdoc/XYplaneTest.def | 2 + lib/obnc/obncdoc/XYplaneTest.def.html | 17 + lib/obnc/obncdoc/index.html | 23 + lib/obnc/obncdoc/style.css | 35 + share/doc/obnc/oberon-report.html | 1671 +++++ share/man/man1/obnc-compile.1 | 61 + share/man/man1/obnc-path.1 | 35 + share/man/man1/obnc.1 | 150 + share/man/man1/obncdoc.1 | 29 + share/obnc/style.css | 35 + src/Config.c | 63 + src/Error.c | 59 + src/Error.h | 29 + src/Files.c | 186 + src/Files.h | 47 + src/Generate.c | 3035 +++++++++ src/Generate.h | 51 + src/Maps.c | 120 + src/Maps.h | 38 + src/MapsTest.c | 89 + src/ModulePaths.c | 214 + src/ModulePaths.h | 27 + src/Oberon.h | 33 + src/Oberon.l | 224 + src/Oberon.y | 4128 +++++++++++ src/Paths.c | 114 + src/Paths.h | 33 + src/Range.c | 181 + src/Range.h | 51 + src/StackTrace.c | 28 + src/StackTrace.h | 27 + src/StackTraceLinux.c | 125 + src/Table.c | 1325 ++++ src/Table.h | 46 + src/TableTest.c | 151 + src/Time.c | 69 + src/Time.h | 23 + src/Trees.c | 830 +++ src/Trees.h | 201 + src/Types.c | 811 +++ src/Types.h | 124 + src/Util.c | 128 + src/Util.env | 1 + src/Util.h | 59 + src/UtilTest.c | 37 + src/lex.yy.c | 2027 ++++++ src/lex.yy.h | 472 ++ src/lex.yyTest.c | 179 + src/obnc-compile.c | 140 + src/obnc-path.c | 128 + src/obnc.c | 916 +++ src/obncdoc.c | 389 ++ src/y.tab.c | 6014 +++++++++++++++++ src/y.tab.h | 168 + test | 95 + tests/obnc/failing-at-compile-time/A.obn | 28 + tests/obnc/failing-at-compile-time/B.obn | 19 + .../T0UnterminatedComment.obn | 22 + .../T2PointerToNonRecord.obn | 23 + .../T2RecursiveRecord.obn | 25 + .../T2RedeclaredField.obn | 29 + .../T2RepeatedParameterIdent.obn | 23 + .../T2SelfDeclaration.obn | 22 + .../T2SelfReferringBaseType.obn | 24 + .../T2UnresolvedAnonType.obn | 23 + .../T2UnresolvedType.obn | 23 + .../T2WrongResolvedType.obn | 24 + .../T3RepeatedField.obn | 25 + .../failing-at-compile-time/T3RepeatedVar.obn | 23 + .../T4InvalidPointerComparison.obn | 26 + .../T4InvalidProcedureComparison.obn | 28 + .../T4NegativeSetElement.obn | 23 + .../T4SelectorOnConstant.obn | 24 + .../T4TypeGuardOnNonVarParamRecord.obn | 28 + .../T5AssignPredefinedProcedure.obn | 24 + .../T5AssignToImportedVariable.obn | 24 + .../T5FunctionProcedureStatement.obn | 26 + .../T5InvalidArrayAssignment.obn | 27 + .../T5NonConstForLoopInc.obn | 24 + .../T5PointerVarParamExt.obn | 32 + .../T5StringAssignment.obn | 24 + .../T5StructValueParamAssignment.obn | 28 + .../T6ExtendedPointerVarParam.obn | 35 + .../T6ForgottenReturnType.obn | 27 + .../T6LocalParamTypeRef.obn | 28 + .../T6NonScalarResultType.obn | 28 + .../T6ReadOnlyParam.obn | 29 + .../T7AccessNonExportedField.obn | 27 + .../T7ActualVarParamImported.obn | 27 + .../T7ActualVarParamImported1.obn | 24 + .../T7ExportLocalIdent.obn | 24 + .../T7ImportDuplicate.obn | 20 + .../T7ImportDuplicateWithAlias.obn | 22 + .../T7ImportLibraryLocal.obn | 22 + .../T7ImportNonExisting.obn | 22 + .../T7ImportRedeclaration.obn | 24 + .../T7ImportRedeclarationAlias.obn | 24 + .../failing-at-compile-time/T7ImportSelf.obn | 20 + .../T7ImportSelfWithAlias.obn | 20 + .../T7ImportWithDuplicateAlias.obn | 20 + .../T7ModuleIdentifierNonMatch.obn | 19 + .../failing-at-compile-time/lib/Local.obn | 19 + .../failing-at-runtime/T4FailingTypeGuard.obn | 37 + .../T5AssignStringToOpenArray.obn | 30 + .../failing-at-runtime/T5CallNilProcedure.obn | 26 + .../T5OpenArrayAssignment.obn | 30 + .../T5RecordVarParamAssignment.obn | 35 + tests/obnc/passing/A.obn | 105 + tests/obnc/passing/B.obn | 32 + tests/obnc/passing/C.obn | 24 + tests/obnc/passing/D.obn | 22 + tests/obnc/passing/OBNC.obn | 37 + tests/obnc/passing/T1ConstantDeclarations.obn | 66 + tests/obnc/passing/T2TypeDeclarations.obn | 140 + tests/obnc/passing/T3VariableDeclarations.obn | 60 + tests/obnc/passing/T4Expressions.obn | 500 ++ tests/obnc/passing/T5Statements.obn | 550 ++ tests/obnc/passing/T5SystemStatements.obn | 98 + .../obnc/passing/T6ProcedureDeclarations.obn | 259 + tests/obnc/passing/T7Modules.obn | 85 + tests/obnc/passing/a dir/E.Mod | 22 + tests/obnc/passing/lib/Local.obn | 29 + tests/obnc/passing/lib/libE.obn | 29 + tests/obnc/passing/lib1/Local.obn | 29 + tests/obnc/passing/lib1/lib1M.obn | 29 + tests/obncdoc/ExportedFeatures.def | 30 + tests/obncdoc/ExportedFeatures.def.html | 45 + tests/obncdoc/ExportedFeatures.obn | 51 + tests/obncdoc/NoExportedFeatures.def | 2 + tests/obncdoc/NoExportedFeatures.def.html | 17 + tests/obncdoc/NoExportedFeatures.obn | 17 + tests/scanner/tokens.txt | 78 + 210 files changed, 37164 insertions(+) create mode 100644 COPYING create mode 100644 README create mode 100644 VERSION create mode 100755 bin/micb create mode 100755 bin/micb-includes create mode 100755 bin/obnc-path-test create mode 100755 bin/obnc-test create mode 100755 bin/obncdoc-extract create mode 100755 bin/obncdoc-index create mode 100755 bin/obncdoc-markup create mode 100755 bin/obncdoc-test create mode 100755 build create mode 100755 install create mode 100644 lib/obnc/Files.c create mode 100644 lib/obnc/Files.obn create mode 100644 lib/obnc/FilesTest.obn create mode 100644 lib/obnc/In.c create mode 100644 lib/obnc/In.obn create mode 100644 lib/obnc/InTest.obn create mode 100755 lib/obnc/InTest.sh create mode 100644 lib/obnc/Input.c create mode 100644 lib/obnc/Input.env create mode 100644 lib/obnc/Input.obn create mode 100644 lib/obnc/Input0.c create mode 100644 lib/obnc/Input0.obn create mode 100644 lib/obnc/Input0Test.obn create mode 100755 lib/obnc/Input0Test.sh create mode 100644 lib/obnc/InputTest.obn create mode 100755 lib/obnc/InputTest.sh create mode 100644 lib/obnc/LICENSE create mode 100644 lib/obnc/Math.c create mode 100644 lib/obnc/Math.env create mode 100644 lib/obnc/Math.obn create mode 100644 lib/obnc/MathTest.obn create mode 100644 lib/obnc/OBNC.c create mode 100644 lib/obnc/OBNC.env create mode 100644 lib/obnc/OBNC.h create mode 100644 lib/obnc/OBNCTest.c create mode 100644 lib/obnc/Out.c create mode 100644 lib/obnc/Out.obn create mode 100644 lib/obnc/OutTest.obn create mode 100755 lib/obnc/OutTest.sh create mode 100644 lib/obnc/Strings.obn create mode 100644 lib/obnc/StringsTest.obn create mode 100644 lib/obnc/XYplane.c create mode 100644 lib/obnc/XYplane.env create mode 100644 lib/obnc/XYplane.obn create mode 100644 lib/obnc/XYplaneTest.obn create mode 100644 lib/obnc/obncdoc/Files.def create mode 100644 lib/obnc/obncdoc/Files.def.html create mode 100644 lib/obnc/obncdoc/FilesTest.def create mode 100644 lib/obnc/obncdoc/FilesTest.def.html create mode 100644 lib/obnc/obncdoc/In.def create mode 100644 lib/obnc/obncdoc/In.def.html create mode 100644 lib/obnc/obncdoc/InTest.def create mode 100644 lib/obnc/obncdoc/InTest.def.html create mode 100644 lib/obnc/obncdoc/Input.def create mode 100644 lib/obnc/obncdoc/Input.def.html create mode 100644 lib/obnc/obncdoc/Input0.def create mode 100644 lib/obnc/obncdoc/Input0.def.html create mode 100644 lib/obnc/obncdoc/Input0Test.def create mode 100644 lib/obnc/obncdoc/Input0Test.def.html create mode 100644 lib/obnc/obncdoc/InputTest.def create mode 100644 lib/obnc/obncdoc/InputTest.def.html create mode 100644 lib/obnc/obncdoc/Math.def create mode 100644 lib/obnc/obncdoc/Math.def.html create mode 100644 lib/obnc/obncdoc/MathTest.def create mode 100644 lib/obnc/obncdoc/MathTest.def.html create mode 100644 lib/obnc/obncdoc/Out.def create mode 100644 lib/obnc/obncdoc/Out.def.html create mode 100644 lib/obnc/obncdoc/OutTest.def create mode 100644 lib/obnc/obncdoc/OutTest.def.html create mode 100644 lib/obnc/obncdoc/Strings.def create mode 100644 lib/obnc/obncdoc/Strings.def.html create mode 100644 lib/obnc/obncdoc/StringsTest.def create mode 100644 lib/obnc/obncdoc/StringsTest.def.html create mode 100644 lib/obnc/obncdoc/XYplane.def create mode 100644 lib/obnc/obncdoc/XYplane.def.html create mode 100644 lib/obnc/obncdoc/XYplaneTest.def create mode 100644 lib/obnc/obncdoc/XYplaneTest.def.html create mode 100644 lib/obnc/obncdoc/index.html create mode 100644 lib/obnc/obncdoc/style.css create mode 100644 share/doc/obnc/oberon-report.html create mode 100644 share/man/man1/obnc-compile.1 create mode 100644 share/man/man1/obnc-path.1 create mode 100644 share/man/man1/obnc.1 create mode 100644 share/man/man1/obncdoc.1 create mode 100644 share/obnc/style.css create mode 100644 src/Config.c create mode 100644 src/Error.c create mode 100644 src/Error.h create mode 100644 src/Files.c create mode 100644 src/Files.h create mode 100644 src/Generate.c create mode 100644 src/Generate.h create mode 100644 src/Maps.c create mode 100644 src/Maps.h create mode 100644 src/MapsTest.c create mode 100644 src/ModulePaths.c create mode 100644 src/ModulePaths.h create mode 100644 src/Oberon.h create mode 100644 src/Oberon.l create mode 100644 src/Oberon.y create mode 100644 src/Paths.c create mode 100644 src/Paths.h create mode 100644 src/Range.c create mode 100644 src/Range.h create mode 100644 src/StackTrace.c create mode 100644 src/StackTrace.h create mode 100644 src/StackTraceLinux.c create mode 100644 src/Table.c create mode 100644 src/Table.h create mode 100644 src/TableTest.c create mode 100644 src/Time.c create mode 100644 src/Time.h create mode 100644 src/Trees.c create mode 100644 src/Trees.h create mode 100644 src/Types.c create mode 100644 src/Types.h create mode 100644 src/Util.c create mode 100644 src/Util.env create mode 100644 src/Util.h create mode 100644 src/UtilTest.c create mode 100644 src/lex.yy.c create mode 100644 src/lex.yy.h create mode 100644 src/lex.yyTest.c create mode 100644 src/obnc-compile.c create mode 100644 src/obnc-path.c create mode 100644 src/obnc.c create mode 100644 src/obncdoc.c create mode 100644 src/y.tab.c create mode 100644 src/y.tab.h create mode 100755 test create mode 100644 tests/obnc/failing-at-compile-time/A.obn create mode 100644 tests/obnc/failing-at-compile-time/B.obn create mode 100644 tests/obnc/failing-at-compile-time/T0UnterminatedComment.obn create mode 100644 tests/obnc/failing-at-compile-time/T2PointerToNonRecord.obn create mode 100644 tests/obnc/failing-at-compile-time/T2RecursiveRecord.obn create mode 100644 tests/obnc/failing-at-compile-time/T2RedeclaredField.obn create mode 100644 tests/obnc/failing-at-compile-time/T2RepeatedParameterIdent.obn create mode 100644 tests/obnc/failing-at-compile-time/T2SelfDeclaration.obn create mode 100644 tests/obnc/failing-at-compile-time/T2SelfReferringBaseType.obn create mode 100644 tests/obnc/failing-at-compile-time/T2UnresolvedAnonType.obn create mode 100644 tests/obnc/failing-at-compile-time/T2UnresolvedType.obn create mode 100644 tests/obnc/failing-at-compile-time/T2WrongResolvedType.obn create mode 100644 tests/obnc/failing-at-compile-time/T3RepeatedField.obn create mode 100644 tests/obnc/failing-at-compile-time/T3RepeatedVar.obn create mode 100644 tests/obnc/failing-at-compile-time/T4InvalidPointerComparison.obn create mode 100644 tests/obnc/failing-at-compile-time/T4InvalidProcedureComparison.obn create mode 100644 tests/obnc/failing-at-compile-time/T4NegativeSetElement.obn create mode 100644 tests/obnc/failing-at-compile-time/T4SelectorOnConstant.obn create mode 100644 tests/obnc/failing-at-compile-time/T4TypeGuardOnNonVarParamRecord.obn create mode 100644 tests/obnc/failing-at-compile-time/T5AssignPredefinedProcedure.obn create mode 100644 tests/obnc/failing-at-compile-time/T5AssignToImportedVariable.obn create mode 100644 tests/obnc/failing-at-compile-time/T5FunctionProcedureStatement.obn create mode 100644 tests/obnc/failing-at-compile-time/T5InvalidArrayAssignment.obn create mode 100644 tests/obnc/failing-at-compile-time/T5NonConstForLoopInc.obn create mode 100644 tests/obnc/failing-at-compile-time/T5PointerVarParamExt.obn create mode 100644 tests/obnc/failing-at-compile-time/T5StringAssignment.obn create mode 100644 tests/obnc/failing-at-compile-time/T5StructValueParamAssignment.obn create mode 100644 tests/obnc/failing-at-compile-time/T6ExtendedPointerVarParam.obn create mode 100644 tests/obnc/failing-at-compile-time/T6ForgottenReturnType.obn create mode 100644 tests/obnc/failing-at-compile-time/T6LocalParamTypeRef.obn create mode 100644 tests/obnc/failing-at-compile-time/T6NonScalarResultType.obn create mode 100644 tests/obnc/failing-at-compile-time/T6ReadOnlyParam.obn create mode 100644 tests/obnc/failing-at-compile-time/T7AccessNonExportedField.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ActualVarParamImported.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ActualVarParamImported1.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ExportLocalIdent.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportDuplicate.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportDuplicateWithAlias.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportLibraryLocal.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportNonExisting.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportRedeclaration.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportRedeclarationAlias.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportSelf.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportSelfWithAlias.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ImportWithDuplicateAlias.obn create mode 100644 tests/obnc/failing-at-compile-time/T7ModuleIdentifierNonMatch.obn create mode 100644 tests/obnc/failing-at-compile-time/lib/Local.obn create mode 100644 tests/obnc/failing-at-runtime/T4FailingTypeGuard.obn create mode 100644 tests/obnc/failing-at-runtime/T5AssignStringToOpenArray.obn create mode 100644 tests/obnc/failing-at-runtime/T5CallNilProcedure.obn create mode 100644 tests/obnc/failing-at-runtime/T5OpenArrayAssignment.obn create mode 100644 tests/obnc/failing-at-runtime/T5RecordVarParamAssignment.obn create mode 100644 tests/obnc/passing/A.obn create mode 100644 tests/obnc/passing/B.obn create mode 100644 tests/obnc/passing/C.obn create mode 100644 tests/obnc/passing/D.obn create mode 100644 tests/obnc/passing/OBNC.obn create mode 100644 tests/obnc/passing/T1ConstantDeclarations.obn create mode 100644 tests/obnc/passing/T2TypeDeclarations.obn create mode 100644 tests/obnc/passing/T3VariableDeclarations.obn create mode 100644 tests/obnc/passing/T4Expressions.obn create mode 100644 tests/obnc/passing/T5Statements.obn create mode 100644 tests/obnc/passing/T5SystemStatements.obn create mode 100644 tests/obnc/passing/T6ProcedureDeclarations.obn create mode 100644 tests/obnc/passing/T7Modules.obn create mode 100644 tests/obnc/passing/a dir/E.Mod create mode 100644 tests/obnc/passing/lib/Local.obn create mode 100644 tests/obnc/passing/lib/libE.obn create mode 100644 tests/obnc/passing/lib1/Local.obn create mode 100644 tests/obnc/passing/lib1/lib1M.obn create mode 100644 tests/obncdoc/ExportedFeatures.def create mode 100644 tests/obncdoc/ExportedFeatures.def.html create mode 100644 tests/obncdoc/ExportedFeatures.obn create mode 100644 tests/obncdoc/NoExportedFeatures.def create mode 100644 tests/obncdoc/NoExportedFeatures.def.html create mode 100644 tests/obncdoc/NoExportedFeatures.obn create mode 100644 tests/scanner/tokens.txt diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/README b/README new file mode 100644 index 0000000..fc132b8 --- /dev/null +++ b/README @@ -0,0 +1,65 @@ +INTRODUCTION + +OBNC is a compiler for Niklaus Wirth's programming language Oberon. It translates Oberon modules into C code. The build command (obnc) invokes both the Oberon compiler (obnc-compile) and the host C compiler and sorts out all dependencies. + +OBNC follows POSIX standard. This implies that it should compile and run on a POSIX compatible operating system. + + +INSTALLATION + +1. Make sure you have Boehm-Demers-Weiser's garbage collector GC installed on your system. To use the basic library modules Input and XYplane you also need SDL (Simple DirectMedia Layer). On a Debian system you install these dependencies with the command + + apt install libgc-dev libsdl1.2-dev + +2. Compile OBNC with the command + + ./build + +By default OBNC is built to be installed in /usr/local. If you want to use installation directory D instead, add `--prefix=D' to the build command. For other build options, run `./build -h'. + +3. Optionally, run unit tests with the command + + ./test + +4. Install OBNC with the command + + ./install + +To undo the installation, run `./install u'. For other installation options, run `./install -h'. + + +COMMANDS + +bin/obnc + Oberon build tool + +bin/obnc-compile + Oberon-to-C compiler + +bin/obnc-path + Oberon module finder + +bin/obncdoc + Oberon documentation generator + + +DOCUMENTATION + +share/doc/obnc/oberon-report.html + Oberon language reference + +share/doc/obnc/obncdoc/obnc + Basic library modules + +share/man/man1/ + OBNC commands + + +LICENSE + +OBNC is released under the GNU General Public License (see file COPYING), with the exception of library source files in lib/obnc which are released under the Mozilla Public License (see file lib/obnc/LICENSE). + + +AUTHOR + +Karl Landstrom diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..2a0970c --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.16.1 diff --git a/bin/micb b/bin/micb new file mode 100755 index 0000000..f77ea31 --- /dev/null +++ b/bin/micb @@ -0,0 +1,279 @@ +#!/bin/sh + +#micb - MIASAP C Builder +# +#usage: micb MODULE.c +# +#Builds an executable with MODULE.c as entry point. Imported modules are compiled or recompiled as needed. For any module M, compiler, compiler flags, link flags and link libraries specific to M can be specified by setting the variables CC, CFLAGS, LDFLAGS and LDLIBS respectively in a file named M.env. + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o errexit -o nounset + +readonly selfDirPath="$(cd "$(dirname "$0")"; pwd -P)" +readonly micbIncludes="$selfDirPath/micb-includes" +readonly CC="${CC:-cc}" +readonly CFLAGS="${CFLAGS:-}" +readonly LDFLAGS="${LDFLAGS:-}" +readonly LDLIBS="${LDLIBS:-}" + +IncludeFiles() +{ + local filename="$1" + + local prefix="$(dirname "$filename")/" + prefix="${prefix#./}" + "$micbIncludes" < "$filename" | while read header; do echo "$prefix$header"; done +} + + +MapPut() +{ + local key="$1" + local value="$2" + local map="$3" + + if [ -z "$map" ]; then + echo "$key$(printf '\t')$value" + else + echo "$map" | \ + awk -v key="$key" -v value="$value" \ + 'BEGIN { FS = "\t"; keyFound = 0 } + $1 == key { print key"\t"value; keyFound = 1 } + $1 != key { print $0 } + END { if (! keyFound) { print key"\t"value } }' + fi +} + + +MapHas() +{ + local key="$1" + local map="$2" + + echo "$map" | grep -q "^$key$(printf '\t')" +} + + +MapAt() +{ + local key="$1" + local map="$2" + + echo "$map" | awk -v key="$key" 'BEGIN { FS = "\t" } $1 == key { print $2 }' +} + + +EnvValue() +{ + local ident="$1" + local envFile="$2" + + local quot="'" + local apos='"' + local value="$(awk -F "[$quot$apos=]+" -v ident="$ident" '$1 == ident { print $2 }' "$envFile")" + eval "value=\"$value\"" #expand embedded commands, like pkg-config + echo "$value" +} + + +Compile() +{ + local cFile="$1" + + local module="${cFile%.c}" + local moduleCC= + local moduleCFLAGS= + if [ -e "$module.env" ]; then + moduleCC="$(EnvValue CC "$module.env")" + moduleCFLAGS="$(EnvValue CFLAGS "$module.env")" + fi + if [ -z "$moduleCC" ]; then + moduleCC="$CC" + fi + local compileCommand="$moduleCC -c -o $module.o $CFLAGS $moduleCFLAGS $module.c" + compileCommand="$(echo "$compileCommand" | sed 's/ */ /g')" + echo "$compileCommand" + $compileCommand +} + + +UpdateObjectFile() +{ + local sourceFile="$1" + local newestFile="$2" + + local module="${sourceFile%.*}" + if [ "$sourceFile" = "$module.c" ]; then + if [ ! -e "$module.o" ] \ + || [ "$module.o" -ot "$newestFile" ] \ + || { [ -e "$module.env" ] && [ "$module.o" -ot "$module.env" ]; }; then + Compile "$sourceFile" + fi + fi +} + + +discoveredFiles="" #map with "filename" as key and "newest file in subgraph" as value + +Traverse() +{ + local filename="$1" + local nodePath="$2" #for detecting include cycles + local nodeHandler="$3" + + discoveredFiles="$(MapPut "$filename" "" "$discoveredFiles")" + + #traverse include files + local includeFile + local newestFileInSubgraph + local newestFile="$filename" + for includeFile in $(IncludeFiles "$filename"); do + if ! { echo "$nodePath" | grep -q -Fx "$includeFile"; }; then + if ! MapHas "$includeFile" "$discoveredFiles"; then + Traverse "$includeFile" "$nodePath\n$includeFile" "$nodeHandler" + fi + newestFileInSubgraph="$(MapAt "$includeFile" "$discoveredFiles")" + if [ "$newestFile" -ot "$newestFileInSubgraph" ]; then + newestFile="$newestFileInSubgraph" + fi + else + local cycle="$(echo "$nodePath" | tr '\n' ' ')$includeFile" + echo "$0: warning: include cycle found: $cycle" >&2 + fi + done + + discoveredFiles="$(MapPut "$filename" "$newestFile" "$discoveredFiles")" + + "$nodeHandler" "$filename" "$newestFile" + + #for a header file, also traverse the implementation file + local module="${filename%.*}" + if [ "${filename%.h}" != "$filename" ] && [ -e "$module.c" ] && ! MapHas "$module.c" "$discoveredFiles"; then + Traverse "$module.c" "$module.c" "$nodeHandler" + fi +} + + +NewestFile() +{ + local files="$1" + + local result="$(echo "$files" | head -n 1)" + for file in $files; do + if [ "$result" -ot "$file" ]; then + result="$file" + fi + done + echo "$result" +} + + +EnvFiles() +{ + local sourceFiles="$1" + + echo "$sourceFiles" \ + | while read srcFile; do + envFile="${srcFile%.*}.env" + if [ -e "$envFile" ]; then + echo "$envFile" + fi + done \ + | sort | uniq +} + + +OptionUnion() +{ + local ident="$1" + local envFiles="$2" + + echo "$envFiles" \ + | while read envFile; do + EnvValue "$ident" "$envFile" + done \ + | tr ' ' '\n' | sort | uniq | tr '\n' ' ' +} + + +Link() +{ + local objectFiles="$1" + local exeFile="$2" + + local objectFileArgs="$(echo "$objectFiles" | tr '\n' ' ')" + local sourceFiles="$(echo "$discoveredFiles" | awk 'BEGIN { FS = "\t" } { print $1 }')" + local envFiles="$(EnvFiles "$sourceFiles")" + local ldflags="$(OptionUnion LDFLAGS "$envFiles")" + local ldlibs="$(OptionUnion LDLIBS "$envFiles")" + + local linkCommand="$CC -o $exeFile $ldflags $LDFLAGS $objectFileArgs $ldlibs $LDLIBS" + linkCommand="$(echo "$linkCommand" | sed 's/ */ /g')" + echo "$linkCommand" + $linkCommand +} + + +Build() +{ + local cFile="$1" + + discoveredFiles="" + Traverse "$cFile" "$cFile" UpdateObjectFile + + local exeFile="${cFile%.c}" + local cFiles="$(echo "$discoveredFiles" | awk 'BEGIN { FS = "\t" } $1 ~ /\.c$/ { print $1 }')" + local objectFiles="$(echo "$cFiles" | sed 's/\.c$/.o/')" + local newestObjectFile="$(NewestFile "$objectFiles")" + + if [ ! -e "$exeFile" ] || [ "$exeFile" -ot "$newestObjectFile" ]; then + Link "$objectFiles" "$exeFile" + else + echo "$exeFile is up to date" + fi +} + + +Run() +{ + local syntaxError=false + + if [ "$#" = 1 ]; then + case $1 in + -*) syntaxError=true;; + *.c) + if [ -e "$1" ]; then + Build "$1" + else + echo "$0: no such file: $1" >&2 + false + fi;; + *) syntaxError=true + esac + else + syntaxError=true + fi + + if "$syntaxError"; then + echo "synopsis: $(basename "$0") MODULE.c" >&2 + false + fi +} + +Run "$@" diff --git a/bin/micb-includes b/bin/micb-includes new file mode 100755 index 0000000..1edf838 --- /dev/null +++ b/bin/micb-includes @@ -0,0 +1,61 @@ +#!/usr/bin/awk -f + +#micb-includes - MIASAP C Builder Include files +# +#usage: micb-includes +# +#Reads C code from stdin and writes include files to stdout. Only non-system header files are considered. + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +BEGIN { + insideComment = 0 +} + +(index($0, "/*") > 0) || (index($0, "*/") > 0) { + tail = $0 + insideString = 0 + if (insideComment) { + match(tail, /\*\//) + } else { + match(tail, /"|\/\*/) + } + while (RSTART > 0) { + delim = substr(tail, RSTART, RLENGTH) + if (delim == "\"") { + insideString = ! insideString + } else if (delim == "/*") { + insideComment = 1 + } else { + insideComment = 0 + } + tail = substr(tail, RSTART + RLENGTH) + if (insideString) { + match(tail, /"/) + } else if (insideComment) { + match(tail, /\*\//) + } else { + match(tail, /"|\/\*|\*\//) + } + } +} + +! insideComment && /^#include[ \t]+"/ { + split($0, fields, /"/) + print fields[2] +} diff --git a/bin/obnc-path-test b/bin/obnc-path-test new file mode 100755 index 0000000..df3e6d0 --- /dev/null +++ b/bin/obnc-path-test @@ -0,0 +1,46 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o nounset + +EndsWith() +{ + local suffix="$1" + local target="$2" + + test "${target%$suffix}" != "$target" +} + +readonly selfDirPath="$(cd "$(dirname "$0")"; pwd -P)" +readonly packagePath="$(dirname "$selfDirPath")" + +path="$(env OBNC_IMPORT_PATH='' "$selfDirPath/obnc-path" Out | tr '\\' '/')" +exitStatus="$?" +expectedResult="$packagePath/lib/obnc" + +if [ "$exitStatus" -eq 0 ]; then + #NOTE: In MinGW on Windows the path returned by obnc-path ends with $selfDirPath + if ! EndsWith "$expectedResult" "$path"; then + echo "$(basename "$0") failed: result: '$path', expected result: $expectedResult" >&2 + exit 1 + fi +else + echo "$(basename "$0") failed: exit status: $exitStatus" >&2 + exit 1 +fi diff --git a/bin/obnc-test b/bin/obnc-test new file mode 100755 index 0000000..e077308 --- /dev/null +++ b/bin/obnc-test @@ -0,0 +1,114 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o errexit -o nounset + +readonly selfDirPath="$(cd "$(dirname "$0")"; pwd -P)" +readonly packagePath="$(dirname "$selfDirPath")" +export OBNC_PREFIX="$packagePath" +export OBNC_LIBDIR="lib" +export CC="${CC:-}" +export CFLAGS="${CFLAGS:-} -I$packagePath/lib" + +EchoAndRun() +{ + echo "$@" + eval "$@" +} + + +CleanUp() +{ + find "$packagePath/tests/obnc" -name .obnc -type d | while read -r dir; do + rm -r "$dir" + done + find "$packagePath/tests/obnc" -name "*.obn" -type f | while read -r file; do + rm -f "${file%.obn}" "${file%.obn}.exe" + done +} + +CleanUp + +dir="$packagePath/tests/obnc/passing" +EchoAndRun cd "$dir" +for module in *.obn; do + if [ "$module" != T5SystemStatements.obn ]; then + if EchoAndRun "OBNC_IMPORT_PATH='a dir' $packagePath/bin/obnc" "$module"; then + if ! EchoAndRun "./${module%.obn}"; then + printf "\nPositive test failed: %s\n\n" "$dir/$module">&2 + exit 1 + fi + else + printf "\nPositive test failed: %s\n\n" "$dir/$module" >&2 + exit 1 + fi + fi +done + +for def in OBNC_CONFIG_C_INT_TYPE=OBNC_CONFIG_SHORT \ + OBNC_CONFIG_C_INT_TYPE=OBNC_CONFIG_INT \ + OBNC_CONFIG_C_INT_TYPE=OBNC_CONFIG_LONG \ + OBNC_CONFIG_C_REAL_TYPE=OBNC_CONFIG_FLOAT \ + OBNC_CONFIG_C_REAL_TYPE=OBNC_CONFIG_DOUBLE \ + OBNC_CONFIG_C_REAL_TYPE=OBNC_CONFIG_LONG_DOUBLE \ + OBNC_CONFIG_TARGET_EMB=1; do + if EchoAndRun "CFLAGS='$CFLAGS -D $def' '$packagePath/bin/obnc'" -x A.obn; then + if ! EchoAndRun ./A; then + printf "\nPositive test compiled with C flag %s failed: %s\n\n" "$cFlag" "$dir/A.obn">&2 + exit 1 + fi + else + printf "\nPositive test compiled with C flag %s failed: %s\n\n" "$cFlag" "$dir/A.obn" >&2 + exit 1 + fi +done + +dir="$packagePath/tests/obnc/failing-at-compile-time" +EchoAndRun cd "$dir" +for module in *.obn; do + if [ "$module" != A.obn ] && [ "$module" != B.obn ]; then + echo "$packagePath/bin/obnc-compile" "$module" + if "$packagePath/bin/obnc-compile" "$module" 2>/dev/null; then + printf "\nNegative test failed: %s\n\n" "$dir/$module" >&2 + exit 1 + elif [ "$?" -ne 1 ]; then + printf "\nNegative test crashed: %s\n\n" "$dir/$module" >&2 + exit 1 + fi + fi +done + +dir="$packagePath/tests/obnc/failing-at-runtime" +EchoAndRun cd "$dir" +for module in *.obn; do + if [ "$module" != A.obn ] && [ "$module" != B.obn ]; then + if EchoAndRun "$packagePath/bin/obnc" "$module"; then + echo "./${module%.obn}" + if ( "./${module%.obn}" || false ) >/dev/null 2>&1; then + printf "\nNegative test failed: %s\n\n" "$dir/$module" >&2 + exit 1 + fi + else + printf "\nNegative test failed: %s\n\n" "$dir/$module" >&2 + exit 1 + fi + fi +done + +CleanUp diff --git a/bin/obncdoc-extract b/bin/obncdoc-extract new file mode 100755 index 0000000..2ac16f3 --- /dev/null +++ b/bin/obncdoc-extract @@ -0,0 +1,361 @@ +#!/usr/bin/awk -f + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +function Indentation(line, + result) +{ + match(line, "^[ \t]+") + if (RLENGTH > 0) { + result = substr(line, RSTART, RLENGTH) + } else { + result = "" + } + return result +} + + +function MatchSyntax(line, regex, + regex1, pos, found, matchedString, commentLevel, insideString) +{ + #ignore comments and strings + regex1 = "("regex")|\\(\\*|\\*\\)|\"" + match(line, regex1) + pos = RSTART + while (! found && (RSTART > 0)) { + matchedString = substr(line, pos, RLENGTH) + if ((matchedString == "(*") && ! insideString) { + commentLevel++ + } else if ((matchedString == "*)") && ! insideString) { + commentLevel-- + } else if ((matchedString == "\"") && (commentLevel == 0)) { + insideString = ! insideString + } else if ((commentLevel == 0) && ! insideString) { + found = 1 + } + if (! found) { + pos += RLENGTH + match(substr(line, pos), regex1) + if (RSTART > 0) { + pos += RSTART - 1 + } else { + pos = 0 + } + } + } + RSTART = pos + return RSTART +} + + +function CommentLevelAtEndOfLine(line, currentLevel, + regexp, matchedString) +{ + regexp = "\\(\\*|\\*\\)|\"" + match(line, regexp) + while (RSTART > 0) { + matchedString = substr(line, RSTART, RLENGTH) + line = substr(line, RSTART + RLENGTH) + if (matchedString == "(*") { + currentLevel++ + } else if (matchedString == "*)") { + currentLevel-- + } else if (matchedString == "\"") { + if (currentLevel == 0) { + line = substr(line, index(line, "\"") + 1) + } + } + match(line, regexp) + } + return currentLevel +} + + +function EndsInsideRecord(line, + parts) +{ + return MatchSyntax(line, "[^"identCharSet"]RECORD([^"identCharSet"]|$)") \ + && ! MatchSyntax(line, "[^"identCharSet"]END[ \t]*;") +} + + +function TrackQualifiers(line, + regex, matchedString) +{ + regex = identRegex"\\."identRegex + MatchSyntax(line, regex) + while (RSTART > 0) { + matchedString = substr(line, RSTART, RLENGTH) + line = substr(line, RSTART + RLENGTH) + match(matchedString, identRegex) + publicImports[substr(matchedString, 1, RLENGTH)] = "" + MatchSyntax(line, regex) + } +} + + +function ExportedParts(line, + left, right) +{ + match(line, "[=:;(]") + if (RSTART > 0) { + left = substr(line, 1, RSTART - 1) + right = substr(line, RSTART) + if ((index(left, ",") > 0) && (currentSection != "IMPORT")) { + #exclude non-exported identifiers + gsub(identRegex"[ \t]*,[ \t]*", "", left) + sub("(,[ \t]*)?"identRegex"[ \t]*$", "", left) + } + gsub("\\*", "", left) + + #skip past trailing semi-colon (if any) + MatchSyntax(right, ";") + while (RSTART > 0) { + left = left "" substr(right, 1, RSTART) + right = substr(right, RSTART + RLENGTH) + MatchSyntax(right, ";") + } + + #skip to trailing comment (if any) + match(right, "[ \t]*\\(\\*") + if (RSTART > 0) { + left = left "" substr(right, 1, RSTART - 1) + right = substr(right, RSTART) + } + + #delete non-exported comments + if (MatchSyntax(left, "PROCEDURE")) { + gsub("[ \t]*\\(\\*[^*]*\\*\\)", "", left) + } + sub("^[ \t]*\\(\\*([^*].*|$)", "", right) + + #unmark exported comments + if (MatchSyntax(left, "PROCEDURE")) { + gsub("\\(\\*\\*", "(*", left) + } + sub("^[ \t]*\\(\\*\\*", " (*", right) + + line = left""right + } + return line +} + +BEGIN { + leadingIdentCharSet = "A-Za-z" + identCharSet = leadingIdentCharSet"0-9_" + identRegex = "["leadingIdentCharSet"]["identCharSet"]*" + exportedIdentRegex = identRegex"[ \t]*\\*" + exportedIdentListRegex = "("identRegex"[ \t]*,[ \t]*)*"identRegex"[ \t]*\\*([ \t]*,[ \t]*"identRegex")*" + split("", output) + split("", sectionExported) + split("", sectionHasExportedComment) + split("", publicImports) + recordLevel = 0 + split("", recordExported) + split("", exportedFieldFound) + moduleIdent = "" + currentSection = "MODULE" + sectionExported["MODULE"] = 1 + commentLevel = 0 + insideExportedComment = 0 + insideParamList = 0 +} + +(commentLevel == 0) && /^[ \t]*$/ { + if ((currentSection == "IMPORT") || sectionExported[currentSection]) { + sub("\n+$", "\n\n", output[currentSection]) + } + next +} + +(commentLevel == 0) && ($1 == "MODULE") { + if (substr($2, length($2), 1) == ";") { + moduleIdent = substr($2, 1, length($2) - 1) + } else { + moduleIdent = $2 + } + line = $0 + sub(/MODULE/, "DEFINITION", line) + commentLevel = CommentLevelAtEndOfLine(line, commentLevel) + output[currentSection] = output[currentSection] ExportedParts(line) "\n" + next +} + +(commentLevel == 0) && ((currentSection != "PROCEDURE") && ($1 ~ "^(IMPORT|CONST|TYPE|VAR)$") || ($1 == "PROCEDURE") && ($2 ~ "^"identRegex)) { + currentSection = $1 +} + +(commentLevel == 0) && (currentSection == "IMPORT") { + commentLevel = CommentLevelAtEndOfLine($0, commentLevel) + output[currentSection] = output[currentSection] ExportedParts($0) "\n" + next +} + +(commentLevel == 0) && (currentSection != "PROCEDURE") && ($1 ~ "^(CONST|TYPE|VAR)$") { + if (match($2$3, "^"exportedIdentRegex)) { + TrackQualifiers($0) + if (EndsInsideRecord($0)) { + recordExported[recordLevel + 1] = 1 + } + sectionExported[$1] = 1 + } + commentLevel = CommentLevelAtEndOfLine($0, commentLevel) + if (EndsInsideRecord($0)) { + recordLevel++ + } + output[currentSection] = output[currentSection] ExportedParts($0) "\n" + next +} + +(commentLevel == 0) && (currentSection ~ "^(TYPE|VAR)$") && ($0 ~ "^[ \t]*END[ \t]*([;(]|$)") { + if (recordExported[recordLevel]) { + line = $0 + if (! exportedFieldFound[recordLevel]) { + sub("^[ \t]*", " ", line) + } + recordExported[recordLevel] = 0 + exportedFieldFound[recordLevel] = 0 + output[currentSection] = output[currentSection] ExportedParts(line) "\n" + } + recordLevel-- + next +} + +(commentLevel == 0) && ($0 ~ "^[ \t]*(PROCEDURE[ \t]+)?"exportedIdentListRegex) { + TrackQualifiers($0) + if ((recordLevel > 0) && recordExported[recordLevel]) { + if (! exportedFieldFound[recordLevel]) { + output[currentSection] = output[currentSection] "\n" + exportedFieldFound[recordLevel] = 1 + } + } + commentLevel = CommentLevelAtEndOfLine($0, commentLevel) + output[currentSection] = output[currentSection] ExportedParts($0) + if (EndsInsideRecord($0)) { + recordLevel++ + recordExported[recordLevel] = 1 + } else { + output[currentSection] = output[currentSection] "\n" + } + sectionExported[currentSection] = 1 + insideParamList = ($1 == "PROCEDURE") && MatchSyntax($0, "\\(") && ! MatchSyntax($0, "\\)") + next +} + +insideParamList { + output[currentSection] = output[currentSection] ExportedParts($0) "\n" + insideParamList = ! MatchSyntax($0, "\\)") + next +} + +(commentLevel == 0) && (currentSection ~ "^(TYPE|VAR)$") && EndsInsideRecord($0) { + recordLevel++ + next +} + +(commentLevel == 0) && ($1 ~ "^\\(\\*\\*?") { + commentLevel = CommentLevelAtEndOfLine($0, commentLevel) + if (match($1, "^\\(\\*\\*")) { + sectionHasExportedComment[currentSection] = 1 + line = $0 + sub(/\(\*\*/, "(*", line) + if (commentLevel > 0) { + insideExportedComment = 1 + } + output[currentSection] = output[currentSection] line "\n" + } + next +} + +commentLevel > 0 { + if (insideExportedComment) { + output[currentSection] = output[currentSection] $0 "\n" + } + commentLevel = CommentLevelAtEndOfLine($0, commentLevel) + if (commentLevel == 0) { + insideExportedComment = 0 + } +} + +END { + n = 0 + for (key in publicImports) { + n++ + } + if (n > 0) { + sectionExported["IMPORT"] = 1 + + #keep only public imports + regex = identRegex "([ \t]*:=[ \t]*" identRegex ")?[ \t]*(,[ \t]*)?" + left = "" + right = output["IMPORT"] + ##skip keyword IMPORT + pos = MatchSyntax(right, "IMPORT") + left = substr(right, 1, pos - 1 + RLENGTH) + right = substr(right, pos + RLENGTH) + ## + pos = MatchSyntax(right, regex) + while (pos > 0) { + import = substr(right, pos, RLENGTH) + split(import, importParts, "[ \t:=,]+") + qualifier = importParts[1] + if (qualifier in publicImports) { + left = left substr(right, 1, pos - 1 + RLENGTH) + } else { + left = left substr(right, 1, pos - 1) + } + right = substr(right, pos + RLENGTH) + pos = MatchSyntax(right, regex) + } + importList = left right + ##fixup separators + hasFinalBlankLine = match(importList, "\n[ \t]*\n") + gsub(",[ \t\n]*;", ";", importList) + gsub("\n[ \t]*\n", "\n", importList) + if (hasFinalBlankLine) { + importList = importList "\n" + } + output["IMPORT"] = importList + } + + split("MODULE IMPORT CONST TYPE VAR PROCEDURE", sections) + sectionsLen = 6 + + hasExportedIdent = 0 + for (i = 3; i <= sectionsLen; i++) { + if (sectionExported[sections[i]]) { + hasExportedIdent = 1 + } + } + if (! hasExportedIdent) { + sub("\n+$", "\n", output["MODULE"]) + } + + for (i = 1; i <= sectionsLen; i++) { + section = sections[i] + if (sectionExported[section]) { + printf "%s", output[section] + } else if (sectionHasExportedComment[section]) { + #account for exported comment preceeding an exported procedure + sub("^[ \t]*" section "[ \t\n]*\n", "", output[section]) + printf "%s", output[section] + } + } + + print "END " moduleIdent "." +} diff --git a/bin/obncdoc-index b/bin/obncdoc-index new file mode 100755 index 0000000..cf82193 --- /dev/null +++ b/bin/obncdoc-index @@ -0,0 +1,43 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o errexit -o nounset + +echo ' + + + + + Library Index + + + +

Library Index

+ + 
'
+
+for file in *; do
+	if [ -e "$file/index.html" ]; then
+		echo "Library $file"
+	fi
+done
+
+echo '
+ +' diff --git a/bin/obncdoc-markup b/bin/obncdoc-markup new file mode 100755 index 0000000..644de7b --- /dev/null +++ b/bin/obncdoc-markup @@ -0,0 +1,85 @@ +#!/usr/bin/awk -f + +#markup definition file + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +BEGIN { + commentLevel = 0 +} + +{ + gsub(/&/, "\\&", $0) + gsub(//, "\\>", $0) +} + +(commentLevel == 0) && (($1 == "DEFINITION") || ($1 == "PROCEDURE")) { + split($2, parts, "[ (;]") + ident = parts[1] + sub($1"[ \t]+"ident, $1" "ident"", $0) +} + +((commentLevel == 0) && match($0, /"|\(\*/)) || ((commentLevel > 0) && match($0, /\(\*|\*\)/)) { + insideString = 0 + head = "" + tail = $0 + do { + delim = substr(tail, RSTART, RLENGTH) + head = head""substr(tail, 1, RSTART - 1) + if (delim == "\"") { + if (! insideString) { + head = head"\"" + insideString = 1 + } else { + head = head"\"" + insideString = 0 + } + } else if (delim == "(*") { + if (commentLevel == 0) { + head = head"(*" + } else { + head = head"(*" + } + commentLevel++ + } else if (delim == "*)") { + if (commentLevel == 1) { + head = head"*)" + } else { + head = head"*)" + } + commentLevel-- + } else { + print "obncdoc-markup: invalid match" > "/dev/stderr" + exit(1) + } + tail = substr(tail, RSTART + RLENGTH) + if (insideString) { + match(tail, /"/) + } else if (commentLevel > 0) { + match(tail, /\(\*|\*\)/) + } else { + match(tail, /"|\(\*|\*\)/) + } + } while (RSTART > 0) + $0 = head""tail +} + +{ + print $0 +} diff --git a/bin/obncdoc-test b/bin/obncdoc-test new file mode 100755 index 0000000..59011e1 --- /dev/null +++ b/bin/obncdoc-test @@ -0,0 +1,47 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o errexit -o nounset + +readonly selfDirPath="$(cd "$(dirname "$0")"; pwd -P)" +readonly packagePath="$(dirname "$selfDirPath")" +readonly testDir="$packagePath/tests/obncdoc" + +(cd "$testDir" && "$selfDirPath/obncdoc") +trap "rm -f '$testDir'/obncdoc/* && rmdir '$testDir/obncdoc'" INT TERM EXIT + +if ! diff -b "$testDir/obncdoc/NoExportedFeatures.def" "$testDir/NoExportedFeatures.def"; then + echo "$(basename "$0") failed: files differ: $testDir/obncdoc/NoExportedFeatures.def" "$testDir/NoExportedFeatures.def" >&2 + exit 1 +fi + +if ! diff -b "$testDir/obncdoc/NoExportedFeatures.def.html" "$testDir/NoExportedFeatures.def.html"; then + echo "$(basename "$0") failed: files differ: $testDir/obncdoc/NoExportedFeatures.def.html" "$testDir/NoExportedFeatures.def.html" >&2 + exit 1 +fi + +if ! diff -b "$testDir/obncdoc/ExportedFeatures.def" "$testDir/ExportedFeatures.def"; then + echo "$(basename "$0") failed: files differ: $testDir/obncdoc/ExportedFeatures.def" "$testDir/ExportedFeatures.def" >&2 + exit 1 +fi + +if ! diff -b "$testDir/obncdoc/ExportedFeatures.def.html" "$testDir/ExportedFeatures.def.html"; then + echo "$(basename "$0") failed: files differ: $testDir/obncdoc/ExportedFeatures.def.html" "$testDir/ExportedFeatures.def.html" >&2 + exit 1 +fi diff --git a/build b/build new file mode 100755 index 0000000..a373f50 --- /dev/null +++ b/build @@ -0,0 +1,323 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o errexit -o nounset + +readonly selfDirPath="$(cd "$(dirname "$0")"; pwd -P)" +readonly LEX="${LEX:-lex}" +readonly YACC="${YACC:-yacc}" +prefix="/usr/local" +libdir="lib" +cIntType=int +cRealType=double + +EchoAndRun() +{ + echo "$@" + eval "$@" +} + + +BuildCSource() +{ + EchoAndRun cd "$selfDirPath/src" + + if [ ! -e lex.yy.c ] || [ ! -e lex.yy.h ] || [ lex.yy.c -ot Oberon.l ] || [ lex.yy.h -ot Oberon.l ]; then + EchoAndRun "$LEX" --header-file=lex.yy.h Oberon.l + else + echo "lex.yy.c and lex.yy.h is up to date" + fi + + if [ ! -e y.tab.c ] || [ ! -e y.tab.h ] || [ y.tab.c -ot Oberon.y ]; then + local tmpdir="${TMPDIR:-/tmp}" + local bakFile="$tmpdir/y.tab.h.$$" + + if [ -e y.tab.h ]; then + cp -p y.tab.h "$bakFile" + trap "rm '$bakFile'" EXIT + fi + + #option -D is a Bison extension to POSIX yacc + if ! EchoAndRun "$YACC" -D parse.error=verbose -d -t Oberon.y; then + EchoAndRun "$YACC" -d -t Oberon.y + fi + + #preserve timestamp of y.tab.h if it is unchanged + if cmp -s y.tab.h "$bakFile"; then + cp -p "$bakFile" y.tab.h + fi + else + echo "y.tab.c and y.tab.h is up to date" + fi + + cd "$selfDirPath" +} + + +Build() +{ + if [ -e "VERSION" ]; then + local version="$(cat VERSION)" + else + local version= + fi + + #generate configuration file for install script + if [ -e CONFIG ]; then + cp CONFIG CONFIG.bak + trap "rm $selfDirPath/CONFIG.bak" EXIT + fi + { + echo "prefix=$prefix" + echo "libdir=$libdir" + echo "cIntType=$cIntType" + echo "cRealType=$cRealType" + echo "version=$version" + } > CONFIG + + if ! { [ -e CONFIG.bak ] && cmp -s CONFIG CONFIG.bak; }; then + #generate configuration header files + { + echo "#ifndef CONFIG_H" + echo "#define CONFIG_H" + echo + printf "#define CONFIG_DEFAULT_PREFIX \"%s\"\n" "$prefix" + printf "#define CONFIG_DEFAULT_LIBDIR \"%s\"\n" "$libdir" + printf "#define CONFIG_VERSION \"%s\"\n" "$version" + echo + echo "void Config_Init(void);" + echo "const char *Config_Prefix(void);" + echo "const char *Config_LibDir(void);" + echo + echo "#endif" + } > src/Config.h + { + echo "#ifndef OBNC_CONFIG_H" + echo "#define OBNC_CONFIG_H" + echo + echo "#define OBNC_CONFIG_SHORT 0" + echo "#define OBNC_CONFIG_INT 1" + echo "#define OBNC_CONFIG_LONG 2" + echo "#define OBNC_CONFIG_LONG_LONG 3" + echo + echo "#define OBNC_CONFIG_FLOAT 0" + echo "#define OBNC_CONFIG_DOUBLE 1" + echo "#define OBNC_CONFIG_LONG_DOUBLE 2" + echo + echo "#ifndef OBNC_CONFIG_C_INT_TYPE" + case "$cIntType" in + short) + echo "#define OBNC_CONFIG_C_INT_TYPE OBNC_CONFIG_SHORT";; + int) + echo "#define OBNC_CONFIG_C_INT_TYPE OBNC_CONFIG_INT";; + long) + echo "#define OBNC_CONFIG_C_INT_TYPE OBNC_CONFIG_LONG";; + longlong) + echo "#define OBNC_CONFIG_C_INT_TYPE OBNC_CONFIG_LONG_LONG";; + esac + echo "#endif" + echo + echo "#ifndef OBNC_CONFIG_C_REAL_TYPE" + case "$cRealType" in + float) + echo "#define OBNC_CONFIG_C_REAL_TYPE OBNC_CONFIG_FLOAT";; + double) + echo "#define OBNC_CONFIG_C_REAL_TYPE OBNC_CONFIG_DOUBLE";; + longdouble) + echo "#define OBNC_CONFIG_C_REAL_TYPE OBNC_CONFIG_LONG_DOUBLE";; + esac + echo "#endif" + echo + echo "#ifndef OBNC_CONFIG_TARGET_EMB" + echo "#define OBNC_CONFIG_TARGET_EMB 0" + echo "#endif" + echo + echo "#endif" + } > lib/obnc/OBNCConfig.h + fi + + BuildCSource + + #build compiler + EchoAndRun cd "$selfDirPath/src" + env CFLAGS="${CFLAGS:-}" "$selfDirPath/bin/micb" obnc-compile.c + if [ ! -e "$selfDirPath/bin/obnc-compile" ] || [ "$selfDirPath/bin/obnc-compile" -ot obnc-compile ]; then + cp obnc-compile "$selfDirPath/bin" + fi + + #build core library module OBNC + EchoAndRun cd "$selfDirPath/lib/obnc" + "$selfDirPath/bin/micb" OBNCTest.c + + #build build command + EchoAndRun cd "$selfDirPath/src" + env CFLAGS="${CFLAGS:-}" "$selfDirPath/bin/micb" obnc.c + if [ ! -e "$selfDirPath/bin/obnc" ] || [ "$selfDirPath/bin/obnc" -ot obnc ]; then + cp obnc "$selfDirPath/bin" + fi + + #build path finder + EchoAndRun cd "$selfDirPath/src" + env CFLAGS="${CFLAGS:-}" "$selfDirPath/bin/micb" obnc-path.c + if [ ! -e "$selfDirPath/bin/obnc-path" ] || [ "$selfDirPath/bin/obnc-path" -ot obnc-path ]; then + cp obnc-path "$selfDirPath/bin" + fi + + #build documentation generator + EchoAndRun cd "$selfDirPath/src" + env CFLAGS="${CFLAGS:-}" "$selfDirPath/bin/micb" obncdoc.c + if [ ! -e "$selfDirPath/bin/obncdoc" ] || [ "$selfDirPath/bin/obncdoc" -ot obncdoc ]; then + cp obncdoc "$selfDirPath/bin" + fi + + cd "$selfDirPath" +} + + +Clean() +{ + rm -f CONFIG + rm -f CONFIG.bak + + rm -f bin/obnc + rm -f bin/obnc-compile + rm -f bin/obnc-path + rm -f bin/obncdoc + rm -f bin/*.exe + + rm -f src/obnc + rm -f src/obnc-compile + rm -f src/obnc-path + rm -f src/obncdoc + rm -f src/?*Test + rm -f src/*.exe + rm -f src/*.o + rm -f src/Config.h + + rm -f lib/obnc/?*Test + rm -f lib/obnc/*.exe + rm -f lib/obnc/*.o + rm -fr lib/obnc/.obnc + rm -f lib/obnc/OBNCConfig.h +} + + +CleanAll() +{ + Clean + rm -f src/lex.yy.[ch] + rm -f src/y.tab.[ch] +} + + +PrintHelp() +{ + echo "usage: " + printf "\tbuild [c-source | clean | clean-all] [--c-int-type=(short|int|long|longlong)] [--c-real-type=(float|double|longdouble)] [--libdir=LIBDIR] [--prefix=PREFIX]\n" + printf "\tbuild -h\n" + echo + printf "\tc-source\tbuild only Yacc and Lex C source files\n" + printf "\tclean\t\tdelete all generated files except Yacc and Lex C files\n" + printf "\tclean-all\tdelete all generated files\n" + printf "\t--c-int-type\tC type for INTEGER and SET (defaults to int)\n" + printf "\t--c-real-type\tC type for REAL (defaults to double)\n" + printf "\t--libdir\tlibrary installation directory instead of lib\n" + printf "\t--prefix\ttoplevel installation directory instead of /usr/local\n" + printf "\t-h\t\tdisplay help and exit\n" +} + + +ExitInvalidCommand() +{ + echo "Try 'build -h' for more information." >&2 + exit 1 +} + + +PathAbsolute() +{ + local path="$1" + + test "${prefix#/}" != "$prefix" || test "${prefix#[A-Za-z]:}" != "$prefix" +} + + +Run() +{ + local helpWanted=false + local action= + local arg= + + for arg in "$@"; do + case "$arg" in + c-source) + action=c-source;; + clean) + action=clean;; + clean-all) + action=clean-all;; + --c-int-type=*) + cIntType="${arg#--c-int-type=}" + if ! { echo "$cIntType" | grep -q '^\(short\|int\|long\|longlong\)$'; }; then + echo "invalid operand for option c-int-type: $cIntType" >&2 + ExitInvalidCommand + fi;; + --c-real-type=*) + cRealType="${arg#--c-real-type=}" + if ! { echo "$cRealType" | grep -q '^\(float\|double\|longdouble\)$'; }; then + echo "invalid operand for option c-real-type: $cRealType" >&2 + ExitInvalidCommand + fi;; + --libdir=*) + libdir="${arg#--libdir=}" + if [ "${libdir#*/}" != "$libdir" ]; then + echo "operand for option 'libdir' must be a directory name, not a path: $prefix" >&2 + exit 1 + fi;; + --prefix=*) + prefix="${arg#--prefix=}" + if ! PathAbsolute "$prefix"; then + echo "operand for option 'prefix' must be an absolute path: $prefix" >&2 + exit 1 + fi;; + -h) + helpWanted=true;; + *) + echo "invalid argument: $arg" + ExitInvalidCommand + esac + done + + if "$helpWanted"; then + PrintHelp + else + case "$action" in + c-source) + BuildCSource;; + clean) + Clean;; + clean-all) + CleanAll;; + *) + Build + esac + fi +} + +Run "$@" diff --git a/install b/install new file mode 100755 index 0000000..83c5c5c --- /dev/null +++ b/install @@ -0,0 +1,225 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o errexit -o nounset + +readonly selfDirPath="$(cd "$(dirname "$0")"; pwd -P)" +readonly prefix="$(awk -F '=' '$1 == "prefix" { print $2; }' CONFIG)" +readonly libdir="$(awk -F '=' '$1 == "libdir" { print $2; }' CONFIG)" +destdir= +includeLibCSrc=false + +readonly scripts="obncdoc-extract obncdoc-index obncdoc-markup" +readonly basicModules="Files In Input Input0 Math Out Strings XYplane" +readonly docFiles="oberon-report.html" +readonly man1Files="obnc.1 obnc-compile.1 obnc-path.1 obncdoc.1" + +EchoAndRun() +{ + echo "$@" + eval "$@" +} + + +Install() +{ + #install core files + EchoAndRun mkdir -p "$destdir$prefix/bin" + EchoAndRun cp "bin/obnc" "$destdir$prefix/bin" + EchoAndRun cp "bin/obnc-compile" "$destdir$prefix/bin" + EchoAndRun cp "bin/obnc-path" "$destdir$prefix/bin" + EchoAndRun cp "bin/obncdoc" "$destdir$prefix/bin" + local file= + for file in $scripts; do + EchoAndRun sed -e '"s|^\(readonly defaultPrefix=\).*$|\1'"'$prefix'"'|"' \ + -e '"s|^\(readonly defaultLibDir=\).*$|\1'"'$libdir'"'|"' \ + '"bin/'$file'"' \> '"'$destdir$prefix/bin/$file'"' + EchoAndRun chmod +x "$destdir$prefix/bin/$file" + done + EchoAndRun mkdir -p "$destdir$prefix/include/obnc" + EchoAndRun cp "lib/obnc/OBNCConfig.h" "$destdir$prefix/include/obnc" + EchoAndRun cp "lib/obnc/OBNC.h" "$destdir$prefix/include/obnc" + EchoAndRun mkdir -p "$destdir$prefix/$libdir/obnc" + EchoAndRun cp "lib/obnc/OBNC.o" "$destdir$prefix/$libdir/obnc" + EchoAndRun cp "lib/obnc/OBNC.env" "$destdir$prefix/$libdir/obnc" + if "$includeLibCSrc"; then + EchoAndRun sed -e '"s|#include \"OBNC\.h\"|#include |"' lib/obnc/OBNC.c \> "'$destdir$prefix/$libdir/obnc/OBNC.c'" + fi + + #install basic library + rm -rf "lib/obnc/.obnc" + local module= + for module in $basicModules; do + #allow installation to proceed even if some optional libraries (like SDL) are missing + if (cd "lib/obnc" && env OBNC_PREFIX="$destdir$prefix" CFLAGS="-I$destdir$prefix/include" "$destdir$prefix/bin/obnc" "${module}Test.obn"); then + EchoAndRun cp "lib/obnc/.obnc/$module.h" "$destdir$prefix/include/obnc" + EchoAndRun cp "lib/obnc/.obnc/$module.o" "$destdir$prefix/$libdir/obnc" + EchoAndRun cp "lib/obnc/.obnc/$module.sym" "$destdir$prefix/$libdir/obnc" + EchoAndRun cp "lib/obnc/.obnc/$module.imp" "$destdir$prefix/$libdir/obnc" + if [ -e "lib/obnc/$module.env" ]; then + EchoAndRun cp "lib/obnc/$module.env" "$destdir$prefix/$libdir/obnc" + fi + if "$includeLibCSrc"; then + local source="lib/obnc/$module.c" + if [ ! -e "$source" ]; then + source="lib/obnc/.obnc/$module.c" + fi + EchoAndRun sed -e "'s|#include \"\(\.obnc/\)\?\([^.]*\)\.h\"|#include |'" "'$source'" \> "'$destdir$prefix/$libdir/obnc/$module.c'" + fi + fi + done + rm -r "lib/obnc/.obnc" + + #install documentation + EchoAndRun mkdir -p "$destdir$prefix/share/doc/obnc" + for file in $docFiles; do + EchoAndRun cp "share/doc/obnc/$file" "$destdir$prefix/share/doc/obnc" + done + (cd "lib/obnc" && OBNC_PREFIX="$selfDirPath" ../../bin/obncdoc) + EchoAndRun mkdir -p "$destdir$prefix/share/doc/obnc/obncdoc/obnc" + for file in "lib/obnc/obncdoc"/*; do + EchoAndRun cp "$file" "$destdir$prefix/share/doc/obnc/obncdoc/obnc" + done + EchoAndRun cd "$destdir$prefix/share/doc/obnc/obncdoc" + EchoAndRun "$selfDirPath/bin/obncdoc-index" \> index.html + EchoAndRun cp "$selfDirPath/share/obnc/style.css" . + cd - >/dev/null + rm -r lib/obnc/obncdoc + + #install man pages + EchoAndRun mkdir -p "$destdir$prefix/share/man/man1" + for file in $man1Files; do + EchoAndRun cp "share/man/man1/$file" "$destdir$prefix/share/man/man1" + done + + #install obncdoc style file + EchoAndRun mkdir -p "$destdir$prefix/share/obnc" + EchoAndRun cp "$selfDirPath/share/obnc/style.css" "$destdir$prefix/share/obnc" +} + + +Uninstall() +{ + #delete executables + EchoAndRun rm -f "$destdir$prefix/bin/obnc" + EchoAndRun rm -f "$destdir$prefix/bin/obnc-compile" + EchoAndRun rm -f "$destdir$prefix/bin/obnc-path" + EchoAndRun rm -f "$destdir$prefix/bin/obncdoc" + local file= + for file in $scripts; do + EchoAndRun rm -f "$destdir$prefix/bin/$file" + done + + #delete library files + local module= + for module in $basicModules; do + EchoAndRun rm -f "$destdir$prefix/include/obnc/$module.h" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/$module.o" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/$module.sym" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/$module.imp" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/$module.env" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/$module.c" + done + EchoAndRun rm -f "$destdir$prefix/include/obnc/OBNC.h" + EchoAndRun rm -f "$destdir$prefix/include/obnc/OBNCConfig.h" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/OBNC.o" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/OBNC.env" + EchoAndRun rm -f "$destdir$prefix/$libdir/obnc/OBNC.c" + + #delete documentation + for file in $docFiles; do + EchoAndRun rm -f "$destdir$prefix/share/doc/obnc/$file" + done + EchoAndRun rm -f "$destdir$prefix/share/doc/obnc/obncdoc/obnc/"* + EchoAndRun rm -f "$destdir$prefix/share/doc/obnc/obncdoc/index.html" + EchoAndRun rm -f "$destdir$prefix/share/doc/obnc/obncdoc/style.css" + + #delete man pages + for file in $man1Files; do + EchoAndRun rm -f "$destdir$prefix/share/man/man1/$file" + done + + #delete obncdoc style file + EchoAndRun rm -f "$destdir$prefix/share/obnc/style.css" +} + + +PrintHelp() +{ + echo "usage: " + printf "\tinstall [u] [--destdir=DESTDIR] [--include-lib-c-src]\n" + printf "\tinstall -h\n" + echo + printf "\tu\t\t\tuninstall\n" + printf "\t--destdir\t\tspecify directory for staged installation\n" + printf "\t--include-lib-c-src\tmake cross compilation possible\n" + printf "\t-h\t\t\tdisplay help and exit\n" +} + + +ExitInvalidCommand() +{ + echo "invalid command. Try 'install -h' for more information." >&2 + exit 1 +} + + +Run() +{ + local helpWanted=false + local uninstall=false + local arg= + + for arg in "$@"; do + case "$arg" in + u) + uninstall=true;; + --destdir=*) + destdir="${arg#--destdir=}";; + --include-lib-c-src) + includeLibCSrc=true;; + -h) + helpWanted=true;; + *) + ExitInvalidCommand + esac + done + + if "$helpWanted"; then + PrintHelp + else + if [ -e CONFIG ]; then + if [ "$prefix" != "${prefix#/}" ]; then + if "$uninstall"; then + Uninstall + else + Install + fi + else + printf "prefix must be an absolute path: %s\ninstallation aborted\n" "$prefix" >&2 + exit 1 + fi + else + printf "must first run build script\ninstallation aborted\n" >&2 + exit 1 + fi + fi +} + +Run "$@" diff --git a/lib/obnc/Files.c b/lib/obnc/Files.c new file mode 100644 index 0000000..0680fd0 --- /dev/null +++ b/lib/obnc/Files.c @@ -0,0 +1,768 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include ".obnc/Files.h" +#include +#ifdef _WIN32 + #include +#else + #include +#endif +#include +#include +#include +#include +#include +#include +#include + +#define LEN(arr) ((int) (sizeof (arr) / sizeof (arr)[0])) + +typedef struct Handle *File; + +struct Handle { + Files__Handle_ base; + FILE *file; + char *name; + int registered; +}; + +struct HeapHandle { + const OBNC_Td *td; + struct Handle fields; +}; + +const int Files__Handle_id; +const int *const Files__Handle_ids[1] = {&Files__Handle_id}; +const OBNC_Td Files__Handle_td = {Files__Handle_ids, 1}; + +const int Files__Rider_id; +const int *const Files__Rider_ids[1] = {&Files__Rider_id}; +const OBNC_Td Files__Rider_td = {Files__Rider_ids, 1}; + +static int FileExists(const char name[]) +{ +#ifdef _WIN32 + DWORD attr = GetFileAttributes(name); + + return (attr != INVALID_FILE_ATTRIBUTES && + ! (attr & FILE_ATTRIBUTE_DIRECTORY)); +#else + return access(name, F_OK ) != -1; +#endif +} + + +static void CheckTermination(const char s[], OBNC_INTEGER sLen) +{ + OBNC_INTEGER i; + + i = 0; + while ((i < sLen) && (s[i] != '\0')) { + i++; + } + OBNC_C_ASSERT(i < sLen); +} + + +static File NewFile(FILE *file, const char name[], int registered) +{ + File result; + size_t nameLen; + + OBNC_C_ASSERT(file != NULL); + OBNC_C_ASSERT(name != NULL); + + OBNC_NEW(result, &Files__Handle_td, struct HeapHandle, OBNC_REGULAR_ALLOC); + if (result != NULL) { + result->file = file; + nameLen = strlen(name) + 1; + result->name = OBNC_Allocate(nameLen, OBNC_ATOMIC_NOINIT_ALLOC); + if (result->name != NULL) { + memcpy(result->name, name, nameLen); + result->registered = registered; + } else { + result = NULL; + } + } + return result; +} + + +Files__File_ Files__Old_(const char name[], OBNC_INTEGER nameLen) +{ + FILE *file; + File result; + + OBNC_C_ASSERT(name != NULL); + OBNC_C_ASSERT(nameLen >= 0); + CheckTermination(name, nameLen); + + file = fopen(name, "r+b"); + if (file == NULL) { + file = fopen(name, "rb"); + if ((file == NULL) && FileExists(name)) { + file = fopen(name, "ab"); + } + } + if (file != NULL) { + result = NewFile(file, name, 1); + } else { + result = NULL; + } + return (Files__File_) result; +} + + +Files__File_ Files__New_(const char name[], OBNC_INTEGER nameLen) +{ + FILE *file; + File result; + + OBNC_C_ASSERT(name != NULL); + OBNC_C_ASSERT(nameLen >= 0); + CheckTermination(name, nameLen); + + file = tmpfile(); + if (file != NULL) { + result = NewFile(file, name, 0); + } else { + result = NULL; + fprintf(stderr, "Files.New failed: %s\n", strerror(errno)); + } + return (Files__File_) result; +} + + +static void Copy(FILE *src, FILE *dst, const char dstName[], int *done) +{ + int ch; + + rewind(src); + ch = fgetc(src); + while (ch != EOF) { + ch = fputc(ch, dst); + if (ch != EOF) { + ch = fgetc(src); + } + } + *done = ! ferror(src) && ! ferror(dst); + if (ferror(src) || ferror(dst)) { + fprintf(stderr, "Files.Register failed: %s: %s\n", dstName, strerror(errno)); + } +} + + +void Files__Register_(Files__File_ file) +{ + File f; + FILE *new; + int done; + + OBNC_C_ASSERT(file != NULL); + + f = (File) file; + if (! f->registered) { + new = fopen(f->name, "w+b"); + if (new != NULL) { + Copy(f->file, new, f->name, &done); + if (done) { + f->file = new; + f->registered = 1; + } + } else { + fprintf(stderr, "Files.Register failed: %s: %s\n", f->name, strerror(errno)); + } + } +} + + +void Files__Close_(Files__File_ file) +{ + File f; + int error; + + OBNC_C_ASSERT(file != NULL); + + f = (File) file; + error = fflush(f->file); + if (error) { + fprintf(stderr, "Files.Close failed: %s: %s\n", f->name, strerror(errno)); + } +} + + +void Files__Purge_(Files__File_ file) +{ + File f; + int error; + + OBNC_C_ASSERT(file != NULL); + + f = ((File) file); + error = fclose(f->file); + if (! error) { + if (f->registered) { + f->file = fopen(f->name, "w+b"); + } else { + f->file = tmpfile(); + } + if (f->file == NULL) { + fprintf(stderr, "Files.Purge failed: %s: %s\n", f->name, strerror(errno)); + } + } else { + fprintf(stderr, "Files.Purge failed: %s: %s\n", f->name, strerror(errno)); + } +} + + +void Files__Delete_(const char name[], OBNC_INTEGER nameLen, OBNC_INTEGER *res) +{ + OBNC_C_ASSERT(name != NULL); + OBNC_C_ASSERT(nameLen >= 0); + CheckTermination(name, nameLen); + + *res = unlink(name); + if (*res != 0) { + fprintf(stderr, "Files.Delete failed: %s: %s\n", name, strerror(errno)); + } +} + + +void Files__Rename_(const char old[], OBNC_INTEGER oldLen, const char new[], OBNC_INTEGER newLen, OBNC_INTEGER *res) +{ + OBNC_C_ASSERT(old != NULL); + OBNC_C_ASSERT(oldLen >= 0); + CheckTermination(old, oldLen); + OBNC_C_ASSERT(new != NULL); + OBNC_C_ASSERT(newLen >= 0); + CheckTermination(new, newLen); + + *res = rename(old, new); + if (*res != 0) { + fprintf(stderr, "Files.Rename failed: %s: %s\n", old, strerror(errno)); + } +} + + +OBNC_INTEGER Files__Length_(Files__File_ file) +{ + File f; + long int result; + int error; + + OBNC_C_ASSERT(file != NULL); + + f = (File) file; + result = 0; + error = fseek(f->file, 0, SEEK_END); + if (! error) { + result = ftell(f->file); + if (result < 0) { + fprintf(stderr, "Files.Length failed: %s: %s\n", f->name, strerror(errno)); + } else if (result > OBNC_INT_MAX) { + fprintf(stderr, "Files.Length failed: %s: length exceeds maximum value of INTEGER (%" OBNC_INT_MOD "d)\n", f->name, (OBNC_INTEGER) OBNC_INT_MAX); + } + } else { + fprintf(stderr, "Files.Length failed: %s: %s\n", f->name, strerror(errno)); + } + return (OBNC_INTEGER) result; +} + + +void Files__GetDate_(Files__File_ file, OBNC_INTEGER *t, OBNC_INTEGER *d) +{ + File f; + struct stat statResult; + int error; + struct tm *td; + + OBNC_C_ASSERT(file != NULL); + OBNC_C_ASSERT(t != NULL); + OBNC_C_ASSERT(d != NULL); + OBNC_C_ASSERT(sizeof (OBNC_INTEGER) >= 4); + + f = (File) file; + if (f->registered) { + error = stat(f->name, &statResult); + if (! error) { + td = localtime(&(statResult.st_mtime)); + if (td != NULL) { + *t = (td->tm_hour << 12) | (td->tm_min << 6) | td->tm_sec; /*59 < 2^6*/ + *d = ((1900 + td->tm_year) << 9) | ((td->tm_mon + 1) << 5) | td->tm_mday; /*31 < 2^5 and 12 < 2^4*/ + } else { + fprintf(stderr, "Files.GetDate failed: %s: %s\n", f->name, strerror(errno)); + } + } else { + fprintf(stderr, "Files.GetDate failed: %s: %s\n", f->name, strerror(errno)); + } + } else { + *t = 0; + *d = 0; + fprintf(stderr, "Files.GetDate failed: %s: cannot get date of unregistered file\n", f->name); + } +} + + +void Files__Set_(Files__Rider_ *r, const OBNC_Td *rTD, Files__File_ f, OBNC_INTEGER pos) +{ + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(f != NULL); + OBNC_C_ASSERT(pos >= 0); + OBNC_C_ASSERT(pos <= Files__Length_(f)); + + r->eof_ = 0; + r->base_ = f; + r->pos_ = pos; +} + + +OBNC_INTEGER Files__Pos_(Files__Rider_ *r, const OBNC_Td *rTD) +{ + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + return r->pos_; +} + + +Files__File_ Files__Base_(Files__Rider_ *r, const OBNC_Td *rTD) +{ + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + return r->base_; +} + + +static void Position(const Files__Rider_ *r, FILE **fp) +{ + File f; + int error; + + f = (File) (r->base_); + *fp = f->file; + error = fseek(*fp, r->pos_, SEEK_SET); + if (error) { + fprintf(stderr, "Positioning rider failed: %s: %s\n", f->name, strerror(errno)); + *fp = NULL; + } +} + + +static const char *BaseName(const Files__Rider_ *r) +{ + return ((File) (r->base_))->name; +} + + +void Files__Read_(Files__Rider_ *r, const OBNC_Td *rTD, unsigned char *x) +{ + FILE *fp; + int ch; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(x != NULL); + + Position(r, &fp); + if (fp != NULL) { + ch = fgetc(fp); + if (ch != EOF) { + *x = (unsigned char) ch; + r->pos_++; + } else { + if (feof(fp)) { + r->eof_ = 1; + } else if (ferror(fp)) { + fprintf(stderr, "Files.Read failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } + } +} + + +void Files__ReadInt_(Files__Rider_ *r, const OBNC_Td *rTD, OBNC_INTEGER *i) +{ + FILE *fp; + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(i != NULL); + + Position(r, &fp); + if (fp != NULL) { + n = fread(i, sizeof (*i), 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof (*i)); + if (feof(fp)) { + r->eof_ = 1; + } else if (ferror(fp)) { + fprintf(stderr, "Files.ReadInt failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__ReadReal_(Files__Rider_ *r, const OBNC_Td *rTD, OBNC_REAL *x) +{ + FILE *fp; + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(x != NULL); + + Position(r, &fp); + if (fp != NULL) { + n = fread(x, sizeof (*x), 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof (*x)); + if (feof(fp)) { + r->eof_ = 1; + } else if (ferror(fp)) { + fprintf(stderr, "Files.ReadReal failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__ReadNum_(Files__Rider_ *r, const OBNC_Td *rTD, OBNC_INTEGER *x) +{ + FILE *fp; + OBNC_INTEGER s, n; + int ch, y, z; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(x != NULL); + OBNC_C_ASSERT(sizeof (OBNC_INTEGER) >= 4); + + Position(r, &fp); + if (fp != NULL) { + n = 0; + s = 0; + ch = fgetc(fp); + while (ch >= 128) { + r->pos_++; + n += (ch - 128) << s; + s += 7; + ch = fgetc(fp); + } + if (ch != EOF) { + r->pos_++; + y = OBNC_MOD(ch, 64) - OBNC_DIV(ch, 64) * 64; + if (y < 0) { + z = -((-y) << s); + } else { + z = y << s; + } + *x = n + z; + } else { + if (feof(fp)) { + r->eof_ = 1; + } else if (ferror(fp)) { + fprintf(stderr, "Files.ReadNum failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } + } +} + + +void Files__ReadString_(Files__Rider_ *r, const OBNC_Td *rTD, char s[], OBNC_INTEGER sLen) +{ + FILE *fp; + int ch; + OBNC_INTEGER i; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(s != NULL); + OBNC_C_ASSERT(sLen >= 0); + + Position(r, &fp); + if (fp != NULL) { + ch = fgetc(fp); + i = 0; + while ((ch != EOF) && (ch != '\0') && (i < sLen - 1)) { + s[i] = (char) ch; + ch = fgetc(fp); + i++; + } + if (ch != EOF) { + if (ch == '\0') { + s[i] = '\0'; + } else { /*string doesn't fit*/ + s[0] = '\0'; + } + r->pos_ += i + 1; + } else { + if (feof(fp)) { + r->eof_ = 1; + } else if (ferror(fp)) { + fprintf(stderr, "Files.ReadString failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } + } +} + + +void Files__ReadSet_(Files__Rider_ *r, const OBNC_Td *rTD, unsigned OBNC_INTEGER *s) +{ + FILE *fp; + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(s != NULL); + + Position(r, &fp); + if (fp != NULL) { + n = fread(s, sizeof (*s), 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof (*s)); + if (feof(fp)) { + r->eof_ = 1; + } else if (ferror(fp)) { + fprintf(stderr, "Files.ReadSet failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__ReadBool_(Files__Rider_ *r, const OBNC_Td *rTD, int *b) +{ + FILE *fp; + int ch; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(b != NULL); + + Position(r, &fp); + if (fp != NULL) { + ch = fgetc(fp); + if (ch != EOF) { + *b = ch; + r->pos_++; + } else { + if (feof(fp)) { + r->eof_ = 1; + } if (ferror(fp)) { + fprintf(stderr, "Files.ReadBool failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } + } +} + + +static OBNC_INTEGER Min(OBNC_INTEGER a, OBNC_INTEGER b) +{ + return (a < b)? a: b; +} + + +void Files__ReadBytes_(Files__Rider_ *r, const OBNC_Td *rTD, unsigned char buf[], OBNC_INTEGER bufLen, OBNC_INTEGER n) +{ + FILE *fp; + size_t nRead; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(buf != NULL); + OBNC_C_ASSERT(bufLen >= 0); + OBNC_C_ASSERT(n >= 0); + + Position(r, &fp); + if (fp != NULL) { + nRead = fread(buf, sizeof buf[0], (size_t) Min(n, bufLen), fp); + r->pos_ += (OBNC_INTEGER) (nRead * sizeof buf[0]); + r->res_ = n - (OBNC_INTEGER) nRead; + if (feof(fp)) { + r->eof_ = 1; + } else if (ferror(fp)) { + fprintf(stderr, "Files.ReadBytes failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__Write_(Files__Rider_ *r, const OBNC_Td *rTD, unsigned char x) +{ + FILE *fp; + int res; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + Position(r, &fp); + if (fp != NULL) { + res = fputc(x, fp); + if (res != EOF) { + r->pos_++; + } else { + fprintf(stderr, "Files.Write failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__WriteInt_(Files__Rider_ *r, const OBNC_Td *rTD, OBNC_INTEGER i) +{ + FILE *fp; + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + Position(r, &fp); + if (fp != NULL) { + n = fwrite(&i, sizeof i, 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof i); + if (ferror(fp)) { + fprintf(stderr, "Files.WriteInt failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__WriteReal_(Files__Rider_ *r, const OBNC_Td *rTD, OBNC_REAL x) +{ + FILE *fp; + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + Position(r, &fp); + if (fp != NULL) { + n = fwrite(&x, sizeof x, 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof x); + if (ferror(fp)) { + fprintf(stderr, "Files.WriteReal failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__WriteNum_(Files__Rider_ *r, const OBNC_Td *rTD, OBNC_INTEGER x) +{ + FILE *fp; + int i; + char buf[CHAR_BIT * sizeof x]; /* 10^x = 2^n implies x < n */ + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + i = 0; + while ((x < -64) || (x > 63)) { + OBNC_C_ASSERT(i < LEN(buf)); + buf[i] = (char) (OBNC_MOD(x, 128) + 128); + x = OBNC_DIV(x, 128); + i++; + } + OBNC_C_ASSERT(i < LEN(buf)); + buf[i] = (char) OBNC_MOD(x, 128); + + Position(r, &fp); + if (fp != NULL) { + n = fwrite(buf, sizeof buf[0], (size_t) i + 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof buf[0]); + if (ferror(fp)) { + fprintf(stderr, "Files.WriteNum failed: %s: %s\n", BaseName(r), strerror(errno)); + } + + } +} + + +void Files__WriteString_(Files__Rider_ *r, const OBNC_Td *rTD, const char s[], OBNC_INTEGER sLen) +{ + FILE *fp; + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(s != NULL); + OBNC_C_ASSERT(sLen >= 0); + CheckTermination(s, sLen); + + Position(r, &fp); + if (fp != NULL) { + n = fwrite(s, sizeof s[0], strlen(s) + 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof s[0]); + if (ferror(fp)) { + fprintf(stderr, "Files.WriteString failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__WriteSet_(Files__Rider_ *r, const OBNC_Td *rTD, unsigned OBNC_INTEGER s) +{ + FILE *fp; + size_t n; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + Position(r, &fp); + if (fp != NULL) { + n = fwrite(&s, sizeof s, 1, fp); + r->pos_ += (OBNC_INTEGER) (n * sizeof s); + if (ferror(fp)) { + fprintf(stderr, "Files.WriteSet failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__WriteBool_(Files__Rider_ *r, const OBNC_Td *rTD, int b) +{ + FILE *fp; + int res; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + + Position(r, &fp); + if (fp != NULL) { + res = fputc(!! b, fp); + if (res != EOF) { + r->pos_++; + } else { + fprintf(stderr, "Files.WriteBool failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__WriteBytes_(Files__Rider_ *r, const OBNC_Td *rTD, unsigned char buf[], OBNC_INTEGER bufLen, OBNC_INTEGER n) +{ + FILE *fp; + size_t nWritten; + + OBNC_C_ASSERT(r != NULL); + OBNC_C_ASSERT(r->base_ != NULL); + OBNC_C_ASSERT(buf != NULL); + OBNC_C_ASSERT(bufLen >= 0); + OBNC_C_ASSERT(n >= 0); + OBNC_C_ASSERT(n <= bufLen); + + Position(r, &fp); + if (fp != NULL) { + nWritten = fwrite(buf, sizeof buf[0], (size_t) n, fp); + r->pos_ += (OBNC_INTEGER) (nWritten * sizeof buf[0]); + r->res_ = n - (OBNC_INTEGER) nWritten; + if (ferror(fp)) { + fprintf(stderr, "Files.WriteBytes failed: %s: %s\n", BaseName(r), strerror(errno)); + } + } +} + + +void Files__Init(void) +{ +} diff --git a/lib/obnc/Files.obn b/lib/obnc/Files.obn new file mode 100644 index 0000000..054e28a --- /dev/null +++ b/lib/obnc/Files.obn @@ -0,0 +1,170 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE Files; +(**Operations on files + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*) + +(*implemented in C*) + + TYPE + File* = POINTER TO Handle; + + Handle = RECORD END; + + Rider* = RECORD + eof*: BOOLEAN; + res*: INTEGER; + base: File; + pos: INTEGER + END; + + PROCEDURE Old*(name: ARRAY OF CHAR): File; +(**Old(fn) searches the name fn in the directory and returns the corresponding file. If the name is not found, it returns NIL.*) + RETURN NIL + END Old; + + + PROCEDURE New*(name: ARRAY OF CHAR): File; +(**New(fn) creates and returns a new file. The name fn is remembered for the later use of the operation Register. The file is only entered into the directory when Register is called.*) + RETURN NIL + END New; + + + PROCEDURE Register*(f: File); +(**enters the file f into the directory together with the name provided in the operation New that created f. The file buffers are written back. Any existing mapping of this name to another file is overwritten.*) + END Register; + + + PROCEDURE Close*(f: File); +(**writes back the file buffers of f. The file is still accessible by its handle f and the riders positioned on it. If a file is not modified it is not necessary to close it.*) + END Close; + + + PROCEDURE Purge*(f: File); +(**resets the length of file f to 0*) + END Purge; + + + PROCEDURE Delete*(name: ARRAY OF CHAR; VAR res: INTEGER); +(**Delete(fn, res) removes the directory entry for the file fn without deleting the file. If res = 0 the file has been successfully deleted. If there are variables referring to the file while Delete is called, they can still be used.*) + END Delete; + + + PROCEDURE Rename*(old, new: ARRAY OF CHAR; VAR res: INTEGER); +(**Rename(oldfn, newfn, res) renames the directory entry oldfn to newfn. If res = 0 the file has been successfully renamed. If there are variables referring to the file while Rename is called, they can still be used.*) + END Rename; + + + PROCEDURE Length*(f: File): INTEGER; +(**returns the number of bytes in file f*) + RETURN 0 + END Length; + + + PROCEDURE GetDate*(f: File; VAR t, d: INTEGER); +(**returns the time t and date d of the last modification of file f. The encoding is: hour = t DIV 4096; minute = t DIV 64 MOD 64; second = t MOD 64; year = d DIV 512; month = d DIV 32 MOD 16; day = d MOD 32.*) + END GetDate; + + + PROCEDURE Set*(VAR r: Rider; f: File; pos: INTEGER); +(**sets the rider r to position pos in file f. The field r.eof is set to FALSE. The +operation requires that 0 <= pos <= Length(f)*) + END Set; + + + PROCEDURE Pos*(VAR r: Rider): INTEGER; +(**returns the position of the rider r*) + RETURN 0 + END Pos; + + + PROCEDURE Base*(VAR r: Rider): File; +(**returns the file to which the rider r has been set*) + RETURN NIL + END Base; + + PROCEDURE Read*(VAR r: Rider; VAR x: BYTE); +(**reads the next byte x from rider r and advances r accordingly*) + END Read; + + + PROCEDURE ReadInt*(VAR r: Rider; VAR i: INTEGER); +(**reads an integer i from rider r and advances r accordingly.*) + END ReadInt; + + + PROCEDURE ReadReal*(VAR r: Rider; VAR x: REAL); +(**reads a real number x from rider r and advances r accordingly.*) + END ReadReal; + + + PROCEDURE ReadNum*(VAR r: Rider; VAR i: INTEGER); +(**reads an integer i from rider r and advances r accordingly. The number i is compactly encoded*) + END ReadNum; + + + PROCEDURE ReadString*(VAR r: Rider; VAR s: ARRAY OF CHAR); +(**reads a sequence of characters (including the terminating 0X) from rider r and returns it in s. The rider is advanced accordingly. The actual parameter corresponding to s must be long enough to hold the character sequence plus the terminating 0X.*) + END ReadString; + + + PROCEDURE ReadSet*(VAR r: Rider; VAR s: SET); +(**reads a set s from rider r and advances r accordingly*) + END ReadSet; + + + PROCEDURE ReadBool*(VAR r: Rider; VAR b: BOOLEAN); +(**reads a Boolean value b from rider r and advances r accordingly*) + END ReadBool; + + + PROCEDURE ReadBytes*(VAR r: Rider; VAR buf: ARRAY OF BYTE; n: INTEGER); +(**reads n bytes into buffer buf starting at the rider position r. The rider is advanced accordingly. If less than n bytes could be read, r.res contains the number of requested but unread bytes.*) + END ReadBytes; + + + PROCEDURE Write*(VAR r: Rider; x: BYTE); +(**writes the byte x to rider r and advances r accordingly*) + END Write; + + + PROCEDURE WriteInt*(VAR r: Rider; i: INTEGER); +(**writes the integer i to rider r and advances r accordingly*) + END WriteInt; + + + PROCEDURE WriteReal*(VAR r: Rider; x: REAL); +(**writes the real number x to rider r and advances r accordingly*) + END WriteReal; + + + PROCEDURE WriteNum*(VAR r: Rider; i: INTEGER); +(**writes the integer i to rider r and advances r accordingly. The number i is compactly encoded.*) + END WriteNum; + + + PROCEDURE WriteString*(VAR r: Rider; s: ARRAY OF CHAR); +(**writes the sequence of characters s (including the terminating 0X) to rider r and advances r accordingly*) + END WriteString; + + + PROCEDURE WriteSet*(VAR r: Rider; s: SET); +(**writes the set s to rider r and advances r accordingly*) + END WriteSet; + + + PROCEDURE WriteBool*(VAR r: Rider; b: BOOLEAN); +(**writes the Boolean value b to rider r and advances r accordingly.*) + END WriteBool; + + + PROCEDURE WriteBytes*(VAR r: Rider; VAR buf: ARRAY OF BYTE; n: INTEGER); +(**writes the first n bytes from buf to rider r and advances r accordingly. r.res contains the number of bytes that could not be written (e.g., due to a disk full error).*) + END WriteBytes; + +END Files. diff --git a/lib/obnc/FilesTest.obn b/lib/obnc/FilesTest.obn new file mode 100644 index 0000000..26fe4de --- /dev/null +++ b/lib/obnc/FilesTest.obn @@ -0,0 +1,453 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE FilesTest; + + IMPORT Files, SYSTEM; + + PROCEDURE TestOld; + VAR f: Files.File; + BEGIN + f := Files.Old("FilesTest.obn"); + ASSERT(f # NIL); + ASSERT(f IS Files.File) + END TestOld; + + + PROCEDURE TestNew; + VAR f: Files.File; + BEGIN + f := Files.New("NewTest"); + ASSERT(f # NIL); + ASSERT(f IS Files.File) + END TestNew; + + + PROCEDURE TestRegister; + VAR f: Files.File; + r: Files.Rider; + res: INTEGER; + + PROCEDURE IsRider(VAR r: Files.Rider): BOOLEAN; + RETURN r IS Files.Rider + END IsRider; + BEGIN + f := Files.New("RegisterTest"); + ASSERT(f # NIL); + ASSERT(IsRider(r)); + Files.Register(f); + + f := Files.Old("RegisterTest"); + ASSERT(f # NIL); + Files.Delete("RegisterTest", res); + ASSERT(res = 0); + + f := Files.New("RegisterTest"); + ASSERT(f # NIL); + Files.Set(r, f, 0); + Files.Write(r, 37); + Files.Close(f); + Files.Register(f); + ASSERT(Files.Length(f) = 1); + + f := Files.Old("RegisterTest"); + ASSERT(f # NIL); + ASSERT(Files.Length(f) = 1); + Files.Delete("RegisterTest", res); + ASSERT(res = 0) + END TestRegister; + + + PROCEDURE TestClose; + VAR f: Files.File; + r: Files.Rider; + BEGIN + f := Files.New("CloseTest"); + ASSERT(f # NIL); + Files.Set(r, f, 0); + Files.Write(r, 65); + ASSERT(Files.Length(f) <= 1); + Files.Close(f); + ASSERT(Files.Length(f) = 1) + END TestClose; + + + PROCEDURE TestPurge; + VAR f: Files.File; + r: Files.Rider; + BEGIN + f := Files.New("PurgeTest"); + ASSERT(f # NIL); + Files.Set(r, f, 0); + Files.Write(r, 65); + Files.Purge(f); + ASSERT(Files.Length(f) = 0) + END TestPurge; + + + PROCEDURE TestDelete; + VAR f: Files.File; + res: INTEGER; + BEGIN + f := Files.New("DeleteTest"); + ASSERT(f # NIL); + Files.Register(f); + f := Files.Old("DeleteTest"); + ASSERT(f # NIL); + Files.Delete("DeleteTest", res); + ASSERT(res = 0); + f := Files.Old("DeleteTest"); + ASSERT(f = NIL) + END TestDelete; + + + PROCEDURE TestRename; + VAR f: Files.File; + res: INTEGER; + BEGIN + f := Files.New("RenameTest"); + ASSERT(f # NIL); + Files.Register(f); + f := Files.Old("RenameTest"); + ASSERT(f # NIL); + + Files.Rename("RenameTest", "RenameTest1", res); + ASSERT(res = 0); + + f := Files.Old("RenameTest"); + ASSERT(f = NIL); + f := Files.Old("RenameTest1"); + ASSERT(f # NIL); + + Files.Delete("RenameTest1", res); + ASSERT(res = 0) + END TestRename; + + + PROCEDURE TestLength; + VAR f: Files.File; + res: INTEGER; + BEGIN + f := Files.New("LengthTest"); + ASSERT(f # NIL); + Files.Register(f); + ASSERT(Files.Length(f) = 0); + Files.Delete("LengthTest", res); + ASSERT(res = 0) + END TestLength; + + + PROCEDURE TestDate; + VAR f: Files.File; + t, d: INTEGER; + hour, minute, second, year, month, day: INTEGER; + BEGIN + f := Files.Old("FilesTest.obn"); + ASSERT(f # NIL); + Files.GetDate(f, t, d); + hour := t DIV 4096; + ASSERT(hour >= 0); + ASSERT(hour < 24); + minute := t DIV 64 MOD 64; + ASSERT(minute >= 0); + ASSERT(minute < 60); + second := t MOD 64; + ASSERT(second >= 0); + ASSERT(second < 60); + year := d DIV 512; + ASSERT(year >= 0); + month := d DIV 32 MOD 16; + ASSERT(month >= 1); + ASSERT(month <= 12); + day := d MOD 32; + ASSERT(day >= 1); + ASSERT(day <= 31) + END TestDate; + + + PROCEDURE TestSet; + VAR f: Files.File; + r: Files.Rider; + BEGIN + f := Files.New("SetTest"); + ASSERT(f # NIL); + Files.Set(r, f, 0); + ASSERT(~r.eof) + END TestSet; + + + PROCEDURE TestPos; + VAR f: Files.File; + r: Files.Rider; + BEGIN + f := Files.New("PosTest"); + ASSERT(f # NIL); + Files.Set(r, f, 0); + ASSERT(Files.Pos(r) = 0) + END TestPos; + + + PROCEDURE TestBase; + VAR f: Files.File; + r: Files.Rider; + BEGIN + f := Files.New("BaseTest"); + ASSERT(f # NIL); + Files.Set(r, f, 0); + ASSERT(Files.Base(r) = f) + END TestBase; + + + PROCEDURE TestReadWrite; + VAR f: Files.File; + r: Files.Rider; + b: BYTE; + BEGIN + f := Files.New("ReadWriteTest"); + ASSERT(f # NIL); + Files.Set(r, f, 0); + Files.Write(r, 65); + Files.Close(f); + ASSERT(Files.Length(f) = 1); + Files.Set(r, f, 0); + Files.Read(r, b); + ASSERT(~r.eof); + ASSERT(b = 65); + ASSERT(Files.Pos(r) = 1) + END TestReadWrite; + + + PROCEDURE TestReadWriteInt; + VAR f: Files.File; + r: Files.Rider; + i: INTEGER; + BEGIN + f := Files.New("ReadWriteIntTest"); + ASSERT(f # NIL); + + Files.Set(r, f, 0); + Files.WriteInt(r, 100); + Files.WriteInt(r, -1000); + Files.Close(f); + + Files.Set(r, f, 0); + Files.ReadInt(r, i); + ASSERT(~r.eof); + ASSERT(i = 100); + Files.ReadInt(r, i); + ASSERT(~r.eof); + ASSERT(i = -1000); + Files.ReadInt(r, i); + ASSERT(r.eof) + END TestReadWriteInt; + + + PROCEDURE TestReadWriteReal; + VAR f: Files.File; + r: Files.Rider; + x: REAL; + BEGIN + f := Files.New("ReadWriteRealTest"); + ASSERT(f # NIL); + + Files.Set(r, f, 0); + Files.WriteReal(r, 3.14); + Files.WriteReal(r, -3.14); + Files.Close(f); + + Files.Set(r, f, 0); + Files.ReadReal(r, x); + ASSERT(~r.eof); + ASSERT(ABS(x - 3.14) < 1.0E-6); + Files.ReadReal(r, x); + ASSERT(~r.eof); + ASSERT(ABS(x - (-3.14)) < 1.0E-6); + Files.ReadReal(r, x); + ASSERT(r.eof) + END TestReadWriteReal; + + + PROCEDURE TestReadWriteNum; + VAR f: Files.File; + r: Files.Rider; + i: INTEGER; + BEGIN + f := Files.New("ReadWriteNumTest"); + ASSERT(f # NIL); + + Files.Set(r, f, 0); + Files.WriteNum(r, 100); + Files.WriteNum(r, -1000); + Files.Close(f); + + Files.Set(r, f, 0); + Files.ReadNum(r, i); + ASSERT(~r.eof); + ASSERT(i = 100); + Files.ReadNum(r, i); + ASSERT(~r.eof); + ASSERT(i = -1000); + Files.ReadNum(r, i); + ASSERT(r.eof) + END TestReadWriteNum; + + + PROCEDURE TestReadWriteString; + VAR f: Files.File; + r: Files.Rider; + s: ARRAY 32 OF CHAR; + BEGIN + f := Files.New("ReadWriteStringTest"); + ASSERT(f # NIL); + + Files.Set(r, f, 0); + Files.WriteString(r, "hello"); + Files.WriteString(r, "there"); + Files.WriteString(r, ""); + Files.Close(f); + + Files.Set(r, f, 0); + Files.ReadString(r, s); + ASSERT(~r.eof); + ASSERT(s = "hello"); + Files.ReadString(r, s); + ASSERT(~r.eof); + ASSERT(s = "there"); + Files.ReadString(r, s); + ASSERT(~r.eof); + ASSERT(s = ""); + Files.ReadString(r, s); + ASSERT(r.eof) + END TestReadWriteString; + + + PROCEDURE TestReadWriteSet; + VAR f: Files.File; + r: Files.Rider; + s: SET; + BEGIN + f := Files.New("ReadWriteSetTest"); + ASSERT(f # NIL); + + Files.Set(r, f, 0); + Files.WriteSet(r, {}); + Files.WriteSet(r, {0}); + Files.WriteSet(r, {0, 1}); + Files.Close(f); + + Files.Set(r, f, 0); + Files.ReadSet(r, s); + ASSERT(~r.eof); + ASSERT(s = {}); + Files.ReadSet(r, s); + ASSERT(~r.eof); + ASSERT(s = {0}); + Files.ReadSet(r, s); + ASSERT(~r.eof); + ASSERT(s = {0, 1}); + Files.ReadSet(r, s); + ASSERT(r.eof) + END TestReadWriteSet; + + + PROCEDURE TestReadWriteBool; + VAR f: Files.File; + r: Files.Rider; + b: BOOLEAN; + BEGIN + f := Files.New("ReadWriteBoolTest"); + ASSERT(f # NIL); + + Files.Set(r, f, 0); + Files.WriteBool(r, TRUE); + Files.WriteBool(r, FALSE); + Files.Close(f); + + Files.Set(r, f, 0); + Files.ReadBool(r, b); + ASSERT(~r.eof); + ASSERT(b); + Files.ReadBool(r, b); + ASSERT(~r.eof); + ASSERT(~b); + Files.ReadBool(r, b); + ASSERT(r.eof) + END TestReadWriteBool; + + + PROCEDURE TestReadWriteBytes; + VAR f: Files.File; + r: Files.Rider; + buf: ARRAY 4 OF BYTE; + i: INTEGER; + BEGIN + FOR i := 0 TO LEN(buf) - 1 DO buf[i] := i + 1 END; + + f := Files.New("ReadWriteBytesTest"); + ASSERT(f # NIL); + + Files.Set(r, f, 0); + Files.WriteBytes(r, buf, LEN(buf)); + Files.WriteBytes(r, buf, LEN(buf)); + Files.Close(f); + + FOR i := 0 TO LEN(buf) - 1 DO buf[i] := 0 END; + + Files.Set(r, f, 0); + + Files.ReadBytes(r, buf, LEN(buf)); + ASSERT(~r.eof); + FOR i := 0 TO LEN(buf) - 1 DO + ASSERT(buf[i] = i + 1) + END; + + Files.ReadBytes(r, buf, LEN(buf)); + ASSERT(~r.eof); + FOR i := 0 TO LEN(buf) - 1 DO + ASSERT(buf[i] = i + 1) + END; + + Files.ReadBytes(r, buf, LEN(buf)); + ASSERT(r.eof) + END TestReadWriteBytes; + +BEGIN + TestOld; + TestNew; + TestRegister; + TestClose; + TestPurge; + TestDelete; + TestRename; + TestLength; + IF SYSTEM.SIZE(INTEGER) >= 4 THEN + TestDate + END; + TestSet; + TestPos; + TestBase; + TestReadWrite; + TestReadWriteInt; + TestReadWriteReal; + IF SYSTEM.SIZE(INTEGER) >= 4 THEN + TestReadWriteNum; + END; + TestReadWriteString; + TestReadWriteSet; + TestReadWriteBool; + TestReadWriteBytes +END FilesTest. diff --git a/lib/obnc/In.c b/lib/obnc/In.c new file mode 100644 index 0000000..a69e83c --- /dev/null +++ b/lib/obnc/In.c @@ -0,0 +1,196 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include ".obnc/In.h" +#include +#include +#include +#include +#include + +#define LEN(arr) ((int) (sizeof (arr) / sizeof (arr)[0])) + +int In__Done_ = 0; +static int inputConsumed = 0; + +void In__Open_(void) +{ + In__Done_ = ! inputConsumed; +} + + +void In__Char_(char *ch) +{ + int d; + + d = getchar(); + *ch = (char) d; + In__Done_ = d != EOF; + if (In__Done_) { + inputConsumed = 1; + } +} + + +void In__Int_(OBNC_INTEGER *x) +{ + int ch, i, n; + char buf[(CHAR_BIT * sizeof (OBNC_INTEGER) / 3) + 3]; + unsigned OBNC_INTEGER y; + + In__Done_ = 0; + do { + ch = getchar(); + } while (isspace(ch)); + i = 0; + if (ch == '-') { + buf[i] = (char) ch; + i++; + ch = getchar(); + } + if (isdigit(ch)) { + do { + buf[i] = (char) ch; + i++; + ch = getchar(); + } while ((isdigit(ch) || ((ch >= 'A') && (ch <= 'F'))) && (i < LEN(buf))); + if (i < LEN(buf)) { + buf[i] = '\0'; + if (ch == 'H') { + n = sscanf(buf, "%" OBNC_INT_MOD "x", &y); + if (n == 1) { + *x = (OBNC_INTEGER) y; + } + } else { + n = sscanf(buf, "%" OBNC_INT_MOD "d", x); + if (ch != EOF) { + ungetc(ch, stdin); + } + } + In__Done_ = n == 1; + } + } else if (ch != EOF) { + ungetc(ch, stdin); + } + if (In__Done_) { + inputConsumed = 1; + } +} + + +void In__Real_(OBNC_REAL *x) +{ + int scanCount; + + scanCount = scanf("%" OBNC_REAL_MOD_R "f", x); + In__Done_ = scanCount == 1; + if (In__Done_) { + inputConsumed = 1; + } +} + + +void In__String_(char str[], OBNC_INTEGER strLen) +{ + int ch, i, ord; + + In__Done_ = 0; + do { + ch = getchar(); + } while (isspace(ch)); + if (ch == '"') { + i = 0; + ch = getchar(); + while ((ch != EOF) && (ch != '"') && (ch != '\n') && (i < strLen)) { + str[i] = (char) ch; + i++; + ch = getchar(); + } + if ((ch == '"') && (i < strLen)) { + str[i] = '\0'; + In__Done_ = 1; + } + } else if (isdigit(ch)) { + ord = ch - '0'; + ch = getchar(); + while ((isdigit(ch) || ((ch >= 'A') && (ch <= 'F'))) && (ord < UCHAR_MAX)) { + ord = isdigit(ch)? ord * 16 + ch - '0': ord * 16 + 10 + ch - 'A'; + ch = getchar(); + } + if ((ch == 'X') && (ord <= UCHAR_MAX) && (strLen >= 2)) { + str[0] = (char) ord; + str[1] = '\0'; + In__Done_ = 1; + } + } + if (! In__Done_) { + str[0] = '\0'; + } + inputConsumed = 1; +} + + +void In__Name_(char name[], OBNC_INTEGER nameLen) +{ + int n, ch, i; + + In__Done_ = 0; + n = 0; + do { + ch = getchar(); + n++; + } while (isspace(ch)); + if (ch != EOF) { + i = 0; + while ((i < nameLen) && (isgraph(ch) || ((unsigned char) ch >= 128))) { + name[i] = (char) ch; + i++; + ch = getchar(); + n++; + } + if (i < nameLen) { + name[i] = '\0'; + In__Done_ = ! isgraph(ch); + } else { + name[0] = '\0'; + } + } + if (ch == EOF) { + n--; + } + if (n > 0) { + inputConsumed = 1; + } +} + + +void In__Line_(char line[], OBNC_INTEGER lineLen) +{ + int i, ch; + + i = 0; + ch = getchar(); + while ((ch != EOF) && (ch != '\n') && (i < lineLen)) { + line[i] = (char) ch; + i++; + ch = getchar(); + } + if ((i > 0) || (ch == '\n')) { + inputConsumed = 1; + } + if (((ch != EOF) && (i < lineLen)) || ((ch == EOF) && (i > 0))) { + line[i] = '\0'; + In__Done_ = 1; + } else { + line[0] = '\0'; + In__Done_ = 0; + } +} + + +void In__Init(void) +{ +} diff --git a/lib/obnc/In.obn b/lib/obnc/In.obn new file mode 100644 index 0000000..3ec3545 --- /dev/null +++ b/lib/obnc/In.obn @@ -0,0 +1,61 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE In; +(**Input from the standard input stream + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". All read operations except Char and Line skips over preceding whitespace.*) + +(*implemented in C*) + + VAR Done*: BOOLEAN; (**status of last operation*) + + PROCEDURE Open*; +(**included for compatibility with "The Oakwood Guidelines". On a typical Unix-like system, stdin cannot be rewinded. If Open is called when the file position is not at the beginning of stdin, the program aborts.*) + END Open; + + + PROCEDURE Char*(VAR ch: CHAR); +(**returns in ch the character at the current position*) + END Char; + + + PROCEDURE Int*(VAR i: INTEGER); +(**returns in i the integer constant at the current position according to the format + + integer = digit {digit} | digit {hexDigit} "H". + hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F". +*) + END Int; + + + PROCEDURE Real*(VAR x: REAL); +(**returns in x the real constant at the current position according to the format + + real = digit {digit} "." {digit} [ScaleFactor]. + ScaleFactor = "E" ["+" | "-"] digit {digit}. +*) + END Real; + + + PROCEDURE String*(VAR str: ARRAY OF CHAR); +(**returns in str the string at the current position according to the format + + string = """ {character} """ | digit {hexdigit} "X" . +*) + END String; + + + PROCEDURE Name*(VAR name: ARRAY OF CHAR); +(**Name(s) returns in s the sequence of graphical (non-whitespace) characters at the current position*) + END Name; + + + PROCEDURE Line*(VAR line: ARRAY OF CHAR); +(**Line(s) returns in s the sequence of characters from the current position to the end of the line. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + END Line; + +END In. diff --git a/lib/obnc/InTest.obn b/lib/obnc/InTest.obn new file mode 100644 index 0000000..ac5ab36 --- /dev/null +++ b/lib/obnc/InTest.obn @@ -0,0 +1,80 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE InTest; + + IMPORT In; + + CONST + eps = 0.001; + + VAR + ch: CHAR; + n: INTEGER; + x: REAL; + s: ARRAY 12 OF CHAR; + +BEGIN + In.Char(ch); + ASSERT(In.Done); + ASSERT(ch = "a"); + + In.Int(n); + ASSERT(In.Done); + ASSERT(n = 37); + + In.Int(n); + ASSERT(In.Done); + ASSERT(n = 37H); + + In.Real(x); + ASSERT(In.Done); + ASSERT(x >= 3.14 - eps); + ASSERT(x <= 3.14 + eps); + + In.String(s); + ASSERT(In.Done); + ASSERT(s = ""); + + In.String(s); + ASSERT(In.Done); + ASSERT(s = "foo bar"); + + In.String(s); + ASSERT(In.Done); + ASSERT(s = 0X); + + In.String(s); + ASSERT(In.Done); + ASSERT(s = 1FX); + + In.String(s); + ASSERT(In.Done); + ASSERT(s = 0FFX); + + In.Name(s); + ASSERT(In.Done); + ASSERT(s = "foo/bar"); + + In.Line(s); + ASSERT(In.Done); + ASSERT(s = ""); + + In.Line(s); + ASSERT(In.Done); + ASSERT(s = "foo bar") +END InTest. diff --git a/lib/obnc/InTest.sh b/lib/obnc/InTest.sh new file mode 100755 index 0000000..561484d --- /dev/null +++ b/lib/obnc/InTest.sh @@ -0,0 +1,35 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -e + +input='a +37 +37H +3.14 +"" +"foo bar" +0X +1FX +0FFX +foo/bar + +foo bar' + +echo "$input" | ./InTest diff --git a/lib/obnc/Input.c b/lib/obnc/Input.c new file mode 100644 index 0000000..39a2b8d --- /dev/null +++ b/lib/obnc/Input.c @@ -0,0 +1,136 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include ".obnc/Input.h" +#include ".obnc/Input0.h" +#include +#include +#include + +#define LEN(arr) ((int) (sizeof (arr) / sizeof (arr)[0])) + +OBNC_INTEGER Input__TimeUnit_; + +static OBNC_INTEGER mouseLimitWidth = OBNC_INT_MAX; +static OBNC_INTEGER mouseLimitHeight = OBNC_INT_MAX; + +static int IsNonModKey(const SDL_Event *event) +{ + return (event->type == SDL_KEYDOWN) && (event->key.keysym.unicode != '\0'); +} + + +OBNC_INTEGER Input__Available_(void) +{ + SDL_Event events[10]; + int result, count, i; + + result = 0; + if (SDL_GetVideoSurface() != NULL) { + SDL_PumpEvents(); + /*search the event queue for key down events*/ + count = SDL_PeepEvents(events, LEN(events), SDL_PEEKEVENT, SDL_EVENTMASK(SDL_KEYDOWN)); + if (count > 0) { + for (i = 0; i < count; i++) { + if (IsNonModKey(&(events[i]))) { + result++; + } + } + } else if (count == 0) { + /*remove events from the queue to allow new ones to enter*/ + count = SDL_PeepEvents(events, LEN(events), SDL_GETEVENT, (Uint32) -1); + for (i = 0; i < count; i++) { + if (events[i].type == SDL_QUIT) { + OBNC_Exit(EXIT_SUCCESS); + } + } + } else { + fprintf(stderr, "Input.Available failed: SDL_PeepEvents: %s\n", SDL_GetError()); + } + } else { + fprintf(stderr, "Input.Available failed: No display surface\n"); + } + return result; +} + + +void Input__Read_(char *ch) +{ + SDL_Event event; + int done; + + *ch = '\0'; + if (SDL_GetVideoSurface() != NULL) { + do { + done = SDL_WaitEvent(&event); + } while (! done || ! IsNonModKey(&event)); + if (done) { + *ch = (char) event.key.keysym.unicode; + } + } else { + fprintf(stderr, "Input.Read failed: No display surface\n"); + } +} + + +void Input__Mouse_(unsigned OBNC_INTEGER *keys, OBNC_INTEGER *x, OBNC_INTEGER *y) +{ + SDL_Surface *display; + int x0, y0; + Uint8 buttons; + unsigned int leftPressed, middlePressed, rightPressed; + + display = SDL_GetVideoSurface(); + if (display != NULL) { + SDL_PumpEvents(); + buttons = SDL_GetMouseState(&x0, &y0); + *x = x0; + *y = y0; + *y = display->h - 1 - *y; + if (*x >= mouseLimitWidth) { + *x = mouseLimitWidth - 1; + } + if (*y >= mouseLimitHeight) { + *y = mouseLimitHeight - 1; + } + leftPressed = (buttons & SDL_BUTTON_LMASK) != 0; + middlePressed = (buttons & SDL_BUTTON_MMASK) != 0; + rightPressed = (buttons & SDL_BUTTON_RMASK) != 0; + + *keys = (unsigned OBNC_INTEGER) (leftPressed << 2) | (middlePressed << 1) | rightPressed; + } else { + fprintf(stderr, "Input.Mouse failed: No display surface\n"); + OBNC_Exit(EXIT_FAILURE); + } +} + + +void Input__SetMouseLimits_(OBNC_INTEGER w, OBNC_INTEGER h) +{ + OBNC_C_ASSERT(w > 0); + OBNC_C_ASSERT(h > 0); + + mouseLimitWidth = w; + mouseLimitHeight = h; +} + + +OBNC_INTEGER Input__Time_(void) +{ + return Input0__Time_(); +} + + +void Input__Init(void) +{ + static int initialized = 0; + + if (! initialized) { + Input0__Init(); + Input__TimeUnit_ = Input0__TimeUnit_; + initialized = 1; + } +} diff --git a/lib/obnc/Input.env b/lib/obnc/Input.env new file mode 100644 index 0000000..d516f62 --- /dev/null +++ b/lib/obnc/Input.env @@ -0,0 +1,2 @@ +CFLAGS=$(sdl-config --cflags) +LDLIBS=$(sdl-config --libs) diff --git a/lib/obnc/Input.obn b/lib/obnc/Input.obn new file mode 100644 index 0000000..d9fac5d --- /dev/null +++ b/lib/obnc/Input.obn @@ -0,0 +1,42 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE Input; +(**Access to keyboard, mouse and clock + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". This module is implemented to be used in tandem with basic module XYplane. For a console application, use module Input0 instead.*) + +(*implemented in C*) + + IMPORT Input0; + + VAR TimeUnit*: INTEGER; (**clock ticks per second*) + + PROCEDURE Available*(): INTEGER; +(**returns the number of characters in the keyboard buffer*) + RETURN 0 (*dummy value*) + END Available; + + PROCEDURE Read*(VAR ch: CHAR); +(**returns (and removes) the next character from the keyboard buffer. If the buffer is empty, Read waits until a key is pressed.*) + END Read; + + PROCEDURE Mouse*(VAR keys: SET; VAR x, y: INTEGER); +(**returns the current mouse position (x, y) in pixels relative to the lower left corner of the screen. keys is the set of the currently pressed mouse keys (left = 2, middle = 1, right = 0).*) + END Mouse; + + PROCEDURE SetMouseLimits*(w, h: INTEGER); +(**defines the rectangle where the mouse moves (in pixels). Subsequent calls to the operation Mouse will return coordinates for x in the range 0 .. w - 1 and y in the range 0 .. h - 1.*) + END SetMouseLimits; + + PROCEDURE Time*(): INTEGER; +(**returns the time elapsed since system startup in units of size 1 / TimeUnit seconds*) + RETURN 0 (*dummy value*) + END Time; + +BEGIN + ASSERT(Input0.TimeUnit > 0) (*silence "Input0 unused" compiler note*) +END Input. diff --git a/lib/obnc/Input0.c b/lib/obnc/Input0.c new file mode 100644 index 0000000..883669f --- /dev/null +++ b/lib/obnc/Input0.c @@ -0,0 +1,220 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include ".obnc/Input0.h" +#include +#ifdef _WIN32 + #include + #include +#else + #include /*POSIX*/ + #include /*POSIX*/ +#endif +#include /*POSIX*/ +#include /*POSIX*/ +#include +#include +#include +#include +#include + +#define LEN(arr) ((int) (sizeof (arr) / sizeof (arr)[0])) + +#ifdef _WIN32 + +/*----- Windows Implementation*/ + +OBNC_INTEGER Input0__TimeUnit_ = 1000; + +OBNC_INTEGER Input0__Available_(void) +{ + HANDLE inputHandle; + INPUT_RECORD events[256]; + DWORD eventCount; + BOOL peeked; + DWORD result = 0; + + inputHandle = GetStdHandle(STD_INPUT_HANDLE); + if ((inputHandle != NULL) && (inputHandle != INVALID_HANDLE_VALUE)) { + peeked = PeekConsoleInput(inputHandle, events, LEN(events), &eventCount); + if(peeked) { + result = eventCount; + } else { + fprintf(stderr, "Input0.Available failed: %s\n", strerror(errno)); + } + } else if (inputHandle == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Input0.Available failed with error code %lu\n", GetLastError()); + } else if (inputHandle == NULL) { + fprintf(stderr, "Input0.Available failed\n"); + } else { + assert(0); + } + return result; +} + + +void Input0__Read_(char *ch) +{ + *ch = getch(); +} + + +OBNC_INTEGER Input0__Time_(void) +{ + return GetTickCount(); +} + +#else + +/*----- POSIX Implementation*/ + +#if OBNC_INT_MAX <= ((1u << 15) - 1) + OBNC_INTEGER Input0__TimeUnit_ = 1; +#elif OBNC_INT_MAX <= ((1u << 31) - 1) + OBNC_INTEGER Input0__TimeUnit_ = 1000; +#else + OBNC_INTEGER Input0__TimeUnit_ = 1000000000; +#endif + +/*Keyboard buffer data structure*/ + +static char queue[256]; +static int queueFront, queueCount; + +static void Enqueue(char ch) +{ + if (queueCount < LEN(queue)) { + queue[(queueFront + queueCount) % LEN(queue)] = ch; + queueCount++; + } +} + + +static void Dequeue(char *ch) +{ + assert(queueCount > 0); + *ch = queue[queueFront]; + queueFront = (queueFront + 1) % LEN(queue); + queueCount--; +} + + +OBNC_INTEGER Input0__Available_(void) +{ + int result, error, oldf, status, ch; + struct termios oldt, newt; + + result = 0; + error = tcgetattr(STDIN_FILENO, &oldt); + if (! error) { + newt = oldt; + newt.c_lflag &= ~(ICANON | ECHO); + error = tcsetattr(STDIN_FILENO, TCSANOW, &newt); + if (! error) { + oldf = fcntl(STDIN_FILENO, F_GETFL, 0); + status = fcntl(STDIN_FILENO, F_SETFL, oldf | O_NONBLOCK); + if (status != -1) { + ch = getchar(); + while (ch != EOF) { + Enqueue(ch); + ch = getchar(); + } + status = fcntl(STDIN_FILENO, F_SETFL, oldf); + if (status != -1) { + error = tcsetattr(STDIN_FILENO, TCSANOW, &oldt); + if (! error) { + result = queueCount; + } else { + fprintf(stderr, "Input0.Available failed: tcsetattr: %s\n", strerror(errno)); + } + } else { + fprintf(stderr, "Input0.Available failed: fcntl: %s\n", strerror(errno)); + } + } else { + fprintf(stderr, "Input0.Available failed: fcntl: %s\n", strerror(errno)); + } + } else { + fprintf(stderr, "Input0.Available failed: tcsetattr: %s\n", strerror(errno)); + } + } else { + fprintf(stderr, "Input0.Available failed: tcgetattr: %s\n", strerror(errno)); + } + return result; +} + + +void Input0__Read_(char *ch) +{ + struct termios oldt, newt; + int error, inputChar; + + if (queueCount > 0) { + Dequeue(ch); + } else { + *ch = '\0'; + error = tcgetattr(STDIN_FILENO, &oldt); + if (! error) { + newt = oldt; + newt.c_lflag &= (tcflag_t) ~(ECHO | ICANON); + newt.c_cc[VMIN] = 1; + error = tcsetattr(STDIN_FILENO, TCSANOW, &newt); + if (! error) { + inputChar = getchar(); + error = tcsetattr(STDIN_FILENO, TCSANOW, &oldt); + if (! error) { + if (inputChar != EOF) { + *ch = (char) inputChar; + } + } else { + fprintf(stderr, "Input0.Read failed: tcsetattr: %s\n", strerror(errno)); + } + } else { + fprintf(stderr, "Input0.Read failed: tcsetattr: %s\n", strerror(errno)); + } + } else { + fprintf(stderr, "Input0.Read failed: tcgetattr: %s\n", strerror(errno)); + } + } +} + + +#ifndef CLOCK_MONOTONIC +#define CLOCK_MONOTONIC 1 + +static int clock_gettime(int clock_id, struct timespec *result) +{ + struct timeval t; + int status; + + status = gettimeofday(&t, NULL); + OBNC_C_ASSERT(status == 0); + result->tv_sec = t.tv_sec; + result->tv_nsec = t.tv_usec * 1000; + return status; +} + +#endif + +OBNC_INTEGER Input0__Time_(void) +{ + struct timespec now; + int error; + OBNC_INTEGER result = -1; + + error = clock_gettime(CLOCK_MONOTONIC, &now); + if (! error) { + result = now.tv_sec * Input0__TimeUnit_ + now.tv_nsec / (1000000000 / Input0__TimeUnit_); + } else { + fprintf(stderr, "Input0.Time failed: clock_gettime: %s\n", strerror(errno)); + } + return result; +} + +#endif /*defined _WIN32*/ + +void Input0__Init(void) +{ +} diff --git a/lib/obnc/Input0.obn b/lib/obnc/Input0.obn new file mode 100644 index 0000000..0ea4895 --- /dev/null +++ b/lib/obnc/Input0.obn @@ -0,0 +1,30 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE Input0; +(**Access to keyboard and clock + +Implements a subset of basic module Input applicable to console applications. Import with Input := Input0 to emphasize the compatibility.*) + +(*implemented in C*) + + VAR TimeUnit*: INTEGER; (**clock ticks per second*) + + PROCEDURE Available*(): INTEGER; +(**returns the number of characters in the keyboard buffer*) + RETURN 0 + END Available; + + PROCEDURE Read*(VAR ch: CHAR); +(**returns (and removes) the next character from the keyboard buffer. If the buffer is empty, Read waits until a key is pressed.*) + END Read; + + PROCEDURE Time*(): INTEGER; +(**returns the time elapsed since system startup in units of size 1 / TimeUnit seconds*) + RETURN 0 + END Time; + +END Input0. diff --git a/lib/obnc/Input0Test.obn b/lib/obnc/Input0Test.obn new file mode 100644 index 0000000..a9829ed --- /dev/null +++ b/lib/obnc/Input0Test.obn @@ -0,0 +1,71 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE Input0Test; + + IMPORT Input := Input0, Out; + + PROCEDURE TestAvailable; + VAR n: INTEGER; ch: CHAR; + BEGIN + Out.String("Press abc..."); + Out.Ln; + REPEAT + n := Input.Available() + UNTIL n >= 3; + Input.Read(ch); + ASSERT(ch = "a"); + Input.Read(ch); + ASSERT(ch = "b"); + Input.Read(ch); + ASSERT(ch = "c"); + Out.String("OK"); + Out.Ln; + END TestAvailable; + + + PROCEDURE TestRead; + VAR ch: CHAR; + BEGIN + Out.String("Press space ... "); + Out.Ln; + Input.Read(ch); + ASSERT(ch = " "); + Out.String("OK"); + Out.Ln; + + Out.String("Press $ ... "); + Out.Ln; + Input.Read(ch); + ASSERT(ch = "$"); + Out.String("OK"); + Out.Ln + END TestRead; + + + PROCEDURE TestTime; + BEGIN + ASSERT(Input.TimeUnit > 0); + ASSERT(Input.Time() > 0) + END TestTime; + + +BEGIN + TestAvailable; + TestRead; + TestTime +END Input0Test. diff --git a/lib/obnc/Input0Test.sh b/lib/obnc/Input0Test.sh new file mode 100755 index 0000000..1c503b1 --- /dev/null +++ b/lib/obnc/Input0Test.sh @@ -0,0 +1,22 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -e + +#TODO: find out how to send keys to Input0Test (which receives non-blocking input) diff --git a/lib/obnc/InputTest.obn b/lib/obnc/InputTest.obn new file mode 100644 index 0000000..e78d061 --- /dev/null +++ b/lib/obnc/InputTest.obn @@ -0,0 +1,102 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE InputTest; + + IMPORT Input, Out, XYplane; + + PROCEDURE TestAvailable; + VAR n: INTEGER; ch: CHAR; + BEGIN + Out.String("Press any key ... "); + Out.Ln; + REPEAT + n := Input.Available() + UNTIL n # 0; + ASSERT(n > 0); + Out.String("OK"); + Out.Ln; + Input.Read(ch) + END TestAvailable; + + + PROCEDURE TestRead; + VAR ch: CHAR; + BEGIN + Out.String("Press space ... "); + Out.Ln; + Input.Read(ch); + ASSERT(ch = " "); + Out.String("OK"); + Out.Ln; + + Out.String("Press $ ... "); + Out.Ln; + Input.Read(ch); + ASSERT(ch = "$"); + Out.String("OK"); + Out.Ln + END TestRead; + + + PROCEDURE TestButton(button: INTEGER); + VAR buttonLabels: ARRAY 3, 8 OF CHAR; + buttons: SET; x, y: INTEGER; + BEGIN + buttonLabels[0] := "right"; + buttonLabels[1] := "middle"; + buttonLabels[2] := "left"; + Out.String("Press "); + Out.String(buttonLabels[button]); + Out.String(" mouse button ... "); + Out.Ln; + REPEAT + Input.Mouse(buttons, x, y); + UNTIL buttons # {}; + ASSERT(button IN buttons); + ASSERT(x >= 0); + ASSERT(y >= 0); + Out.String("OK"); + Out.Ln; + REPEAT (*wait until button has been released*) + Input.Mouse(buttons, x, y); + UNTIL buttons = {} + END TestButton; + + + PROCEDURE TestMouse; + BEGIN + TestButton(0); + TestButton(1); + TestButton(2) + END TestMouse; + + + PROCEDURE TestTime; + BEGIN + ASSERT(Input.TimeUnit > 0); + ASSERT(Input.Time() > 0) + END TestTime; + + +BEGIN + XYplane.Open; + TestAvailable; + TestRead; + TestMouse; + TestTime +END InputTest. diff --git a/lib/obnc/InputTest.sh b/lib/obnc/InputTest.sh new file mode 100755 index 0000000..fde397a --- /dev/null +++ b/lib/obnc/InputTest.sh @@ -0,0 +1,39 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -e + +./InputTest >/dev/null & +pid="$!" +wid="$(xdotool search --sync --onlyvisible --pid "$pid")" + +xdotool key --window "$wid" k +xdotool key --window "$wid" space +xdotool key --window "$wid" dollar + +#save mouse position (X, Y and SCREEN) +eval "$(xdotool getmouselocation --shell)" + +xdotool mousemove --window "$wid" 0 0 click 3 +xdotool mousemove --window "$wid" 0 0 click 2 +xdotool mousemove --window "$wid" 0 0 click 1 + +#restore mouse position +xdotool mousemove --screen $SCREEN $X $Y + diff --git a/lib/obnc/LICENSE b/lib/obnc/LICENSE new file mode 100644 index 0000000..a612ad9 --- /dev/null +++ b/lib/obnc/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/lib/obnc/Math.c b/lib/obnc/Math.c new file mode 100644 index 0000000..511f9ff --- /dev/null +++ b/lib/obnc/Math.c @@ -0,0 +1,148 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include ".obnc/Math.h" +#include +#include + +#if OBNC_CONFIG_C_REAL_TYPE == OBNC_CONFIG_FLOAT + #define S(func) func ## f +#elif OBNC_CONFIG_C_REAL_TYPE == OBNC_CONFIG_DOUBLE + #define S(func) func +#elif OBNC_CONFIG_C_REAL_TYPE == OBNC_CONFIG_LONG_DOUBLE + #define S(func) func ## l +#endif + +OBNC_REAL Math__sqrt_(OBNC_REAL x) +{ + return S(sqrt)(x); +} + + +OBNC_REAL Math__power_(OBNC_REAL base, OBNC_REAL exp) +{ + return S(pow)(base, exp); +} + + +OBNC_REAL Math__exp_(OBNC_REAL x) +{ + return S(exp)(x); +} + + +OBNC_REAL Math__ln_(OBNC_REAL x) +{ + return S(log)(x); +} + + +OBNC_REAL Math__log_(OBNC_REAL x, OBNC_REAL base) +{ + return S(log)(x) / S(log)(base); +} + + +OBNC_REAL Math__round_(OBNC_REAL x) +{ + return S(floor)(x + 0.5); +} + + +OBNC_REAL Math__sin_(OBNC_REAL x) +{ + return S(sin)(x); +} + + +OBNC_REAL Math__cos_(OBNC_REAL x) +{ + return S(cos)(x); +} + + +OBNC_REAL Math__tan_(OBNC_REAL x) +{ + return S(tan)(x); +} + + +OBNC_REAL Math__arcsin_(OBNC_REAL x) +{ + return S(asin)(x); +} + + +OBNC_REAL Math__arccos_(OBNC_REAL x) +{ + return S(acos)(x); +} + + +OBNC_REAL Math__arctan_(OBNC_REAL x) +{ + return S(atan)(x); +} + + +OBNC_REAL Math__arctan2_(OBNC_REAL y, OBNC_REAL x) +{ + return S(atan2)(y, x); +} + + +OBNC_REAL Math__sinh_(OBNC_REAL x) +{ + return S(sinh)(x); +} + + +OBNC_REAL Math__cosh_(OBNC_REAL x) +{ + return S(cosh)(x); +} + + +OBNC_REAL Math__tanh_(OBNC_REAL x) +{ + return S(tanh)(x); +} + + +OBNC_REAL Math__arcsinh_(OBNC_REAL x) +{ +#ifdef _WIN32 + return S(log)(x + S(sqrt)(x * x + 1.0)); +#else + return S(asinh)(x); +#endif +} + + +OBNC_REAL Math__arccosh_(OBNC_REAL x) +{ +#ifdef _WIN32 + return S(log)(x + S(sqrt)(x * x - 1.0)); +#else + return S(acosh)(x); +#endif +} + + +OBNC_REAL Math__arctanh_(OBNC_REAL x) +{ +#ifdef _WIN32 + return 0.5 * S(log)((1.0 + x) / (1.0 - x)); +#else + return S(atanh)(x); +#endif +} + + +void Math__Init(void) +{ + /*do nothing*/ +} diff --git a/lib/obnc/Math.env b/lib/obnc/Math.env new file mode 100644 index 0000000..fc7fd98 --- /dev/null +++ b/lib/obnc/Math.env @@ -0,0 +1 @@ +LDLIBS=-lm diff --git a/lib/obnc/Math.obn b/lib/obnc/Math.obn new file mode 100644 index 0000000..d7a51cb --- /dev/null +++ b/lib/obnc/Math.obn @@ -0,0 +1,132 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE Math; +(**General purpose mathematical functions + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*) + +(*implemented in C*) + + CONST + pi* = 3.14159265358979; + e* = 2.71828182845905; + dummy = 0.0; + + PROCEDURE sqrt*(x: REAL): REAL; +(**returns the square root of x, where x must be positive*) + RETURN dummy + END sqrt; + + + PROCEDURE power*(base, exp: REAL): REAL; +(**returns base raised to exp*) + RETURN dummy + END power; + + + PROCEDURE exp*(x: REAL): REAL; +(**returns the constant e raised to x*) + RETURN dummy + END exp; + + + PROCEDURE ln*(x: REAL): REAL; +(**returns the natural logarithm of x with base e*) + RETURN dummy + END ln; + + + PROCEDURE log*(x, base: REAL): REAL; +(**log(x, b) returns the logarithm of x with base b*) + RETURN dummy + END log; + + + PROCEDURE round*(x: REAL): REAL; +(**returns x rounded to the nearest integer. If the fraction part of x is in range 0.0 to 0.5 then the result is the largest integer not greater than x, otherwise the result is x rounded up to the next highest whole number. Note that integer values cannot always be exactly represented in REAL format.*) + RETURN dummy + END round; + + + PROCEDURE sin*(x: REAL): REAL; +(**returns the sine of a radian value x*) + RETURN dummy + END sin; + + + PROCEDURE cos*(x: REAL): REAL; +(**returns the cosine of a radian value x*) + RETURN dummy + END cos; + + + PROCEDURE tan*(x: REAL): REAL; +(**returns the tangent of a radian value x*) + RETURN dummy + END tan; + + + PROCEDURE arcsin*(x: REAL): REAL; +(**returns the inverse sine of x in radians, where -1 <= x <= 1*) + RETURN dummy + END arcsin; + + + PROCEDURE arccos*(x: REAL): REAL; +(**returns the inverse cosine of x in radians, where -1 <= x <= 1*) + RETURN dummy + END arccos; + + + PROCEDURE arctan*(x: REAL): REAL; +(**returns the inverse tangent of x in radians, where -1 <= x <= 1*) + RETURN dummy + END arctan; + + + PROCEDURE arctan2*(y, x: REAL): REAL; +(**returns the inverse tangent in radians of y/x based on the signs of both values to determine the correct quadrant.*) + RETURN dummy + END arctan2; + + + PROCEDURE sinh*(x: REAL): REAL; +(**returns the hyperbolic sine of x*) + RETURN dummy + END sinh; + + + PROCEDURE cosh*(x: REAL): REAL; +(**returns the hyperbolic cosine of x*) + RETURN dummy + END cosh; + + + PROCEDURE tanh*(x: REAL): REAL; +(**returns the hyperbolic tangent of x*) + RETURN dummy + END tanh; + + + PROCEDURE arcsinh*(x: REAL): REAL; +(**returns the inverse hyperbolic sine of x*) + RETURN dummy + END arcsinh; + + + PROCEDURE arccosh*(x: REAL): REAL; +(**returns the inverse hyperbolic cosine of x*) + RETURN dummy + END arccosh; + + + PROCEDURE arctanh*(x: REAL): REAL; +(**returns the inverse hyperbolic tangent of x*) + RETURN dummy + END arctanh; + +END Math. diff --git a/lib/obnc/MathTest.obn b/lib/obnc/MathTest.obn new file mode 100644 index 0000000..715fdd0 --- /dev/null +++ b/lib/obnc/MathTest.obn @@ -0,0 +1,94 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE MathTest; + + IMPORT Math; + + CONST + eps = 0.01; + +BEGIN + ASSERT(ABS(Math.sqrt(1.0) - 1.0) < eps); + ASSERT(ABS(Math.sqrt(4.0) - 2.0) < eps); + + ASSERT(ABS(Math.power(0.0, 1.0) - 0.0) < eps); + ASSERT(ABS(Math.power(1.0, 0.0) - 1.0) < eps); + ASSERT(ABS(Math.power(2.0, 3.0) - 8.0) < eps); + ASSERT(ABS(Math.power(2.0, -3.0) - 1.0 / 8.0) < eps); + + ASSERT(ABS(Math.exp(0.0) - 1.0) < eps); + ASSERT(ABS(Math.exp(1.0) - Math.e) < eps); + ASSERT(ABS(Math.exp(2.0) - Math.e * Math.e) < eps); + ASSERT(ABS(Math.exp(-2.0) - 1.0 / Math.e / Math.e) < eps); + + ASSERT(ABS(Math.ln(1.0) - 0.0) < eps); + ASSERT(ABS(Math.ln(Math.e) - 1.0) < eps); + ASSERT(ABS(Math.ln(Math.e * Math.e) - 2.0) < eps); + + ASSERT(ABS(Math.log(1.0, 2.0) - 0.0) < eps); + ASSERT(ABS(Math.log(Math.e, Math.e) - 1.0) < eps); + ASSERT(ABS(Math.log(100.0, 10.0) - 2.0) < eps); + + ASSERT(ABS(Math.round(0.4) - 0.0) < eps); + ASSERT(ABS(Math.round(-0.4) - 0.0) < eps); + ASSERT(ABS(Math.round(0.6) - 1.0) < eps); + ASSERT(ABS(Math.round(-0.6) - (-1.0)) < eps); + + ASSERT(ABS(Math.sin(0.0) - 0.0) < eps); + ASSERT(ABS(Math.sin(Math.pi / 6.0) - 0.5) < eps); + ASSERT(ABS(Math.sin(Math.pi / 2.0) - 1.0) < eps); + + ASSERT(ABS(Math.cos(0.0) - 1.0) < eps); + ASSERT(ABS(Math.cos(Math.pi / 3.0) - 0.5) < eps); + ASSERT(ABS(Math.cos(Math.pi / 2.0) - 0.0) < eps); + + ASSERT(ABS(Math.tan(0.0) - 0.0) < eps); + ASSERT(ABS(Math.tan(Math.pi / 4.0) - 1.0) < eps); + + ASSERT(ABS(Math.arcsin(0.0) - 0.0) < eps); + ASSERT(ABS(Math.arcsin(0.5) - Math.pi / 6.0) < eps); + ASSERT(ABS(Math.arcsin(1.0) - Math.pi / 2.0) < eps); + + ASSERT(ABS(Math.arccos(1.0) - 0.0) < eps); + ASSERT(ABS(Math.arccos(0.5) - Math.pi / 3.0) < eps); + ASSERT(ABS(Math.arccos(0.0) - Math.pi / 2.0) < eps); + + ASSERT(ABS(Math.arctan(0.0) - 0.0) < eps); + ASSERT(ABS(Math.arctan(1.0) - Math.pi / 4.0) < eps); + + ASSERT(ABS(Math.arctan2(0.0, 2.0) - 0.0) < eps); + ASSERT(ABS(Math.arctan2(2.0, 2.0) - Math.pi / 4.0) < eps); + + ASSERT(ABS(Math.sinh(0.0) - 0.0) < eps); + ASSERT(ABS(Math.sinh(1.0) - (Math.e - 1.0 / Math.e) / 2.0) < eps); + + ASSERT(ABS(Math.cosh(0.0) - 1.0) < eps); + ASSERT(ABS(Math.cosh(1.0) - (Math.e + 1.0 / Math.e) / 2.0) < eps); + + ASSERT(ABS(Math.tanh(0.0) - 0.0) < eps); + ASSERT(ABS(Math.tanh(1.0) - (Math.e - 1.0 / Math.e) / (Math.e + 1.0 / Math.e)) < eps); + + ASSERT(ABS(Math.arcsinh(0.0) - 0.0) < eps); + ASSERT(ABS(Math.arcsinh((Math.e - 1.0 / Math.e) / 2.0) - 1.0) < eps); + + ASSERT(ABS(Math.arccosh(1.0) - 0.0) < eps); + ASSERT(ABS(Math.arccosh((Math.e + 1.0 / Math.e) / 2.0) - 1.0) < eps); + + ASSERT(ABS(Math.arctanh(0.0) - 0.0) < eps); + ASSERT(ABS(Math.arctanh((Math.e - 1.0 / Math.e) / (Math.e + 1.0 / Math.e)) - 1.0) < eps) +END MathTest. diff --git a/lib/obnc/OBNC.c b/lib/obnc/OBNC.c new file mode 100644 index 0000000..51c6704 --- /dev/null +++ b/lib/obnc/OBNC.c @@ -0,0 +1,234 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include "OBNC.h" +#if ! OBNC_CONFIG_TARGET_EMB + #include +#endif +#include +#include +#include +#include + +#define UNUSED(x) (void) (x) + +int OBNC_argc; +char **OBNC_argv; +OBNC_TrapHandler OBNC_handleTrap; + +void OBNC_ExitTrap(void) +{ +#if OBNC_CONFIG_TARGET_EMB + while (1); +#else + exit(EXIT_FAILURE); +#endif +} + + +static void ExitTrapWithMessage(OBNC_INTEGER exception, const char file[], OBNC_INTEGER fileLen, OBNC_INTEGER line) +{ + UNUSED(fileLen); + fputs("Exception (E", stderr); + OBNC_WriteInt(exception, 0, stderr); + putc(')', stderr); +#if ! OBNC_CONFIG_TARGET_EMB + fputs(": ", stderr); + switch (exception) { + case OBNC_ARRAY_ASSIGNMENT_EXCEPTION: + fputs("destination array too short for assignment", stderr); + break; + case OBNC_ARRAY_INDEX_EXCEPTION: + fputs("array index out of bounds", stderr); + break; + case OBNC_POINTER_DEREFERENCE_EXCEPTION: + fputs("nil pointer dereference", stderr); + break; + case OBNC_PROCEDURE_CALL_EXCEPTION: + fputs("nil procedure variable call", stderr); + break; + case OBNC_RECORD_ASSIGNMENT_EXCEPTION: + fputs("source in assignment is not an extension of target", stderr); + break; + case OBNC_TYPE_GUARD_EXCEPTION: + fputs("type guard failure", stderr); + break; + case OBNC_CASE_EXP_MATCH_EXCEPTION: + fputs("unmatched expression in case statement", stderr); + break; + case OBNC_ASSERT_STATEMENT_EXCEPTION: + fputs("assertion failure", stderr); + break; + default: + assert(0); + } + fputs(" (", stderr); + fputs(file, stderr); + fputs(":", stderr); + OBNC_WriteInt(line, 0, stderr); + fputs(")", stderr); +#endif + putc('\n', stderr); + OBNC_ExitTrap(); +} + + +void OBNC_Init(int argc, char *argv[]) +{ + OBNC_argc = argc; + OBNC_argv = argv; + OBNC_handleTrap = ExitTrapWithMessage; +#if ! OBNC_CONFIG_TARGET_EMB + GC_INIT(); +#endif +} + + +void *OBNC_Allocate(size_t size, int kind) +{ + void *result = NULL; + +#if ! OBNC_CONFIG_TARGET_EMB + switch (kind) { + case OBNC_REGULAR_ALLOC: + result = GC_MALLOC(size); /*initializes memory to zero like calloc*/ + break; + case OBNC_ATOMIC_ALLOC: + result = GC_MALLOC_ATOMIC(size); + if (result != NULL) { + memset(result, 0, size); + } + break; + case OBNC_ATOMIC_NOINIT_ALLOC: + result = GC_MALLOC_ATOMIC(size); /*no initialization*/ + break; + default: + OBNC_C_ASSERT(0); + } +#else + OBNC_C_ASSERT(0); +#endif + return result; +} + + +OBNC_INTEGER OBNC_It1(OBNC_INTEGER i, OBNC_INTEGER n, const char file[], int line) +{ + if ((i < 0) || (i >= n)) { + OBNC_handleTrap(OBNC_ARRAY_INDEX_EXCEPTION, file, strlen(file) + 1, line); + } + return i; +} + + +static OBNC_INTEGER Abs(OBNC_INTEGER x) +{ + return (x >= 0)? x: -x; +} + + +void OBNC_WriteInt(OBNC_INTEGER x, OBNC_INTEGER n, FILE *f) +{ + int neg, i; + char buf[(CHAR_BIT * sizeof (OBNC_INTEGER) / 3) + 3]; + + neg = x < 0; + i = 0; + do { + OBNC_C_ASSERT(i < (int) (sizeof (buf) / sizeof (buf[0]))); + buf[i] = '0' + Abs(x % 10); + x = x / 10; + i++; + } while (x != 0); + while (n > i + !! neg) { + putc(' ', f); + n--; + } + if (neg) { + putc('-', f); + } + do { + i--; + putc(buf[i], f); + } while (i > 0); +} + + +void OBNC_WriteHex(unsigned OBNC_INTEGER n, FILE *f) +{ + unsigned OBNC_INTEGER d; + char digits[2 * sizeof n]; + int i; + + putc(' ', f); + for (i = 0; i < (int) sizeof (digits); i++) { + d = n % 16; + digits[i] = (d >= 10)? 'A' + d - 10: '0' + d; + n = n / 16; + } + for (i = (int) sizeof (digits) - 1; i >= 0; i--) { + putc(digits[i], f); + } +} + + +void OBNC_Exit(int status) +{ +#if OBNC_CONFIG_TARGET_EMB + while (1); +#else + exit(status); +#endif +} + + +int OBNC_Cmp(const char s[], OBNC_INTEGER sLen, const char t[], OBNC_INTEGER tLen) +{ + return strncmp(s, t, (sLen < tLen)? sLen: tLen); +} + + +OBNC_INTEGER OBNC_Div(OBNC_INTEGER x, OBNC_INTEGER y) +{ + return (x >= 0)? x / y: (x - OBNC_Mod(x, y)) / y; +} + + +OBNC_INTEGER OBNC_Mod(OBNC_INTEGER x, OBNC_INTEGER y) +{ + return (x >= 0)? x % y: ((x % y) + y) % y; +} + + +unsigned OBNC_INTEGER OBNC_Range(OBNC_INTEGER m, OBNC_INTEGER n) +{ + return (m <= n)? + (unsigned OBNC_INTEGER) ((((unsigned OBNC_INTEGER) -2) << n) ^ (((unsigned OBNC_INTEGER) -1) << m)): + (unsigned OBNC_INTEGER) 0x0u; +} + + +OBNC_INTEGER OBNC_Ror(OBNC_INTEGER x, OBNC_INTEGER n) +{ + return (OBNC_INTEGER) (((unsigned OBNC_INTEGER) x >> n) | ((unsigned OBNC_INTEGER) x << (((unsigned OBNC_INTEGER) sizeof (OBNC_INTEGER) << 3) - (size_t) n))); +} + + +void OBNC_Pack(OBNC_REAL *x, OBNC_INTEGER n) +{ + *x = OBNC_REAL_SUFFIX(ldexp)(*x, (int) n); +} + + +void OBNC_Unpk(OBNC_REAL *x, OBNC_INTEGER *n) +{ + int t; + + *x = OBNC_REAL_SUFFIX(frexp)(*x, &t); + *n = (OBNC_INTEGER) t; + *x += *x; + (*n)--; +} diff --git a/lib/obnc/OBNC.env b/lib/obnc/OBNC.env new file mode 100644 index 0000000..93029f4 --- /dev/null +++ b/lib/obnc/OBNC.env @@ -0,0 +1 @@ +LDLIBS="-lgc -lm" diff --git a/lib/obnc/OBNC.h b/lib/obnc/OBNC.h new file mode 100644 index 0000000..c530c30 --- /dev/null +++ b/lib/obnc/OBNC.h @@ -0,0 +1,338 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#ifndef OBNC_H +#define OBNC_H + +#include "OBNCConfig.h" +#include +#include +#include +#include +#include +#include + +#if OBNC_CONFIG_TARGET_EMB + #define OBNC_CFILE "" + #define OBNC_OBNFILE "" +#else + #define OBNC_CFILE __FILE__ + #define OBNC_OBNFILE OBERON_SOURCE_FILENAME +#endif + +/*Run-time exceptions*/ + +#define OBNC_ARRAY_ASSIGNMENT_EXCEPTION 1 +#define OBNC_ARRAY_INDEX_EXCEPTION 2 +#define OBNC_POINTER_DEREFERENCE_EXCEPTION 3 +#define OBNC_PROCEDURE_CALL_EXCEPTION 4 +#define OBNC_RECORD_ASSIGNMENT_EXCEPTION 5 +#define OBNC_TYPE_GUARD_EXCEPTION 6 +#define OBNC_CASE_EXP_MATCH_EXCEPTION 7 +#define OBNC_ASSERT_STATEMENT_EXCEPTION 8 + +/*Memory allocation kinds*/ + +#define OBNC_REGULAR_ALLOC 0 +#define OBNC_ATOMIC_ALLOC 1 +#define OBNC_ATOMIC_NOINIT_ALLOC 2 + +/*Properties of basic type INTEGER (a set is an unsigned OBNC_INTEGER)*/ + +#if OBNC_CONFIG_C_INT_TYPE == OBNC_CONFIG_SHORT + #define OBNC_INTEGER short + #define OBNC_INT_MOD "h" + #define OBNC_INT_MIN SHRT_MIN + #define OBNC_INT_MAX SHRT_MAX + #define OBNC_UINT_MAX USHRT_MAX + #define OBNC_INT_PREFIX(func) func +#elif OBNC_CONFIG_C_INT_TYPE == OBNC_CONFIG_INT + #define OBNC_INTEGER int + #define OBNC_LONGI /*obsolescent*/ + #define OBNC_INT_MOD "" + #define OBNC_INT_MIN INT_MIN + #define OBNC_INT_MAX INT_MAX + #define OBNC_UINT_MAX UINT_MAX + #define OBNC_INT_PREFIX(func) func +#elif OBNC_CONFIG_C_INT_TYPE == OBNC_CONFIG_LONG + #define OBNC_INTEGER long + #define OBNC_LONGI long /*obsolescent*/ + #define OBNC_INT_MOD "l" + #define OBNC_INT_MIN LONG_MIN + #define OBNC_INT_MAX LONG_MAX + #define OBNC_UINT_MAX ULONG_MAX + #define OBNC_INT_PREFIX(func) l ## func +#elif OBNC_CONFIG_C_INT_TYPE == OBNC_CONFIG_LONG_LONG + #define OBNC_INTEGER long long + #define OBNC_LONGI long long /*obsolescent*/ + #ifdef _WIN32 + #define OBNC_INT_MOD "I64" + #else + #define OBNC_INT_MOD "ll" + #endif + #define OBNC_INT_MIN LLONG_MIN + #define OBNC_INT_MAX LLONG_MAX + #define OBNC_UINT_MAX ULLONG_MAX + #define OBNC_INT_PREFIX(func) ll ## func +#else + #error Invalid value of OBNC_CONFIG_C_INT_TYPE +#endif + +#ifdef OBNC_CONFIG_USE_LONG_INT + #error OBNC_CONFIG_USE_LONG_INT is obsolete, use OBNC_CONFIG_C_INT_TYPE instead +#endif + +/*Properties of basic type REAL*/ + +#if OBNC_CONFIG_C_REAL_TYPE == OBNC_CONFIG_FLOAT + #define OBNC_REAL float + #define OBNC_REAL_MOD_R "" + #define OBNC_REAL_MOD_W "" + #define OBNC_REAL_MIN FLT_MIN + #define OBNC_REAL_MAX FLT_MAX + #define OBNC_REAL_PREFIX(func) f ## func + #define OBNC_REAL_SUFFIX(funcOrLiteral) funcOrLiteral ## f +#elif OBNC_CONFIG_C_REAL_TYPE == OBNC_CONFIG_DOUBLE + #define OBNC_REAL double + #define OBNC_LONGR /*obsolescent*/ + #define OBNC_REAL_MOD_R "l" + #define OBNC_REAL_MOD_W "" + #define OBNC_REAL_MIN DBL_MIN + #define OBNC_REAL_MAX DBL_MAX + #define OBNC_REAL_PREFIX(func) func + #define OBNC_REAL_SUFFIX(funcOrLiteral) funcOrLiteral +#elif OBNC_CONFIG_C_REAL_TYPE == OBNC_CONFIG_LONG_DOUBLE + #define OBNC_REAL long double + #define OBNC_LONGR long /*obsolescent*/ + #define OBNC_REAL_MOD_R "L" + #define OBNC_REAL_MOD_W "L" + #define OBNC_REAL_MIN LDBL_MIN + #define OBNC_REAL_MAX LDBL_MAX + #define OBNC_REAL_PREFIX(func) l ## func + #define OBNC_REAL_SUFFIX(funcOrLiteral) funcOrLiteral ## l +#else + #error Invalid value of OBNC_CONFIG_C_REAL_TYPE +#endif + +#ifdef OBNC_CONFIG_USE_LONG_REAL + #error OBNC_CONFIG_USE_LONG_REAL is obsolete, use OBNC_CONFIG_C_REAL_TYPE instead +#endif + +/*Predefined function procedures*/ + +#define OBNC_ABS_INT(x) OBNC_INT_PREFIX(abs)(x) +#define OBNC_ABS_FLT(x) OBNC_REAL_SUFFIX(fabs)(x) +#define OBNC_ODD(x) (((x) & 1) == 1) +#define OBNC_LSL(x, n) ((OBNC_INTEGER) (x) << (n)) +#define OBNC_ASR(x, n) ((OBNC_INTEGER) (x) >> (n)) +#define OBNC_ROR(x, n) ((OBNC_INTEGER) (((unsigned OBNC_INTEGER) (x) >> (n)) | ((unsigned OBNC_INTEGER) (x) << ((sizeof (OBNC_INTEGER) << 3) - (size_t) (n))))) + +/*Type conversions*/ + +#define OBNC_FLOOR(x) ((OBNC_INTEGER) OBNC_REAL_SUFFIX(floor)(x)) +#define OBNC_FLT(x) ((OBNC_REAL) (x)) +#define OBNC_ORD(x) ((OBNC_INTEGER) (x)) +#define OBNC_CHR(x) ((char) (x)) + +/*Predefined proper procedures*/ + +#define OBNC_INC(v) (v)++ +#define OBNC_INC_N(v, n) (v) += (n) + +#define OBNC_DEC(v) (v)-- +#define OBNC_DEC_N(v, n) (v) -= (n) + +#define OBNC_INCL(v, x) (v) |= (1 << (x)) +#define OBNC_EXCL(v, x) (v) &= ~((unsigned OBNC_INTEGER) 1 << (x)) + +#define OBNC_NEW(v, vtd, vHeapType, allocKind) \ + { \ + vHeapType *p = OBNC_Allocate(sizeof *p, (allocKind)); \ + if (p != NULL) { \ + p->td = (vtd); \ + (v) = &p->fields; \ + } else { \ + (v) = NULL; \ + }\ + } + +#define OBNC_NEW_ANON(v, allocKind) (v) = OBNC_Allocate(sizeof *(v), (allocKind)) + +#define OBNC_ASSERT(b, oberonFile, line) \ + if (! (b)) { \ + if (strcmp(#b, "0") == 0) { \ + OBNC_Exit(EXIT_FAILURE); \ + } else { \ + OBNC_handleTrap(OBNC_ASSERT_STATEMENT_EXCEPTION, (oberonFile), strlen(oberonFile) + 1, (line)); \ + OBNC_ExitTrap(); \ + } \ + } + +#define OBNC_C_ASSERT(b) \ + if (! (b)) { \ + OBNC_handleTrap(OBNC_ASSERT_STATEMENT_EXCEPTION, OBNC_CFILE, sizeof OBNC_CFILE, __LINE__); \ + OBNC_ExitTrap(); \ + } + +#define OBNC_PACK(x, n) (x) = OBNC_REAL_SUFFIX(ldexp)(x, n) + +#if OBNC_CONFIG_C_INT_TYPE != OBNC_CONFIG_INT + #define OBNC_UNPK(x, n) OBNC_Unpk(&(x), &(n)) +#else + #define OBNC_UNPK(x, n) (x) = OBNC_REAL_SUFFIX(frexp)(x, &(n)); (x) += (x); (n)-- +#endif + +/*SYSTEM procedures*/ + +#ifndef OBNC_ADR + #define OBNC_ADR(v) ((OBNC_INTEGER) &(v)) +#endif + +#ifndef OBNC_SIZE + #define OBNC_SIZE(T) ((OBNC_INTEGER) sizeof (T)) +#endif + +#ifndef OBNC_BIT + #define OBNC_BIT(a, n) (*(volatile OBNC_INTEGER *) (a) & ((OBNC_INTEGER) 1 << (n))) +#endif + +#ifndef OBNC_GET + #define OBNC_GET(a, v, T) (v) = *(volatile T *) (a) +#endif + +#ifndef OBNC_PUT + #define OBNC_PUT(a, x, T) *(volatile T *) (a) = (x) +#endif + +#ifndef OBNC_COPY + #define OBNC_COPY(src, dst, n) \ + { \ + int i; \ + for (i = 0; i < (n); i++) { \ + ((volatile OBNC_INTEGER *) (dst))[i] = ((volatile OBNC_INTEGER *) (src))[i]; \ + } \ + } +#endif + +#ifndef OBNC_VAL + #define OBNC_VAL(T, n) ((T) (n)) +#endif + +/*Type descriptor accessor*/ + +#define OBNC_TD(ptr, heapType) (*(const OBNC_Td **) ((char *) (ptr) - offsetof (heapType, fields))) + +/*Operators*/ + +#define OBNC_CMP(arr1, len1, arr2, len2) (strncmp((arr1), (arr2), ((len1) < (len2))? (len1): (len2))) + +#define OBNC_IS(var, td, typeID, extLevel) (((var) != NULL) && ((extLevel) < (td)->nids) && ((td)->ids[extLevel] == (typeID))) + +#define OBNC_DIV(x, y) (((x) >= 0)? (x) / (y): ((x) - OBNC_MOD(x, y)) / (y)) + +#define OBNC_MOD(x, y) (((x) >= 0)? (x) % (y): (((x) % (y)) + (y)) % (y)) + +#define OBNC_RANGE(m, n) \ + (((m) <= (n))? \ + (unsigned OBNC_INTEGER) ((((unsigned OBNC_INTEGER) -2) << (n)) ^ (((unsigned OBNC_INTEGER) -1)) << (m)): \ + (unsigned OBNC_INTEGER) 0x0u) + +#define OBNC_IN(x, A) ((int) ((((unsigned OBNC_INTEGER) 1) << (x)) & (A))) + +/*Structured assignments*/ + +#define OBNC_COPY_ARRAY(src, dst, n) memcpy(dst, src, (size_t) (n) * sizeof (src)[0]) + +/*Traps*/ + +#define OBNC_IT(index, length, line) \ + (((unsigned OBNC_INTEGER) (index) < (unsigned OBNC_INTEGER) (length)) \ + ? (index) \ + : (OBNC_handleTrap(OBNC_ARRAY_INDEX_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)), OBNC_ExitTrap(), (index))) + +#define OBNC_IT1(index, length, line) (OBNC_It1((index), (length), OBNC_OBNFILE, (line))) + +#define OBNC_RTT(recPtr, td, typeID, extLevel, line) \ + (OBNC_IS((recPtr), (td), (typeID), (extLevel)) \ + ? (recPtr) \ + : (OBNC_handleTrap(OBNC_TYPE_GUARD_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)), OBNC_ExitTrap(), (recPtr))) + +#define OBNC_PTT(ptrPtr, td, typeID, extLevel, line) \ + ((OBNC_IS(*(ptrPtr), (td), (typeID), (extLevel))) \ + ? (ptrPtr) \ + : (OBNC_handleTrap(OBNC_TYPE_GUARD_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)), OBNC_ExitTrap(), (ptrPtr))) + +#define OBNC_AAT(sourceLen, targetLen, line) \ + if (sourceLen > targetLen) { \ + OBNC_handleTrap(OBNC_ARRAY_ASSIGNMENT_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)); \ + OBNC_ExitTrap(); \ + } + +#define OBNC_RAT(srcTD, dstTD, line) \ + if (! (((srcTD)->nids >= (dstTD)->nids) \ + && ((srcTD)->ids[(dstTD)->nids - 1] == (dstTD)->ids[(dstTD)->nids - 1]))) { \ + OBNC_handleTrap(OBNC_RECORD_ASSIGNMENT_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)); \ + OBNC_ExitTrap(); \ + } + +#define OBNC_PT(ptr, line) \ + (((ptr) != NULL)? \ + (ptr): \ + (OBNC_handleTrap(OBNC_POINTER_DEREFERENCE_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)), OBNC_ExitTrap(), (ptr))) + +#define OBNC_PCT(ptr, line) \ + (((ptr) != NULL)? \ + (ptr): \ + (OBNC_handleTrap(OBNC_PROCEDURE_CALL_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)), OBNC_ExitTrap(), (ptr))) + +#define OBNC_CT(line) \ + OBNC_handleTrap(OBNC_CASE_EXP_MATCH_EXCEPTION, OBNC_OBNFILE, sizeof OBNC_OBNFILE, (line)); \ + OBNC_ExitTrap() + +typedef struct { + const int *const *ids; /*basetype IDs*/ + const int nids; /*length of ids*/ +} OBNC_Td; + +typedef void (*OBNC_TrapHandler)(OBNC_INTEGER exception, const char file[], OBNC_INTEGER fileLen, OBNC_INTEGER line); + +extern int OBNC_argc; +extern char **OBNC_argv; +extern OBNC_TrapHandler OBNC_handleTrap; + +void OBNC_Init(int argc, char *argv[]); + +void OBNC_ExitTrap(void); + +void *OBNC_Allocate(size_t size, int kind); + +void OBNC_Exit(int status); + +/*Functions used instead of the corresponding macros when a parameter contains a function call, which must not be evaluated more than once*/ + +int OBNC_Cmp(const char s[], OBNC_INTEGER sLen, const char t[], OBNC_INTEGER tLen); + +OBNC_INTEGER OBNC_Div(OBNC_INTEGER x, OBNC_INTEGER y); + +OBNC_INTEGER OBNC_It1(OBNC_INTEGER index, OBNC_INTEGER length, const char file[], int line); + +OBNC_INTEGER OBNC_Mod(OBNC_INTEGER x, OBNC_INTEGER y); + +unsigned OBNC_INTEGER OBNC_Range(OBNC_INTEGER m, OBNC_INTEGER n); + +OBNC_INTEGER OBNC_Ror(OBNC_INTEGER x, OBNC_INTEGER n); + +void OBNC_Pack(OBNC_REAL *x, OBNC_INTEGER n); + +void OBNC_Unpk(OBNC_REAL *x, OBNC_INTEGER *n); + +/*On small systems fprintf takes up too much memory*/ + +void OBNC_WriteInt(OBNC_INTEGER x, OBNC_INTEGER n, FILE *f); + +void OBNC_WriteHex(unsigned OBNC_INTEGER x, FILE *f); + +#endif diff --git a/lib/obnc/OBNCTest.c b/lib/obnc/OBNCTest.c new file mode 100644 index 0000000..49771a8 --- /dev/null +++ b/lib/obnc/OBNCTest.c @@ -0,0 +1,236 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "OBNC.h" +#include +#include +#include + +#define LEN(arr) ((int) (sizeof (arr) / sizeof (arr)[0])) +#define INTEGER_BITS (sizeof (OBNC_INTEGER) * CHAR_BIT) + +static void TestABS(void) +{ + assert(OBNC_ABS_INT(-1) == 1); + assert(OBNC_ABS_INT(0) == 0); + assert(OBNC_ABS_INT(1) == 1); + + assert(OBNC_ABS_FLT(-OBNC_REAL_SUFFIX(1.0)) == 1.0); + assert(OBNC_ABS_FLT(OBNC_REAL_SUFFIX(0.0)) == 0.0); + assert(OBNC_ABS_FLT(OBNC_REAL_SUFFIX(1.0)) == 1.0); +} + + +static void TestODD(void) +{ + assert(! OBNC_ODD(-2)); + assert(OBNC_ODD(-1)); + assert(! OBNC_ODD(0)); + assert(OBNC_ODD(1)); + assert(! OBNC_ODD(2)); +} + + +static void TestLSL(void) +{ + assert(OBNC_LSL(0, 0) == 0); + assert(OBNC_LSL(0, 1) == 0); + assert(OBNC_LSL(1, 0) == 1); + assert(OBNC_LSL(1, 1) == 2); +} + + +static void TestASR(void) +{ + assert(OBNC_ASR(0, 0) == 0); + assert(OBNC_ASR(0, 1) == 0); + assert(OBNC_ASR(1, 0) == 1); + assert(OBNC_ASR(1, 1) == 0); + assert(OBNC_ASR(~0, 1) == ~0); +} + + +static void TestROR(void) +{ + assert(OBNC_ROR(0, 1) == 0); + assert(OBNC_ROR(2, 1) == 1); + assert(OBNC_ROR(1, 2) == (OBNC_INTEGER) 1 << (INTEGER_BITS - 2)); +} + + +static void TestFLOOR(void) +{ + assert(OBNC_FLOOR(-1.5) == -2); + assert(OBNC_FLOOR(0.0) == 0); + assert(OBNC_FLOOR(1.5) == 1); +} + + +static void TestFLT(void) +{ + assert(OBNC_FLT(-1) == -1.0); + assert(OBNC_FLT(0) == 0.0); + assert(OBNC_FLT(1) == 1.0); +} + + +static void TestORD(void) +{ + assert(OBNC_ORD('\0') == 0); + assert(OBNC_ORD('\1') == 1); +} + + +static void TestCHR(void) +{ + assert(OBNC_CHR(0) == '\0'); + assert(OBNC_CHR(1) == '\1'); +} + + +static void TestINC(void) +{ + int x; + + x = 0; + OBNC_INC(x); + assert(x == 1); + + x = 0; + OBNC_INC_N(x, 10); + assert(x == 10); +} + + +static void TestDEC(void) +{ + int x; + + x = 0; + OBNC_DEC(x); + assert(x == -1); + + x = 0; + OBNC_DEC_N(x, 10); + assert(x == -10); +} + + +static void TestINCL(void) +{ + int A; + + A = 0; + OBNC_INCL(A, 0); + assert(A == 1); +} + + +static void TestEXCL(void) +{ + unsigned OBNC_INTEGER A; + + A = 1; + OBNC_EXCL(A, 0); + assert(A == 0); +} + + +static void TestNEW(void) +{ + struct { int *typeID; int x; } *v; + + OBNC_NEW_ANON(v, OBNC_ATOMIC_NOINIT_ALLOC); + assert(v != NULL); + v->x = 1; + assert(v->x == 1); +} + + +static void TestASSERT(void) +{ + OBNC_ASSERT(1, "", -1); + /*can't test failure here*/ +} + + +static void TestPACK(void) +{ + const double eps = 0.01; + OBNC_REAL x; + + x = 1.0; + OBNC_PACK(x, 2); + assert(OBNC_ABS_FLT(x - OBNC_REAL_SUFFIX(4.0)) < eps); +} + + +static void TestUNPK(void) +{ + OBNC_REAL x; + OBNC_INTEGER n; + + x = 4.0; + OBNC_UNPK(x, n); + assert(x >= 1.0); + assert(x < 2.0); + assert(n == 2); +} + + +static void TestCMP(void) +{ + char s[4], t[4]; + + strcpy(s, "foo"); + assert(OBNC_CMP(s, LEN(s), "foo", LEN("foo")) == 0); + assert(OBNC_CMP(s, LEN(s), "fool", LEN("fool")) < 0); + assert(OBNC_CMP(s, LEN(s), "fo", LEN("fo")) > 0); + + strcpy(s, "fo"); + s[3] = 'x'; + strcpy(t, "fo"); + t[3] = 'y'; + assert(OBNC_CMP(s, LEN(s), t, LEN(t)) == 0); +} + + +int main(void) +{ + OBNC_Init(0, NULL); + + TestABS(); + TestODD(); + TestLSL(); + TestASR(); + TestROR(); + TestFLOOR(); + TestFLT(); + TestORD(); + TestCHR(); + TestINC(); + TestDEC(); + TestINCL(); + TestEXCL(); + TestNEW(); + TestASSERT(); + TestPACK(); + TestUNPK(); + TestCMP(); + + return 0; +} diff --git a/lib/obnc/Out.c b/lib/obnc/Out.c new file mode 100644 index 0000000..93614e0 --- /dev/null +++ b/lib/obnc/Out.c @@ -0,0 +1,62 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include ".obnc/Out.h" +#include +#include + +void Out__Open_(void) +{ + /*do nothing*/ +} + + +void Out__Char_(char ch) +{ + putchar(ch); +} + + +void Out__String_(const char s[], OBNC_INTEGER sLen) +{ + OBNC_INTEGER i; + + i = 0; + while ((i < sLen) && (s[i] != '\0')) { + putchar(s[i]); + i++; + } +} + + +void Out__Int_(OBNC_INTEGER i, OBNC_INTEGER n) +{ + OBNC_WriteInt(i, n, stdout); +} + + +void Out__Hex_(OBNC_INTEGER i) +{ + OBNC_WriteHex((unsigned OBNC_INTEGER) i, stdout); +} + + +void Out__Real_(OBNC_REAL x, OBNC_INTEGER n) +{ + printf("%*" OBNC_REAL_MOD_W "E", (int) n, x); +} + + +void Out__Ln_(void) +{ + putchar('\n'); +} + + +void Out__Init(void) +{ + /*do nothing*/ +} diff --git a/lib/obnc/Out.obn b/lib/obnc/Out.obn new file mode 100644 index 0000000..b3da450 --- /dev/null +++ b/lib/obnc/Out.obn @@ -0,0 +1,48 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE Out; +(**Output to the standard output stream + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*) + +(*implemented in C*) + + PROCEDURE Open*; +(**does nothing (included for compatibility with "The Oakwood Guidelines")*) + END Open; + + + PROCEDURE Char*(ch: CHAR); +(**writes the character ch to the end of the output stream*) + END Char; + + + PROCEDURE String*(s: ARRAY OF CHAR); +(**writes the null-terminated character sequence s to the end of the output stream (without 0X).*) + END String; + + + PROCEDURE Int*(i, n: INTEGER); +(**writes the integer i to the end of the output stream. If the textual representation of i requires m characters, i is right adjusted in a field of Max(n, m) characters padded with blanks at the left end. A plus sign is not written.*) + END Int; + + + PROCEDURE Hex*(i: INTEGER); +(**writes the integer i to the end of the output stream as a zero-padded unsigned hexadecimal number with a leading space. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + END Hex; + + + PROCEDURE Real*(x: REAL; n: INTEGER); +(**writes the real number x to the end of the output stream using an exponential form. If the textual representation of x requires m characters (including a two-digit signed exponent), x is right adjusted in a field of Max(n, m) characters padded with blanks at the left end. A plus sign of the mantissa is not written.*) + END Real; + + + PROCEDURE Ln*; +(**writes an end-of-line symbol to the end of the output stream*) + END Ln; + +END Out. diff --git a/lib/obnc/OutTest.obn b/lib/obnc/OutTest.obn new file mode 100644 index 0000000..471ac87 --- /dev/null +++ b/lib/obnc/OutTest.obn @@ -0,0 +1,41 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE OutTest; + + IMPORT Out; + +BEGIN + Out.Char("a"); Out.Ln; + Out.String("abc"); Out.Ln; + Out.Int(-07FFFH - 1, 0); Out.Ln; (*minimum 16-bit integer*) + Out.Int(-1, 0); Out.Ln; + Out.Int(-1, 3); Out.Ln; + Out.Int(0, 0); Out.Ln; + Out.Int(1, 0); Out.Ln; + Out.Int(37, 0); Out.Ln; + Out.Int(07FFFH, 0); Out.Ln; (*maximum 16-bit integer*) + Out.Hex(0); Out.Ln; + Out.Hex(1); Out.Ln; + Out.Hex(0BEEFH); Out.Ln; + Out.Real(-1.0, 0); Out.Ln; + Out.Real(0.0, 0); Out.Ln; + Out.Real(0.0, 14); Out.Ln; + Out.Real(1.0, 0); Out.Ln; + Out.Real(37.0, 0); Out.Ln; + Out.Real(0.37, 0); Out.Ln +END OutTest. diff --git a/lib/obnc/OutTest.sh b/lib/obnc/OutTest.sh new file mode 100755 index 0000000..d57b4a8 --- /dev/null +++ b/lib/obnc/OutTest.sh @@ -0,0 +1,91 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -e + +expectedOutput="a +abc +-32768 +-1 + -1 +0 +1 +37 +32767 + 0000 + 0001 + BEEF +-1.000000E+00 +0.000000E+00 + 0.000000E+00 +1.000000E+00 +3.700000E+01 +3.700000E-01" + +expectedOutput1="a +abc +-32768 +-1 + -1 +0 +1 +37 +32767 + 00000000 + 00000001 + 0000BEEF +-1.000000E+000 +0.000000E+000 + 0.000000E+000 +1.000000E+000 +3.700000E+001 +3.700000E-001" + +expectedOutput2="a +abc +-32768 +-1 + -1 +0 +1 +37 +32767 + 0000000000000000 + 0000000000000001 + 000000000000BEEF +-1.000000E+000 +0.000000E+000 + 0.000000E+000 +1.000000E+000 +3.700000E+001 +3.700000E-001" + +IFS=' +' +i=1 +for line in $(./OutTest); do + expectedLine="$(echo "$expectedOutput" | head -n "$i" | tail -n 1)" + expectedLine1="$(echo "$expectedOutput1" | head -n "$i" | tail -n 1)" + expectedLine2="$(echo "$expectedOutput2" | head -n "$i" | tail -n 1)" + if [ "$line" != "$expectedLine" ] && [ "$line" != "$expectedLine1" ] && [ "$line" != "$expectedLine2" ]; then + echo "test failed: output: \"$line\", expected output: \"$expectedLine\" or \"$expectedLine1\"" >&2 + exit 1 + fi + i="$(expr "$i" + 1)" +done diff --git a/lib/obnc/Strings.obn b/lib/obnc/Strings.obn new file mode 100644 index 0000000..ccf04ab --- /dev/null +++ b/lib/obnc/Strings.obn @@ -0,0 +1,164 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE Strings; +(**Operations on strings + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". All character arrays are assumed to contain 0X as a terminator and positions start at 0.*) + + PROCEDURE Length*(s: ARRAY OF CHAR): INTEGER; +(**Length(s) returns the number of characters in s up to and excluding the first 0X.*) + VAR i: INTEGER; + BEGIN + i := 0; + WHILE s[i] # 0X DO + INC(i) + END + RETURN i + END Length; + + + PROCEDURE Min(a, b: INTEGER): INTEGER; + BEGIN IF a > b THEN a := b END + RETURN a + END Min; + + + PROCEDURE Insert*(source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR); +(**Insert(src, pos, dst) inserts the string src into the string dst at position pos (0 <= pos <= Length(dst)). If pos = Length(dst), src is appended to dst. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X.*) + VAR sourceLength, destLength, newLength: INTEGER; + i, lim: INTEGER; + BEGIN + destLength := Length(dest); + ASSERT(pos >= 0); + ASSERT(pos <= destLength); + + sourceLength := Length(source); + newLength := Min(destLength + sourceLength, LEN(dest) - 1); + + (*make room for source in dest*) + dest[newLength] := 0X; + FOR i := newLength - 1 TO pos + sourceLength BY -1 DO + dest[i] := dest[i - sourceLength] + END; + + (*copy source to dest*) + lim := Min(pos + sourceLength - 1, newLength - 1); + FOR i := pos TO lim DO + dest[i] := source[i - pos]; + END + END Insert; + + + PROCEDURE Append*(extra: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR); +(**Append(s, dst) has the same effect as Insert(s, Length(dst), dst).*) + VAR destLength, newLength: INTEGER; + i: INTEGER; + BEGIN + destLength := Length(dest); + newLength := Min(destLength + Length(extra), LEN(dest) - 1); + + FOR i := destLength TO newLength - 1 DO + dest[i] := extra[i - destLength] + END; + dest[newLength] := 0X + END Append; + + + PROCEDURE Delete*(VAR s: ARRAY OF CHAR; pos, n: INTEGER); +(**Delete(s, pos, n) deletes n characters from s starting at position pos (0 <= pos <= Length(s)). If n > Length(s) - pos, the new length of s is pos.*) + VAR length, n1, i: INTEGER; + BEGIN + length := Length(s); + ASSERT(pos >= 0); + ASSERT(pos <= length); + ASSERT(n >= 0); + + n1 := Min(n, length - pos); (*actual number of characters to delete*) + FOR i := pos TO length - n1 DO + s[i] := s[i + n1] + END + END Delete; + + + PROCEDURE Replace*(source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR); +(**Replace(src, pos, dst) has the same effect as Delete(dst, pos, Length(src)) followed by an Insert(src, pos, dst).*) + VAR destLength, n, i: INTEGER; + BEGIN + destLength := Length(dest); + ASSERT(pos >= 0); + ASSERT(pos <= destLength); + + n := Min(Length(source), LEN(dest) - 1 - pos); (*actual number of characters to replace*) + + (*replace characters*) + FOR i := 0 TO n - 1 DO + dest[pos + i] := source[i] + END; + + IF pos + n > destLength THEN + dest[pos + n] := 0X + END + END Replace; + + + PROCEDURE Extract*(source: ARRAY OF CHAR; pos, n: INTEGER; VAR dest: ARRAY OF CHAR); +(**Extract(src, pos, n, dst) extracts a substring dst with n characters from position pos (0 <= pos <= Length(src)) in src. If n > Length(src) - pos, dst is only the part of src from pos to the end of src, i.e. Length(src) - 1. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X.*) + VAR sourceLength, n1, i: INTEGER; + BEGIN + sourceLength := Length(source); + ASSERT(pos >= 0); + ASSERT(pos <= sourceLength); + + n1 := Min(n, Min(sourceLength - pos, LEN(dest) - 1)); (*actual number of characters to extract*) + FOR i := 0 TO n1 - 1 DO + dest[i] := source[pos + i] + END; + dest[n1] := 0X + END Extract; + + + PROCEDURE Pos*(pattern, s: ARRAY OF CHAR; pos: INTEGER): INTEGER; +(**Pos(pat, s, pos) returns the position of the first occurrence of pat in s. Searching starts at position pos (0 <= pos <= Length(s)). If pat is not found, -1 is returned.*) + VAR is, ip, result: INTEGER; + BEGIN + ASSERT(pos >= 0); + ASSERT(pos < LEN(s)); + + is := pos - 1; + REPEAT + INC(is); + ip := 0; + WHILE (pattern[ip] # 0X) & (s[is + ip] = pattern[ip]) DO + INC(ip) + END + UNTIL (pattern[ip] = 0X) OR (s[is + ip] = 0X); + + IF pattern[ip] = 0X THEN + result := is + ELSE + result := -1 + END; + + ASSERT((result = -1) OR (result >= 0) & (result + ip < LEN(s))) + RETURN result + END Pos; + + + PROCEDURE Cap*(VAR s: ARRAY OF CHAR); +(**Cap(s) replaces each lower case letter within s by its upper case equivalent.*) + VAR i: INTEGER; + BEGIN + i := 0; + WHILE s[i] # 0X DO + IF (s[i] >= "a") & (s[i] <= "z") THEN + s[i] := CHR(ORD("A") + ORD(s[i]) - ORD("a")); + END; + INC(i) + END + END Cap; + +END Strings. diff --git a/lib/obnc/StringsTest.obn b/lib/obnc/StringsTest.obn new file mode 100644 index 0000000..840a060 --- /dev/null +++ b/lib/obnc/StringsTest.obn @@ -0,0 +1,117 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE StringsTest; + + IMPORT Strings; + + VAR + shortStr: ARRAY 4 OF CHAR; + s: ARRAY 14 OF CHAR; + +BEGIN + (*test Length*) + ASSERT(Strings.Length("") = 0); + shortStr := ""; + ASSERT(Strings.Length(shortStr) = 0); + shortStr := 22X; + ASSERT(Strings.Length(shortStr) = 1); + shortStr := "123"; + ASSERT(Strings.Length(shortStr) = 3); + + (*test Insert*) + s := "cde"; + Strings.Insert("ab", 0, s); + ASSERT(s = "abcde"); + s := "adef"; + Strings.Insert("bc", 1, s); + ASSERT(s = "abcdef"); + shortStr := "ade"; + Strings.Insert("bc", 1, shortStr); + ASSERT(shortStr = "abc"); + shortStr := "aef"; + Strings.Insert("bcd", 1, shortStr); + ASSERT(shortStr = "abc"); + s := "foo bar"; + Strings.Insert(" baz", Strings.Length(s), s); + ASSERT(s = "foo bar baz"); + Strings.Insert(" qux qux qux qux qux", Strings.Length(s), s); + ASSERT(s = "foo bar baz q"); + + (*test Append*) + s := ""; + Strings.Append("foo", s); + ASSERT(s = "foo"); + Strings.Append(" bar", s); + ASSERT(s = "foo bar"); + Strings.Append(" baz qux", s); + ASSERT(s = "foo bar baz q"); + + (*test Delete*) + s := "foo bar baz"; + Strings.Delete(s, 11, 4); + ASSERT(s = "foo bar baz"); + Strings.Delete(s, 7, 4); + ASSERT(s = "foo bar"); + Strings.Delete(s, 0, 4); + ASSERT(s = "bar"); + Strings.Delete(s, 1, 10); + ASSERT(s = "b"); + Strings.Delete(s, 0, 0); + ASSERT(s = "b"); + Strings.Delete(s, 0, 1); + ASSERT(s = ""); + + (*test Replace*) + s := "foo bar baz"; + Strings.Replace("qux", 4, s); + ASSERT(s = "foo qux baz"); + s := "foo bar"; + Strings.Replace("qux qux qux", 5, s); + ASSERT(s = "foo bqux qux "); + s := "foo"; + Strings.Replace(" bar", 3, s); + ASSERT(s = "foo bar"); + + (*test Extract*) + Strings.Extract("foo bar", 4, 3, shortStr); + ASSERT(shortStr = "bar"); + Strings.Extract("foo bar", 4, 10, shortStr); + ASSERT(shortStr = "bar"); + Strings.Extract("foo bar", 0, 6, shortStr); + ASSERT(shortStr = "foo"); + Strings.Extract("foo bar", 7, 4, shortStr); + ASSERT(shortStr = ""); + + (*test Pos*) + ASSERT(Strings.Pos("", "", 0) = 0); + ASSERT(Strings.Pos("", "foo", 0) = 0); + ASSERT(Strings.Pos("", "foo", 1) = 1); + ASSERT(Strings.Pos("", "foo", 3) = 3); + ASSERT(Strings.Pos("foo", "foo", 0) = 0); + ASSERT(Strings.Pos("foo", "fool", 0) = 0); + ASSERT(Strings.Pos("ool", "fool", 0) = 1); + ASSERT(Strings.Pos("oo", "fool", 0) = 1); + ASSERT(Strings.Pos("fools", "fool", 0) = -1); + ASSERT(Strings.Pos("ools", "fool", 0) = -1); + ASSERT(Strings.Pos("ol", "fool", 1) = 2); + + (*test Cap*) + s := "foo Bar BAZ"; + Strings.Cap(s); + ASSERT(s = "FOO BAR BAZ") +END StringsTest. diff --git a/lib/obnc/XYplane.c b/lib/obnc/XYplane.c new file mode 100644 index 0000000..d8397bb --- /dev/null +++ b/lib/obnc/XYplane.c @@ -0,0 +1,212 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*/ + +#include ".obnc/XYplane.h" +#include ".obnc/Input.h" +#include +#include /*SDL 1.2*/ +#include + +#define LEN(arr) ((int) (sizeof (arr) / sizeof (arr)[0])) + +#define WITHIN_BOUNDS(x, y) (((unsigned OBNC_INTEGER) (x) < (unsigned OBNC_INTEGER) plane->w) && ((unsigned OBNC_INTEGER) (y) < (unsigned OBNC_INTEGER) plane->h)) + +#define PIXEL_PTR(x, y) (((Uint32 *) plane->pixels) + (plane->h - 1- (y)) * plane->w + (x)) + +static SDL_Surface *plane; + +OBNC_INTEGER XYplane__X_ = 0; +OBNC_INTEGER XYplane__Y_ = 0; +OBNC_INTEGER XYplane__W_ = 0; +OBNC_INTEGER XYplane__H_ = 0; +static OBNC_INTEGER customWidth; +static OBNC_INTEGER customHeight; + +static Uint32 colors[2] = {0, 0xffffff}; + +static void CalculatePlaneSize(int useFullscreen, int *width, int *height) +{ + const SDL_VideoInfo *info; + int nominalW; + + *width = 0; + *height = 0; + info = SDL_GetVideoInfo(); + if (info != NULL) { + if (useFullscreen) { + *width = info->current_w; + *height = info->current_h; + } else if ((customWidth > 0) && (customHeight > 0)) { + *width = customWidth; + *height = customHeight; + } else { + if (info->current_h > info->current_w) { + nominalW = info->current_w * 4 / 5; + } else { + nominalW = info->current_h * 4 * 4 / (5 * 3); + } + *width = nominalW - nominalW % 4; + *height = *width * 3 / 4; + } + } else { + fprintf(stderr, "XYplane.Open failed: cannot get video info\n"); + } + OBNC_C_ASSERT(*width % 4 == 0); /*required for correct rendering*/ +} + + +static const char *Basename(const char path[]) +{ + const char *p, *result; + + p = strrchr(path, '/'); + if (p != NULL) { + result = p + 1; + } else { + result = path; + } + return result; +} + + +static void Open(int useFullscreen) +{ + int error, width, height; + unsigned int flags; + + if (plane != NULL) { + SDL_Quit(); + } + error = SDL_Init(SDL_INIT_VIDEO); + if (! error) { + atexit(SDL_Quit); + if (OBNC_argc > 0) { + SDL_WM_SetCaption(Basename(OBNC_argv[0]), NULL); + } else { + SDL_WM_SetCaption("XYplane - OBNC", NULL); + } + SDL_EnableUNICODE(1); + CalculatePlaneSize(useFullscreen, &width, &height); + flags = SDL_HWSURFACE | SDL_DOUBLEBUF; + if (useFullscreen) { + flags |= SDL_FULLSCREEN; + } + plane = SDL_SetVideoMode(width, height, 32, flags); + if (plane != NULL) { + XYplane__W_ = plane->w; + XYplane__H_ = plane->h; + if (SDL_MUSTLOCK(plane)) { + error = SDL_LockSurface(plane); + if (error) { + fprintf(stderr, "XYplane.Open failed: %s\n", SDL_GetError()); + } + } + } else { + fprintf(stderr, "XYplane.Open failed: %s\n", SDL_GetError()); + } + } else { + fprintf(stderr, "XYplane.Open failed: %s\n", SDL_GetError()); + } +} + + +void XYplane__Open_(void) +{ + Open(0); +} + + +void XYplane__Clear_(void) +{ + if (plane != NULL) { + if (SDL_MUSTLOCK(plane)) { + SDL_LockSurface(plane); + SDL_FillRect(plane, NULL, 0); + SDL_UnlockSurface(plane); + } else { + SDL_FillRect(plane, NULL, 0); + } + } +} + + +void XYplane__Dot_(OBNC_INTEGER x, OBNC_INTEGER y, OBNC_INTEGER mode) +{ + OBNC_C_ASSERT(mode >= 0); + OBNC_C_ASSERT(mode < LEN(colors)); + + if ((plane != NULL) && WITHIN_BOUNDS(x, y)) { + *PIXEL_PTR(x, y) = colors[mode]; + } +} + + +int XYplane__IsDot_(OBNC_INTEGER x, OBNC_INTEGER y) +{ + return (plane != NULL) && WITHIN_BOUNDS(x, y) && (*PIXEL_PTR(x, y) != 0); +} + + +char XYplane__Key_(void) +{ + static const int ack = 0x06; /*Ctrl-f*/ + static const int esc = 0x1b; + char result = 0; + int fullscreen; + + if (plane != NULL) { + if (SDL_MUSTLOCK(plane)) { + SDL_LockSurface(plane); + SDL_Flip(plane); + SDL_UnlockSurface(plane); + } else { + SDL_Flip(plane); + } + if (Input__Available_() > 0) { + Input__Read_(&result); + fullscreen = (plane->flags & SDL_FULLSCREEN) != 0; + if (result == ack) { + Open(! fullscreen); + } else if ((result == esc) && fullscreen) { + Open(0); + } + } + SDL_Delay(10); + } + return result; +} + + +void XYplane__SetSize_(OBNC_INTEGER width, OBNC_INTEGER height) +{ + OBNC_C_ASSERT(width > 0); + OBNC_C_ASSERT(height > 0); + + if (width % 4 == 0) { + customWidth = width; + } else { + customWidth = width + 4 - width % 4; + } + customHeight = height; +} + + +void XYplane__UseColor_(OBNC_INTEGER color) +{ + colors[1] = color; +} + + +OBNC_INTEGER XYplane__Color_(OBNC_INTEGER x, OBNC_INTEGER y) +{ + return ((plane != NULL) && WITHIN_BOUNDS(x, y))? *PIXEL_PTR(x, y): 0; +} + + +void XYplane__Init(void) +{ + /*do nothing*/ +} diff --git a/lib/obnc/XYplane.env b/lib/obnc/XYplane.env new file mode 100644 index 0000000..d516f62 --- /dev/null +++ b/lib/obnc/XYplane.env @@ -0,0 +1,2 @@ +CFLAGS=$(sdl-config --cflags) +LDLIBS=$(sdl-config --libs) diff --git a/lib/obnc/XYplane.obn b/lib/obnc/XYplane.obn new file mode 100644 index 0000000..dc66b1c --- /dev/null +++ b/lib/obnc/XYplane.obn @@ -0,0 +1,85 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This Source Code Form is subject to the terms of the Mozilla Public +License, v. 2.0. If a copy of the MPL was not distributed with this +file, You can obtain one at http://mozilla.org/MPL/2.0/.*) + +MODULE XYplane; +(**Basic facilities for graphics programming + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". The drawing plane is repainted when Key is invoked. Fullscreen mode is toggled with Ctrl-f; it can also be exited with Esc.*) + +(*implemented in C*) + + IMPORT Input; (*required by the implementation*) + + CONST + (**drawing modes*) + draw* = 1; + erase* = 0; + + VAR + X*, Y*: INTEGER; (**X = 0 and Y = 0. Included for compatibility with The Oakwood Guidelines.*) + W*, H*: INTEGER; (**width and height of the drawing plane in pixels*) + + PROCEDURE Open*; +(**initializes the drawing plane*) + END Open; + + PROCEDURE Clear*; +(**erases all pixels in the drawing plane*) + END Clear; + + PROCEDURE Dot*(x, y, mode: INTEGER); +(**Dot(x, y, m) draws or erases the pixel at the coordinates (x, y) relative to the lower left corner of the plane. If m = draw the pixel is drawn, if m = erase the pixel is erased.*) + END Dot; + + PROCEDURE IsDot*(x, y: INTEGER): BOOLEAN; +(**returns TRUE if the pixel at the coordinates (x, y) relative to the lower left corner of the screen is drawn, otherwise it returns FALSE*) + RETURN FALSE (*dummy value*) + END IsDot; + + PROCEDURE Key*(): CHAR; +(**reads the keyboard. If a key was pressed prior to invocation, its character value is returned, otherwise the result is 0X.*) + RETURN CHR(0) (*dummy value*) + END Key; + + PROCEDURE SetSize*(width, height: INTEGER); +(**sets the width and height of the drawing plane. The setting takes effect when Open is called. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + END SetSize; + + PROCEDURE UseColor*(color: INTEGER); +(**sets the red, green and blue components of the drawing color as a three-byte value. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + END UseColor; + + PROCEDURE Color*(x, y: INTEGER): INTEGER; +(**returns the color of the pixel at the coordinates (x, y). NOTE: This procedure is an extension to The Oakwood Guidelines.*) + RETURN 0 (*dummy value*) + END Color; + +(**Example: + +MODULE drawpixels; + + (*click or drag the mouse to draw pixels*) + + IMPORT Input, XYplane; + + VAR + x, y: INTEGER; + keys: SET; + +BEGIN + XYplane.Open; + REPEAT + Input.Mouse(keys, x, y); + IF 2 IN keys THEN + XYplane.Dot(x, y, XYplane.draw) + END + UNTIL XYplane.Key() = "q" +END drawpixels. +*) + +BEGIN + ASSERT(Input.TimeUnit > 0) (*silence "Input unused" compiler note*) +END XYplane. diff --git a/lib/obnc/XYplaneTest.obn b/lib/obnc/XYplaneTest.obn new file mode 100644 index 0000000..154d2aa --- /dev/null +++ b/lib/obnc/XYplaneTest.obn @@ -0,0 +1,92 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE XYplaneTest; + + IMPORT XYplane; + + PROCEDURE TestPosition(x, y: INTEGER); + VAR withinBounds: BOOLEAN; + BEGIN + withinBounds := (x >= 0) & (x < XYplane.W) + & (y >= 0) & (y < XYplane.H); + XYplane.Clear; + XYplane.Dot(x, y, XYplane.draw); + ASSERT(withinBounds & XYplane.IsDot(x, y) + OR ~withinBounds & ~XYplane.IsDot(x, y)); + XYplane.Dot(x, y, XYplane.erase); + ASSERT(~XYplane.IsDot(x, y)) + END TestPosition; + + + PROCEDURE Run; + VAR x, y, w, h: INTEGER; + BEGIN + x := XYplane.X; + y := XYplane.Y; + w := XYplane.W; + h := XYplane.H; + + XYplane.Open; + + XYplane.Open; (*reopening test*) + + (*corners*) + + TestPosition(x, y); + TestPosition(x, y + h - 1); + TestPosition(x + w - 1, y + h - 1); + TestPosition(x, y + h - 1); + + (*just outside the corners*) + + TestPosition(x - 1, y); + TestPosition(x - 1, y - 1); + TestPosition(x, y - 1); + + TestPosition(x - 1, y + h - 1); + TestPosition(x - 1, y + h); + TestPosition(x, y + h); + + TestPosition(x + w - 1, y + h); + TestPosition(x + w, y + h); + TestPosition(x + w, y + h - 1); + + TestPosition(x + w, y); + TestPosition(x + w, y - 1); + TestPosition(x + w - 1, y - 1); + + (*test SetSize*) + XYplane.SetSize(640, 480); + XYplane.Open; + ASSERT(XYplane.W = 640); + ASSERT(XYplane.H = 480); + + (*test UseColor and Color*) + XYplane.UseColor(00FF3FH); + XYplane.Dot(100, 100, XYplane.draw); + ASSERT(XYplane.Color(100, 100) = 00FF3FH); + ASSERT(XYplane.IsDot(100, 100)); + XYplane.UseColor(0); + XYplane.Dot(100, 100, XYplane.draw); + ASSERT(XYplane.Color(100, 100) = 0); + ASSERT(~XYplane.IsDot(100, 100)) + END Run; + +BEGIN + Run +END XYplaneTest. diff --git a/lib/obnc/obncdoc/Files.def b/lib/obnc/obncdoc/Files.def new file mode 100644 index 0000000..7de32ae --- /dev/null +++ b/lib/obnc/obncdoc/Files.def @@ -0,0 +1,99 @@ +DEFINITION Files; +(*Operations on files + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*) + + TYPE + File = POINTER TO Handle; + + Rider = RECORD + eof: BOOLEAN; + res: INTEGER; + END; + + PROCEDURE Old(name: ARRAY OF CHAR): File; +(*Old(fn) searches the name fn in the directory and returns the corresponding file. If the name is not found, it returns NIL.*) + + PROCEDURE New(name: ARRAY OF CHAR): File; +(*New(fn) creates and returns a new file. The name fn is remembered for the later use of the operation Register. The file is only entered into the directory when Register is called.*) + + PROCEDURE Register(f: File); +(*enters the file f into the directory together with the name provided in the operation New that created f. The file buffers are written back. Any existing mapping of this name to another file is overwritten.*) + + PROCEDURE Close(f: File); +(*writes back the file buffers of f. The file is still accessible by its handle f and the riders positioned on it. If a file is not modified it is not necessary to close it.*) + + PROCEDURE Purge(f: File); +(*resets the length of file f to 0*) + + PROCEDURE Delete(name: ARRAY OF CHAR; VAR res: INTEGER); +(*Delete(fn, res) removes the directory entry for the file fn without deleting the file. If res = 0 the file has been successfully deleted. If there are variables referring to the file while Delete is called, they can still be used.*) + + PROCEDURE Rename(old, new: ARRAY OF CHAR; VAR res: INTEGER); +(*Rename(oldfn, newfn, res) renames the directory entry oldfn to newfn. If res = 0 the file has been successfully renamed. If there are variables referring to the file while Rename is called, they can still be used.*) + + PROCEDURE Length(f: File): INTEGER; +(*returns the number of bytes in file f*) + + PROCEDURE GetDate(f: File; VAR t, d: INTEGER); +(*returns the time t and date d of the last modification of file f. The encoding is: hour = t DIV 4096; minute = t DIV 64 MOD 64; second = t MOD 64; year = d DIV 512; month = d DIV 32 MOD 16; day = d MOD 32.*) + + PROCEDURE Set(VAR r: Rider; f: File; pos: INTEGER); +(*sets the rider r to position pos in file f. The field r.eof is set to FALSE. The +operation requires that 0 <= pos <= Length(f)*) + + PROCEDURE Pos(VAR r: Rider): INTEGER; +(*returns the position of the rider r*) + + PROCEDURE Base(VAR r: Rider): File; +(*returns the file to which the rider r has been set*) + + PROCEDURE Read(VAR r: Rider; VAR x: BYTE); +(*reads the next byte x from rider r and advances r accordingly*) + + PROCEDURE ReadInt(VAR r: Rider; VAR i: INTEGER); +(*reads an integer i from rider r and advances r accordingly.*) + + PROCEDURE ReadReal(VAR r: Rider; VAR x: REAL); +(*reads a real number x from rider r and advances r accordingly.*) + + PROCEDURE ReadNum(VAR r: Rider; VAR i: INTEGER); +(*reads an integer i from rider r and advances r accordingly. The number i is compactly encoded*) + + PROCEDURE ReadString(VAR r: Rider; VAR s: ARRAY OF CHAR); +(*reads a sequence of characters (including the terminating 0X) from rider r and returns it in s. The rider is advanced accordingly. The actual parameter corresponding to s must be long enough to hold the character sequence plus the terminating 0X.*) + + PROCEDURE ReadSet(VAR r: Rider; VAR s: SET); +(*reads a set s from rider r and advances r accordingly*) + + PROCEDURE ReadBool(VAR r: Rider; VAR b: BOOLEAN); +(*reads a Boolean value b from rider r and advances r accordingly*) + + PROCEDURE ReadBytes(VAR r: Rider; VAR buf: ARRAY OF BYTE; n: INTEGER); +(*reads n bytes into buffer buf starting at the rider position r. The rider is advanced accordingly. If less than n bytes could be read, r.res contains the number of requested but unread bytes.*) + + PROCEDURE Write(VAR r: Rider; x: BYTE); +(*writes the byte x to rider r and advances r accordingly*) + + PROCEDURE WriteInt(VAR r: Rider; i: INTEGER); +(*writes the integer i to rider r and advances r accordingly*) + + PROCEDURE WriteReal(VAR r: Rider; x: REAL); +(*writes the real number x to rider r and advances r accordingly*) + + PROCEDURE WriteNum(VAR r: Rider; i: INTEGER); +(*writes the integer i to rider r and advances r accordingly. The number i is compactly encoded.*) + + PROCEDURE WriteString(VAR r: Rider; s: ARRAY OF CHAR); +(*writes the sequence of characters s (including the terminating 0X) to rider r and advances r accordingly*) + + PROCEDURE WriteSet(VAR r: Rider; s: SET); +(*writes the set s to rider r and advances r accordingly*) + + PROCEDURE WriteBool(VAR r: Rider; b: BOOLEAN); +(*writes the Boolean value b to rider r and advances r accordingly.*) + + PROCEDURE WriteBytes(VAR r: Rider; VAR buf: ARRAY OF BYTE; n: INTEGER); +(*writes the first n bytes from buf to rider r and advances r accordingly. r.res contains the number of bytes that could not be written (e.g., due to a disk full error).*) + +END Files. diff --git a/lib/obnc/obncdoc/Files.def.html b/lib/obnc/obncdoc/Files.def.html new file mode 100644 index 0000000..115da52 --- /dev/null +++ b/lib/obnc/obncdoc/Files.def.html @@ -0,0 +1,114 @@ + + + + + + DEFINITION Files + + + +

Index

+ + 
+DEFINITION Files;
+(*Operations on files
+
+Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*)
+
+	TYPE
+		File = POINTER TO Handle;
+
+		Rider = RECORD
+			eof: BOOLEAN;
+			res: INTEGER;
+		END;
+
+	PROCEDURE Old(name: ARRAY OF CHAR): File;
+(*Old(fn) searches the name fn in the directory and returns the corresponding file. If the name is not found, it returns NIL.*)
+
+	PROCEDURE New(name: ARRAY OF CHAR): File;
+(*New(fn) creates and returns a new file. The name fn is remembered for the later use of the operation Register. The file is only entered into the directory when Register is called.*)
+
+	PROCEDURE Register(f: File);
+(*enters the file f into the directory together with the name provided in the operation New that created f. The file buffers are written back. Any existing mapping of this name to another file is overwritten.*)
+
+	PROCEDURE Close(f: File);
+(*writes back the file buffers of f. The file is still accessible by its handle f and the riders positioned on it. If a file is not modified it is not necessary to close it.*)
+
+	PROCEDURE Purge(f: File);
+(*resets the length of file f to 0*)
+
+	PROCEDURE Delete(name: ARRAY OF CHAR; VAR res: INTEGER);
+(*Delete(fn, res) removes the directory entry for the file fn without deleting the file. If res = 0 the file has been successfully deleted. If there are variables referring to the file while Delete is called, they can still be used.*)
+
+	PROCEDURE Rename(old, new: ARRAY OF CHAR; VAR res: INTEGER);
+(*Rename(oldfn, newfn, res) renames the directory entry oldfn to newfn. If res = 0 the file has been successfully renamed. If there are variables referring to the file while Rename is called, they can still be used.*)
+
+	PROCEDURE Length(f: File): INTEGER;
+(*returns the number of bytes in file f*)
+
+	PROCEDURE GetDate(f: File; VAR t, d: INTEGER);
+(*returns the time t and date d of the last modification of file f. The encoding is: hour = t DIV 4096; minute = t DIV 64 MOD 64; second = t MOD 64; year = d DIV 512; month = d DIV 32 MOD 16; day = d MOD 32.*)
+
+	PROCEDURE Set(VAR r: Rider; f: File; pos: INTEGER);
+(*sets the rider r to position pos in file f. The field r.eof is set to FALSE. The
+operation requires that 0 <= pos <= Length(f)*)
+
+	PROCEDURE Pos(VAR r: Rider): INTEGER;
+(*returns the position of the rider r*)
+
+	PROCEDURE Base(VAR r: Rider): File;
+(*returns the file to which the rider r has been set*)
+
+	PROCEDURE Read(VAR r: Rider; VAR x: BYTE);
+(*reads the next byte x from rider r and advances r accordingly*)
+
+	PROCEDURE ReadInt(VAR r: Rider; VAR i: INTEGER);
+(*reads an integer i from rider r and advances r accordingly.*)
+
+	PROCEDURE ReadReal(VAR r: Rider; VAR x: REAL);
+(*reads a real number x from rider r and advances r accordingly.*)
+
+	PROCEDURE ReadNum(VAR r: Rider; VAR i: INTEGER);
+(*reads an integer i from rider r and advances r accordingly. The number i is compactly encoded*)
+
+	PROCEDURE ReadString(VAR r: Rider; VAR s: ARRAY OF CHAR);
+(*reads a sequence of characters (including the terminating 0X) from rider r and returns it in s. The rider is advanced accordingly. The actual parameter corresponding to s must be long enough to hold the character sequence plus the terminating 0X.*)
+
+	PROCEDURE ReadSet(VAR r: Rider; VAR s: SET);
+(*reads a set s from rider r and advances r accordingly*)
+
+	PROCEDURE ReadBool(VAR r: Rider; VAR b: BOOLEAN);
+(*reads a Boolean value b from rider r and advances r accordingly*)
+
+	PROCEDURE ReadBytes(VAR r: Rider; VAR buf: ARRAY OF BYTE; n: INTEGER);
+(*reads n bytes into buffer buf starting at the rider position r. The rider is advanced accordingly. If less than n bytes could be read, r.res contains the number of requested but unread bytes.*)
+
+	PROCEDURE Write(VAR r: Rider; x: BYTE);
+(*writes the byte x to rider r and advances r accordingly*)
+
+	PROCEDURE WriteInt(VAR r: Rider; i: INTEGER);
+(*writes the integer i to rider r and advances r accordingly*)
+
+	PROCEDURE WriteReal(VAR r: Rider; x: REAL);
+(*writes the real number x to rider r and advances r accordingly*)
+
+	PROCEDURE WriteNum(VAR r: Rider; i: INTEGER);
+(*writes the integer i to rider r and advances r accordingly. The number i is compactly encoded.*)
+
+	PROCEDURE WriteString(VAR r: Rider; s: ARRAY OF CHAR);
+(*writes the sequence of characters s (including the terminating 0X) to rider r and advances r accordingly*)
+
+	PROCEDURE WriteSet(VAR r: Rider; s: SET);
+(*writes the set s to rider r and advances r accordingly*)
+
+	PROCEDURE WriteBool(VAR r: Rider; b: BOOLEAN);
+(*writes the Boolean value b to rider r and advances r accordingly.*)
+
+	PROCEDURE WriteBytes(VAR r: Rider; VAR buf: ARRAY OF BYTE; n: INTEGER);
+(*writes the first n bytes from buf to rider r and advances r accordingly. r.res contains the number of bytes that could not be written (e.g., due to a disk full error).*)
+
+END Files.
+
+ + diff --git a/lib/obnc/obncdoc/FilesTest.def b/lib/obnc/obncdoc/FilesTest.def new file mode 100644 index 0000000..0be0afc --- /dev/null +++ b/lib/obnc/obncdoc/FilesTest.def @@ -0,0 +1,2 @@ +DEFINITION FilesTest; +END FilesTest. diff --git a/lib/obnc/obncdoc/FilesTest.def.html b/lib/obnc/obncdoc/FilesTest.def.html new file mode 100644 index 0000000..afd819e --- /dev/null +++ b/lib/obnc/obncdoc/FilesTest.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION FilesTest + + + +

Index

+ + 
+DEFINITION FilesTest;
+END FilesTest.
+
+ + diff --git a/lib/obnc/obncdoc/In.def b/lib/obnc/obncdoc/In.def new file mode 100644 index 0000000..b45e957 --- /dev/null +++ b/lib/obnc/obncdoc/In.def @@ -0,0 +1,40 @@ +DEFINITION In; +(*Input from the standard input stream + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". All read operations except Char and Line skips over preceding whitespace.*) + + VAR Done: BOOLEAN; (*status of last operation*) + + PROCEDURE Open; +(*included for compatibility with "The Oakwood Guidelines". On a typical Unix-like system, stdin cannot be rewinded. If Open is called when the file position is not at the beginning of stdin, the program aborts.*) + + PROCEDURE Char(VAR ch: CHAR); +(*returns in ch the character at the current position*) + + PROCEDURE Int(VAR i: INTEGER); +(*returns in i the integer constant at the current position according to the format + + integer = digit {digit} | digit {hexDigit} "H". + hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F". +*) + + PROCEDURE Real(VAR x: REAL); +(*returns in x the real constant at the current position according to the format + + real = digit {digit} "." {digit} [ScaleFactor]. + ScaleFactor = "E" ["+" | "-"] digit {digit}. +*) + + PROCEDURE String(VAR str: ARRAY OF CHAR); +(*returns in str the string at the current position according to the format + + string = """ {character} """ | digit {hexdigit} "X" . +*) + + PROCEDURE Name(VAR name: ARRAY OF CHAR); +(*Name(s) returns in s the sequence of graphical (non-whitespace) characters at the current position*) + + PROCEDURE Line(VAR line: ARRAY OF CHAR); +(*Line(s) returns in s the sequence of characters from the current position to the end of the line. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + +END In. diff --git a/lib/obnc/obncdoc/In.def.html b/lib/obnc/obncdoc/In.def.html new file mode 100644 index 0000000..b31bcc3 --- /dev/null +++ b/lib/obnc/obncdoc/In.def.html @@ -0,0 +1,55 @@ + + + + + + DEFINITION In + + + +

Index

+ + 
+DEFINITION In;
+(*Input from the standard input stream
+
+Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". All read operations except Char and Line skips over preceding whitespace.*)
+
+	VAR Done: BOOLEAN; (*status of last operation*)
+
+	PROCEDURE Open;
+(*included for compatibility with "The Oakwood Guidelines". On a typical Unix-like system, stdin cannot be rewinded. If Open is called when the file position is not at the beginning of stdin, the program aborts.*)
+
+	PROCEDURE Char(VAR ch: CHAR);
+(*returns in ch the character at the current position*)
+
+	PROCEDURE Int(VAR i: INTEGER);
+(*returns in i the integer constant at the current position according to the format
+
+	integer = digit {digit} | digit {hexDigit} "H".
+	hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".
+*)
+
+	PROCEDURE Real(VAR x: REAL);
+(*returns in x the real constant at the current position according to the format
+
+	real = digit {digit} "." {digit} [ScaleFactor].
+	ScaleFactor = "E" ["+" | "-"] digit {digit}.
+*)
+
+	PROCEDURE String(VAR str: ARRAY OF CHAR);
+(*returns in str the string at the current position according to the format
+
+	string = """ {character} """ | digit {hexdigit} "X" .
+*)
+
+	PROCEDURE Name(VAR name: ARRAY OF CHAR);
+(*Name(s) returns in s the sequence of graphical (non-whitespace) characters at the current position*)
+
+	PROCEDURE Line(VAR line: ARRAY OF CHAR);
+(*Line(s) returns in s the sequence of characters from the current position to the end of the line. NOTE: This procedure is an extension to The Oakwood Guidelines.*)
+
+END In.
+
+ + diff --git a/lib/obnc/obncdoc/InTest.def b/lib/obnc/obncdoc/InTest.def new file mode 100644 index 0000000..73defc9 --- /dev/null +++ b/lib/obnc/obncdoc/InTest.def @@ -0,0 +1,2 @@ +DEFINITION InTest; +END InTest. diff --git a/lib/obnc/obncdoc/InTest.def.html b/lib/obnc/obncdoc/InTest.def.html new file mode 100644 index 0000000..6251d89 --- /dev/null +++ b/lib/obnc/obncdoc/InTest.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION InTest + + + +

Index

+ + 
+DEFINITION InTest;
+END InTest.
+
+ + diff --git a/lib/obnc/obncdoc/Input.def b/lib/obnc/obncdoc/Input.def new file mode 100644 index 0000000..884dbcb --- /dev/null +++ b/lib/obnc/obncdoc/Input.def @@ -0,0 +1,23 @@ +DEFINITION Input; +(*Access to keyboard, mouse and clock + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". This module is implemented to be used in tandem with basic module XYplane. For a console application, use module Input0 instead.*) + + VAR TimeUnit: INTEGER; (*clock ticks per second*) + + PROCEDURE Available(): INTEGER; +(*returns the number of characters in the keyboard buffer*) + + PROCEDURE Read(VAR ch: CHAR); +(*returns (and removes) the next character from the keyboard buffer. If the buffer is empty, Read waits until a key is pressed.*) + + PROCEDURE Mouse(VAR keys: SET; VAR x, y: INTEGER); +(*returns the current mouse position (x, y) in pixels relative to the lower left corner of the screen. keys is the set of the currently pressed mouse keys (left = 2, middle = 1, right = 0).*) + + PROCEDURE SetMouseLimits(w, h: INTEGER); +(*defines the rectangle where the mouse moves (in pixels). Subsequent calls to the operation Mouse will return coordinates for x in the range 0 .. w - 1 and y in the range 0 .. h - 1.*) + + PROCEDURE Time(): INTEGER; +(*returns the time elapsed since system startup in units of size 1 / TimeUnit seconds*) + +END Input. diff --git a/lib/obnc/obncdoc/Input.def.html b/lib/obnc/obncdoc/Input.def.html new file mode 100644 index 0000000..536e668 --- /dev/null +++ b/lib/obnc/obncdoc/Input.def.html @@ -0,0 +1,38 @@ + + + + + + DEFINITION Input + + + +

Index

+ + 
+DEFINITION Input;
+(*Access to keyboard, mouse and clock
+
+Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". This module is implemented to be used in tandem with basic module XYplane. For a console application, use module Input0 instead.*)
+
+	VAR TimeUnit: INTEGER; (*clock ticks per second*)
+
+	PROCEDURE Available(): INTEGER;
+(*returns the number of characters in the keyboard buffer*)
+
+	PROCEDURE Read(VAR ch: CHAR);
+(*returns (and removes) the next character from the keyboard buffer. If the buffer is empty, Read waits until a key is pressed.*)
+
+	PROCEDURE Mouse(VAR keys: SET; VAR x, y: INTEGER);
+(*returns the current mouse position (x, y) in pixels relative to the lower left corner of the screen. keys is the set of the currently pressed mouse keys (left = 2, middle = 1, right = 0).*)
+
+	PROCEDURE SetMouseLimits(w, h: INTEGER);
+(*defines the rectangle where the mouse moves (in pixels). Subsequent calls to the operation Mouse will return coordinates for x in the range 0 .. w - 1 and y in the range 0 .. h - 1.*)
+
+	PROCEDURE Time(): INTEGER;
+(*returns the time elapsed since system startup in units of size 1 / TimeUnit seconds*)
+
+END Input.
+
+ + diff --git a/lib/obnc/obncdoc/Input0.def b/lib/obnc/obncdoc/Input0.def new file mode 100644 index 0000000..dce0f94 --- /dev/null +++ b/lib/obnc/obncdoc/Input0.def @@ -0,0 +1,17 @@ +DEFINITION Input0; +(*Access to keyboard and clock + +Implements a subset of basic module Input applicable to console applications. Import with Input := Input0 to emphasize the compatibility.*) + + VAR TimeUnit: INTEGER; (*clock ticks per second*) + + PROCEDURE Available(): INTEGER; +(*returns the number of characters in the keyboard buffer*) + + PROCEDURE Read(VAR ch: CHAR); +(*returns (and removes) the next character from the keyboard buffer. If the buffer is empty, Read waits until a key is pressed.*) + + PROCEDURE Time(): INTEGER; +(*returns the time elapsed since system startup in units of size 1 / TimeUnit seconds*) + +END Input0. diff --git a/lib/obnc/obncdoc/Input0.def.html b/lib/obnc/obncdoc/Input0.def.html new file mode 100644 index 0000000..a166b0c --- /dev/null +++ b/lib/obnc/obncdoc/Input0.def.html @@ -0,0 +1,32 @@ + + + + + + DEFINITION Input0 + + + +

Index

+ + 
+DEFINITION Input0;
+(*Access to keyboard and clock
+
+Implements a subset of basic module Input applicable to console applications. Import with Input := Input0 to emphasize the compatibility.*)
+
+	VAR TimeUnit: INTEGER; (*clock ticks per second*)
+
+	PROCEDURE Available(): INTEGER;
+(*returns the number of characters in the keyboard buffer*)
+
+	PROCEDURE Read(VAR ch: CHAR);
+(*returns (and removes) the next character from the keyboard buffer. If the buffer is empty, Read waits until a key is pressed.*)
+
+	PROCEDURE Time(): INTEGER;
+(*returns the time elapsed since system startup in units of size 1 / TimeUnit seconds*)
+
+END Input0.
+
+ + diff --git a/lib/obnc/obncdoc/Input0Test.def b/lib/obnc/obncdoc/Input0Test.def new file mode 100644 index 0000000..8c9d3d3 --- /dev/null +++ b/lib/obnc/obncdoc/Input0Test.def @@ -0,0 +1,2 @@ +DEFINITION Input0Test; +END Input0Test. diff --git a/lib/obnc/obncdoc/Input0Test.def.html b/lib/obnc/obncdoc/Input0Test.def.html new file mode 100644 index 0000000..21da197 --- /dev/null +++ b/lib/obnc/obncdoc/Input0Test.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION Input0Test + + + +

Index

+ + 
+DEFINITION Input0Test;
+END Input0Test.
+
+ + diff --git a/lib/obnc/obncdoc/InputTest.def b/lib/obnc/obncdoc/InputTest.def new file mode 100644 index 0000000..468decc --- /dev/null +++ b/lib/obnc/obncdoc/InputTest.def @@ -0,0 +1,2 @@ +DEFINITION InputTest; +END InputTest. diff --git a/lib/obnc/obncdoc/InputTest.def.html b/lib/obnc/obncdoc/InputTest.def.html new file mode 100644 index 0000000..a0faf13 --- /dev/null +++ b/lib/obnc/obncdoc/InputTest.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION InputTest + + + +

Index

+ + 
+DEFINITION InputTest;
+END InputTest.
+
+ + diff --git a/lib/obnc/obncdoc/Math.def b/lib/obnc/obncdoc/Math.def new file mode 100644 index 0000000..46f5063 --- /dev/null +++ b/lib/obnc/obncdoc/Math.def @@ -0,0 +1,67 @@ +DEFINITION Math; +(*General purpose mathematical functions + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*) + + CONST + pi = 3.14159265358979; + e = 2.71828182845905; + + PROCEDURE sqrt(x: REAL): REAL; +(*returns the square root of x, where x must be positive*) + + PROCEDURE power(base, exp: REAL): REAL; +(*returns base raised to exp*) + + PROCEDURE exp(x: REAL): REAL; +(*returns the constant e raised to x*) + + PROCEDURE ln(x: REAL): REAL; +(*returns the natural logarithm of x with base e*) + + PROCEDURE log(x, base: REAL): REAL; +(*log(x, b) returns the logarithm of x with base b*) + + PROCEDURE round(x: REAL): REAL; +(*returns x rounded to the nearest integer. If the fraction part of x is in range 0.0 to 0.5 then the result is the largest integer not greater than x, otherwise the result is x rounded up to the next highest whole number. Note that integer values cannot always be exactly represented in REAL format.*) + + PROCEDURE sin(x: REAL): REAL; +(*returns the sine of a radian value x*) + + PROCEDURE cos(x: REAL): REAL; +(*returns the cosine of a radian value x*) + + PROCEDURE tan(x: REAL): REAL; +(*returns the tangent of a radian value x*) + + PROCEDURE arcsin(x: REAL): REAL; +(*returns the inverse sine of x in radians, where -1 <= x <= 1*) + + PROCEDURE arccos(x: REAL): REAL; +(*returns the inverse cosine of x in radians, where -1 <= x <= 1*) + + PROCEDURE arctan(x: REAL): REAL; +(*returns the inverse tangent of x in radians, where -1 <= x <= 1*) + + PROCEDURE arctan2(y, x: REAL): REAL; +(*returns the inverse tangent in radians of y/x based on the signs of both values to determine the correct quadrant.*) + + PROCEDURE sinh(x: REAL): REAL; +(*returns the hyperbolic sine of x*) + + PROCEDURE cosh(x: REAL): REAL; +(*returns the hyperbolic cosine of x*) + + PROCEDURE tanh(x: REAL): REAL; +(*returns the hyperbolic tangent of x*) + + PROCEDURE arcsinh(x: REAL): REAL; +(*returns the inverse hyperbolic sine of x*) + + PROCEDURE arccosh(x: REAL): REAL; +(*returns the inverse hyperbolic cosine of x*) + + PROCEDURE arctanh(x: REAL): REAL; +(*returns the inverse hyperbolic tangent of x*) + +END Math. diff --git a/lib/obnc/obncdoc/Math.def.html b/lib/obnc/obncdoc/Math.def.html new file mode 100644 index 0000000..a3204d6 --- /dev/null +++ b/lib/obnc/obncdoc/Math.def.html @@ -0,0 +1,82 @@ + + + + + + DEFINITION Math + + + +

Index

+ + 
+DEFINITION Math;
+(*General purpose mathematical functions
+
+Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*)
+
+	CONST
+		pi = 3.14159265358979;
+		e = 2.71828182845905;
+
+	PROCEDURE sqrt(x: REAL): REAL;
+(*returns the square root of x, where x must be positive*)
+
+	PROCEDURE power(base, exp: REAL): REAL;
+(*returns base raised to exp*)
+
+	PROCEDURE exp(x: REAL): REAL;
+(*returns the constant e raised to x*)
+
+	PROCEDURE ln(x: REAL): REAL;
+(*returns the natural logarithm of x with base e*)
+
+	PROCEDURE log(x, base: REAL): REAL;
+(*log(x, b) returns the logarithm of x with base b*)
+
+	PROCEDURE round(x: REAL): REAL;
+(*returns x rounded to the nearest integer. If the fraction part of x is in range 0.0 to 0.5 then the result is the largest integer not greater than x, otherwise the result is x rounded up to the next highest whole number. Note that integer values cannot always be exactly represented in REAL format.*)
+
+	PROCEDURE sin(x: REAL): REAL;
+(*returns the sine of a radian value x*)
+
+	PROCEDURE cos(x: REAL): REAL;
+(*returns the cosine of a radian value x*)
+
+	PROCEDURE tan(x: REAL): REAL;
+(*returns the tangent of a radian value x*)
+
+	PROCEDURE arcsin(x: REAL): REAL;
+(*returns the inverse sine of x in radians, where -1 <= x <= 1*)
+
+	PROCEDURE arccos(x: REAL): REAL;
+(*returns the inverse cosine of x in radians, where -1 <= x <= 1*)
+
+	PROCEDURE arctan(x: REAL): REAL;
+(*returns the inverse tangent of x in radians, where -1 <= x <= 1*)
+
+	PROCEDURE arctan2(y, x: REAL): REAL;
+(*returns the inverse tangent in radians of y/x based on the signs of both values to determine the correct quadrant.*)
+
+	PROCEDURE sinh(x: REAL): REAL;
+(*returns the hyperbolic sine of x*)
+
+	PROCEDURE cosh(x: REAL): REAL;
+(*returns the hyperbolic cosine of x*)
+
+	PROCEDURE tanh(x: REAL): REAL;
+(*returns the hyperbolic tangent of x*)
+
+	PROCEDURE arcsinh(x: REAL): REAL;
+(*returns the inverse hyperbolic sine of x*)
+
+	PROCEDURE arccosh(x: REAL): REAL;
+(*returns the inverse hyperbolic cosine of x*)
+
+	PROCEDURE arctanh(x: REAL): REAL;
+(*returns the inverse hyperbolic tangent of x*)
+
+END Math.
+
+ + diff --git a/lib/obnc/obncdoc/MathTest.def b/lib/obnc/obncdoc/MathTest.def new file mode 100644 index 0000000..5d5b233 --- /dev/null +++ b/lib/obnc/obncdoc/MathTest.def @@ -0,0 +1,2 @@ +DEFINITION MathTest; +END MathTest. diff --git a/lib/obnc/obncdoc/MathTest.def.html b/lib/obnc/obncdoc/MathTest.def.html new file mode 100644 index 0000000..c851fe5 --- /dev/null +++ b/lib/obnc/obncdoc/MathTest.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION MathTest + + + +

Index

+ + 
+DEFINITION MathTest;
+END MathTest.
+
+ + diff --git a/lib/obnc/obncdoc/Out.def b/lib/obnc/obncdoc/Out.def new file mode 100644 index 0000000..9f285e8 --- /dev/null +++ b/lib/obnc/obncdoc/Out.def @@ -0,0 +1,27 @@ +DEFINITION Out; +(*Output to the standard output stream + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*) + + PROCEDURE Open; +(*does nothing (included for compatibility with "The Oakwood Guidelines")*) + + PROCEDURE Char(ch: CHAR); +(*writes the character ch to the end of the output stream*) + + PROCEDURE String(s: ARRAY OF CHAR); +(*writes the null-terminated character sequence s to the end of the output stream (without 0X).*) + + PROCEDURE Int(i, n: INTEGER); +(*writes the integer i to the end of the output stream. If the textual representation of i requires m characters, i is right adjusted in a field of Max(n, m) characters padded with blanks at the left end. A plus sign is not written.*) + + PROCEDURE Hex(i: INTEGER); +(*writes the integer i to the end of the output stream as a zero-padded unsigned hexadecimal number with a leading space. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + + PROCEDURE Real(x: REAL; n: INTEGER); +(*writes the real number x to the end of the output stream using an exponential form. If the textual representation of x requires m characters (including a two-digit signed exponent), x is right adjusted in a field of Max(n, m) characters padded with blanks at the left end. A plus sign of the mantissa is not written.*) + + PROCEDURE Ln; +(*writes an end-of-line symbol to the end of the output stream*) + +END Out. diff --git a/lib/obnc/obncdoc/Out.def.html b/lib/obnc/obncdoc/Out.def.html new file mode 100644 index 0000000..d79d5ed --- /dev/null +++ b/lib/obnc/obncdoc/Out.def.html @@ -0,0 +1,42 @@ + + + + + + DEFINITION Out + + + +

Index

+ + 
+DEFINITION Out;
+(*Output to the standard output stream
+
+Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers".*)
+
+	PROCEDURE Open;
+(*does nothing (included for compatibility with "The Oakwood Guidelines")*)
+
+	PROCEDURE Char(ch: CHAR);
+(*writes the character ch to the end of the output stream*)
+
+	PROCEDURE String(s: ARRAY OF CHAR);
+(*writes the null-terminated character sequence s to the end of the output stream (without 0X).*)
+
+	PROCEDURE Int(i, n: INTEGER);
+(*writes the integer i to the end of the output stream. If the textual representation of i requires m characters, i is right adjusted in a field of Max(n, m) characters padded with blanks at the left end. A plus sign is not written.*)
+
+	PROCEDURE Hex(i: INTEGER);
+(*writes the integer i to the end of the output stream as a zero-padded unsigned hexadecimal number with a leading space. NOTE: This procedure is an extension to The Oakwood Guidelines.*)
+
+	PROCEDURE Real(x: REAL; n: INTEGER);
+(*writes the real number x to the end of the output stream using an exponential form. If the textual representation of x requires m characters (including a two-digit signed exponent), x is right adjusted in a field of Max(n, m) characters padded with blanks at the left end. A plus sign of the mantissa is not written.*)
+
+	PROCEDURE Ln;
+(*writes an end-of-line symbol to the end of the output stream*)
+
+END Out.
+
+ + diff --git a/lib/obnc/obncdoc/OutTest.def b/lib/obnc/obncdoc/OutTest.def new file mode 100644 index 0000000..6a0d6de --- /dev/null +++ b/lib/obnc/obncdoc/OutTest.def @@ -0,0 +1,2 @@ +DEFINITION OutTest; +END OutTest. diff --git a/lib/obnc/obncdoc/OutTest.def.html b/lib/obnc/obncdoc/OutTest.def.html new file mode 100644 index 0000000..79e3110 --- /dev/null +++ b/lib/obnc/obncdoc/OutTest.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION OutTest + + + +

Index

+ + 
+DEFINITION OutTest;
+END OutTest.
+
+ + diff --git a/lib/obnc/obncdoc/Strings.def b/lib/obnc/obncdoc/Strings.def new file mode 100644 index 0000000..54704a6 --- /dev/null +++ b/lib/obnc/obncdoc/Strings.def @@ -0,0 +1,30 @@ +DEFINITION Strings; +(*Operations on strings + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". All character arrays are assumed to contain 0X as a terminator and positions start at 0.*) + + PROCEDURE Length(s: ARRAY OF CHAR): INTEGER; +(*Length(s) returns the number of characters in s up to and excluding the first 0X.*) + + PROCEDURE Insert(source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR); +(*Insert(src, pos, dst) inserts the string src into the string dst at position pos (0 <= pos <= Length(dst)). If pos = Length(dst), src is appended to dst. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X.*) + + PROCEDURE Append(extra: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR); +(*Append(s, dst) has the same effect as Insert(s, Length(dst), dst).*) + + PROCEDURE Delete(VAR s: ARRAY OF CHAR; pos, n: INTEGER); +(*Delete(s, pos, n) deletes n characters from s starting at position pos (0 <= pos <= Length(s)). If n > Length(s) - pos, the new length of s is pos.*) + + PROCEDURE Replace(source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR); +(*Replace(src, pos, dst) has the same effect as Delete(dst, pos, Length(src)) followed by an Insert(src, pos, dst).*) + + PROCEDURE Extract(source: ARRAY OF CHAR; pos, n: INTEGER; VAR dest: ARRAY OF CHAR); +(*Extract(src, pos, n, dst) extracts a substring dst with n characters from position pos (0 <= pos <= Length(src)) in src. If n > Length(src) - pos, dst is only the part of src from pos to the end of src, i.e. Length(src) - 1. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X.*) + + PROCEDURE Pos(pattern, s: ARRAY OF CHAR; pos: INTEGER): INTEGER; +(*Pos(pat, s, pos) returns the position of the first occurrence of pat in s. Searching starts at position pos (0 <= pos <= Length(s)). If pat is not found, -1 is returned.*) + + PROCEDURE Cap(VAR s: ARRAY OF CHAR); +(*Cap(s) replaces each lower case letter within s by its upper case equivalent.*) + +END Strings. diff --git a/lib/obnc/obncdoc/Strings.def.html b/lib/obnc/obncdoc/Strings.def.html new file mode 100644 index 0000000..2218370 --- /dev/null +++ b/lib/obnc/obncdoc/Strings.def.html @@ -0,0 +1,45 @@ + + + + + + DEFINITION Strings + + + +

Index

+ + 
+DEFINITION Strings;
+(*Operations on strings
+
+Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". All character arrays are assumed to contain 0X as a terminator and positions start at 0.*)
+
+	PROCEDURE Length(s: ARRAY OF CHAR): INTEGER;
+(*Length(s) returns the number of characters in s up to and excluding the first 0X.*)
+
+	PROCEDURE Insert(source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR);
+(*Insert(src, pos, dst) inserts the string src into the string dst at position pos (0 <= pos <= Length(dst)). If pos = Length(dst), src is appended to dst. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X.*)
+
+	PROCEDURE Append(extra: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
+(*Append(s, dst) has the same effect as Insert(s, Length(dst), dst).*)
+
+	PROCEDURE Delete(VAR s: ARRAY OF CHAR; pos, n: INTEGER);
+(*Delete(s, pos, n) deletes n characters from s starting at position pos (0 <= pos <= Length(s)). If n > Length(s) - pos, the new length of s is pos.*)
+
+	PROCEDURE Replace(source: ARRAY OF CHAR; pos: INTEGER; VAR dest: ARRAY OF CHAR);
+(*Replace(src, pos, dst) has the same effect as Delete(dst, pos, Length(src)) followed by an Insert(src, pos, dst).*)
+
+	PROCEDURE Extract(source: ARRAY OF CHAR; pos, n: INTEGER; VAR dest: ARRAY OF CHAR);
+(*Extract(src, pos, n, dst) extracts a substring dst with n characters from position pos (0 <= pos <= Length(src)) in src. If n > Length(src) - pos, dst is only the part of src from pos to the end of src, i.e. Length(src) - 1. If the size of dst is not large enough to hold the result of the operation, the result is truncated so that dst is always terminated with a 0X.*)
+
+	PROCEDURE Pos(pattern, s: ARRAY OF CHAR; pos: INTEGER): INTEGER;
+(*Pos(pat, s, pos) returns the position of the first occurrence of pat in s. Searching starts at position pos (0 <= pos <= Length(s)). If pat is not found, -1 is returned.*)
+
+	PROCEDURE Cap(VAR s: ARRAY OF CHAR);
+(*Cap(s) replaces each lower case letter within s by its upper case equivalent.*)
+
+END Strings.
+
+ + diff --git a/lib/obnc/obncdoc/StringsTest.def b/lib/obnc/obncdoc/StringsTest.def new file mode 100644 index 0000000..0743ec9 --- /dev/null +++ b/lib/obnc/obncdoc/StringsTest.def @@ -0,0 +1,2 @@ +DEFINITION StringsTest; +END StringsTest. diff --git a/lib/obnc/obncdoc/StringsTest.def.html b/lib/obnc/obncdoc/StringsTest.def.html new file mode 100644 index 0000000..572bd98 --- /dev/null +++ b/lib/obnc/obncdoc/StringsTest.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION StringsTest + + + +

Index

+ + 
+DEFINITION StringsTest;
+END StringsTest.
+
+ + diff --git a/lib/obnc/obncdoc/XYplane.def b/lib/obnc/obncdoc/XYplane.def new file mode 100644 index 0000000..87ce72b --- /dev/null +++ b/lib/obnc/obncdoc/XYplane.def @@ -0,0 +1,62 @@ +DEFINITION XYplane; +(*Basic facilities for graphics programming + +Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". The drawing plane is repainted when Key is invoked. Fullscreen mode is toggled with Ctrl-f; it can also be exited with Esc.*) + + CONST + (*drawing modes*) + draw = 1; + erase = 0; + + VAR + X, Y: INTEGER; (*X = 0 and Y = 0. Included for compatibility with The Oakwood Guidelines.*) + W, H: INTEGER; (*width and height of the drawing plane in pixels*) + + PROCEDURE Open; +(*initializes the drawing plane*) + + PROCEDURE Clear; +(*erases all pixels in the drawing plane*) + + PROCEDURE Dot(x, y, mode: INTEGER); +(*Dot(x, y, m) draws or erases the pixel at the coordinates (x, y) relative to the lower left corner of the plane. If m = draw the pixel is drawn, if m = erase the pixel is erased.*) + + PROCEDURE IsDot(x, y: INTEGER): BOOLEAN; +(*returns TRUE if the pixel at the coordinates (x, y) relative to the lower left corner of the screen is drawn, otherwise it returns FALSE*) + + PROCEDURE Key(): CHAR; +(*reads the keyboard. If a key was pressed prior to invocation, its character value is returned, otherwise the result is 0X.*) + + PROCEDURE SetSize(width, height: INTEGER); +(*sets the width and height of the drawing plane. The setting takes effect when Open is called. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + + PROCEDURE UseColor(color: INTEGER); +(*sets the red, green and blue components of the drawing color as a three-byte value. NOTE: This procedure is an extension to The Oakwood Guidelines.*) + + PROCEDURE Color(x, y: INTEGER): INTEGER; +(*returns the color of the pixel at the coordinates (x, y). NOTE: This procedure is an extension to The Oakwood Guidelines.*) + +(*Example: + +MODULE drawpixels; + + (*click or drag the mouse to draw pixels*) + + IMPORT Input, XYplane; + + VAR + x, y: INTEGER; + keys: SET; + +BEGIN + XYplane.Open; + REPEAT + Input.Mouse(keys, x, y); + IF 2 IN keys THEN + XYplane.Dot(x, y, XYplane.draw) + END + UNTIL XYplane.Key() = "q" +END drawpixels. +*) + +END XYplane. diff --git a/lib/obnc/obncdoc/XYplane.def.html b/lib/obnc/obncdoc/XYplane.def.html new file mode 100644 index 0000000..01fb1f1 --- /dev/null +++ b/lib/obnc/obncdoc/XYplane.def.html @@ -0,0 +1,77 @@ + + + + + + DEFINITION XYplane + + + +

Index

+ + 
+DEFINITION XYplane;
+(*Basic facilities for graphics programming
+
+Implements the basic library module from "The Oakwood Guidelines for Oberon-2 Compiler Developers". The drawing plane is repainted when Key is invoked. Fullscreen mode is toggled with Ctrl-f; it can also be exited with Esc.*)
+
+	CONST
+		(*drawing modes*)
+		draw = 1;
+		erase = 0;
+
+	VAR
+		X, Y: INTEGER; (*X = 0 and Y = 0. Included for compatibility with The Oakwood Guidelines.*)
+		W, H: INTEGER; (*width and height of the drawing plane in pixels*)
+
+	PROCEDURE Open;
+(*initializes the drawing plane*)
+
+	PROCEDURE Clear;
+(*erases all pixels in the drawing plane*)
+
+	PROCEDURE Dot(x, y, mode: INTEGER);
+(*Dot(x, y, m) draws or erases the pixel at the coordinates (x, y) relative to the lower left corner of the plane. If m = draw the pixel is drawn, if m = erase the pixel is erased.*)
+
+	PROCEDURE IsDot(x, y: INTEGER): BOOLEAN;
+(*returns TRUE if the pixel at the coordinates (x, y) relative to the lower left corner of the screen is drawn, otherwise it returns FALSE*)
+
+	PROCEDURE Key(): CHAR;
+(*reads the keyboard. If a key was pressed prior to invocation, its character value is returned, otherwise the result is 0X.*)
+
+	PROCEDURE SetSize(width, height: INTEGER);
+(*sets the width and height of the drawing plane. The setting takes effect when Open is called. NOTE: This procedure is an extension to The Oakwood Guidelines.*)
+
+	PROCEDURE UseColor(color: INTEGER);
+(*sets the red, green and blue components of the drawing color as a three-byte value. NOTE: This procedure is an extension to The Oakwood Guidelines.*)
+
+	PROCEDURE Color(x, y: INTEGER): INTEGER;
+(*returns the color of the pixel at the coordinates (x, y). NOTE: This procedure is an extension to The Oakwood Guidelines.*)
+
+(*Example:
+
+MODULE drawpixels;
+
+	(*click or drag the mouse to draw pixels*)
+
+	IMPORT Input, XYplane;
+
+	VAR
+		x, y: INTEGER;
+		keys: SET;
+
+BEGIN
+	XYplane.Open;
+	REPEAT
+		Input.Mouse(keys, x, y);
+		IF 2 IN keys THEN
+			XYplane.Dot(x, y, XYplane.draw)
+		END
+	UNTIL XYplane.Key() = "q"
+END drawpixels.
+*)
+
+END XYplane.
+
+ + diff --git a/lib/obnc/obncdoc/XYplaneTest.def b/lib/obnc/obncdoc/XYplaneTest.def new file mode 100644 index 0000000..00fb0be --- /dev/null +++ b/lib/obnc/obncdoc/XYplaneTest.def @@ -0,0 +1,2 @@ +DEFINITION XYplaneTest; +END XYplaneTest. diff --git a/lib/obnc/obncdoc/XYplaneTest.def.html b/lib/obnc/obncdoc/XYplaneTest.def.html new file mode 100644 index 0000000..f1436ce --- /dev/null +++ b/lib/obnc/obncdoc/XYplaneTest.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION XYplaneTest + + + +

Index

+ + 
+DEFINITION XYplaneTest;
+END XYplaneTest.
+
+ + diff --git a/lib/obnc/obncdoc/index.html b/lib/obnc/obncdoc/index.html new file mode 100644 index 0000000..a655dde --- /dev/null +++ b/lib/obnc/obncdoc/index.html @@ -0,0 +1,23 @@ + + + + + + Index of obnc + + + +

Index

+ + 
+DEFINITION Files
+DEFINITION In
+DEFINITION Input
+DEFINITION Input0
+DEFINITION Math
+DEFINITION Out
+DEFINITION Strings
+DEFINITION XYplane
+
+ + diff --git a/lib/obnc/obncdoc/style.css b/lib/obnc/obncdoc/style.css new file mode 100644 index 0000000..ef1ab9c --- /dev/null +++ b/lib/obnc/obncdoc/style.css @@ -0,0 +1,35 @@ +body { + font-family: sans-serif; + margin: 1em; +} + +pre { + font-family: inherit; + font-size: inherit; + + -moz-tab-size: 4; + -o-tab-size: 4; + tab-size: 4; +} + +pre em { + font-style: normal; + font-weight: bold; +} + +pre .comment { + color: #800000; + display: inline-block; + max-width: 42em; + vertical-align: text-top; + + white-space: pre-wrap; + white-space: -moz-pre-wrap; + white-space: -pre-wrap; + white-space: -o-pre-wrap; + word-wrap: break-word; +} + +pre .string { + color: #767676; +} diff --git a/share/doc/obnc/oberon-report.html b/share/doc/obnc/oberon-report.html new file mode 100644 index 0000000..1afed7f --- /dev/null +++ b/share/doc/obnc/oberon-report.html @@ -0,0 +1,1671 @@ + + + + + + + The Programming Language Oberon + + + + +
+

The Programming Language Oberon

+ +

Revision 1.10.2013 / 3.5.2016

+ +

+ Niklaus Wirth
+ (HTML translation from PDF by Karl Landström) +

+ +
+

Make it as simple as possible, but not simpler. (A. Einstein)

+
+
+ +

Table of Contents

+ +
    +
  1. History and introduction
    2. +
  2. Syntax
    3. +
  3. Vocabulary
    4. +
  4. Declarations and scope rules
    5. +
  5. Constant declarations
    6. +
  6. Type declarations
    7. +
  7. Variable declarations
    8. +
  8. Expressions
    9. +
  9. Statements
    10. +
  10. Procedure declarations
    11. +
  11. Modules
    12. +
+ +

Appendix: The Syntax of Oberon

+ +

1. Introduction

+ +

Oberon is a general-purpose programming language that evolved from Modula-2. Its principal new feature is the concept of type extension. It permits the construction of new data types on the basis of existing ones and to relate them.

+ +

This report is not intended as a programmer's tutorial. It is intentionally kept concise. Its function is to serve as a reference for programmers, implementors, and manual writers. What remains unsaid is mostly left so intentionally, either because it is derivable from stated rules of the language, or because it would unnecessarily restrict the freedom of implementors.

+ +

This document describes the language defined in 1988/90 as revised in 2007 / 2016.

+ +

2. Syntax

+ +

A language is an infinite set of sentences, namely the sentences well formed according to its syntax. In Oberon, these sentences are called compilation units. Each unit is a finite sequence of symbols from a finite vocabulary. The vocabulary of Oberon consists of identifiers, numbers, strings, operators, delimiters, and comments. They are called lexical symbols and are composed of sequences of characters. (Note the distinction between symbols and characters.)

+ +

To describe the syntax, an extended Backus-Naur Formalism called EBNF is used. Brackets [ and ] denote optionality of the enclosed sentential form, and braces { and } denote its repetition (possibly 0 times). Syntactic entities (non-terminal symbols) are denoted by English words expressing their intuitive meaning. Symbols of the language vocabulary (terminal symbols) are denoted by strings enclosed in quote marks or by words in capital letters.

+ +

3. Vocabulary

+ +

The following lexical rules must be observed when composing symbols. Blanks and line breaks must not occur within symbols (except in comments, and blanks in strings). They are ignored unless they are essential to separate two consecutive symbols. Capital and lower-case letters are considered as being distinct.

+ +

Identifiers are sequences of letters and digits. The first character must be a letter.

+ + 
+ident = letter {letter | digit}.
+
+ +

Examples:

+ + 
+x    scan    Oberon    GetSymbol    firstLetter
+
+ +

Numbers are (unsigned) integers or real numbers. Integers are sequences of digits and may be followed by a suffix letter. If no suffix is specified, the representation is decimal. The suffix H indicates hexadecimal representation.

+ +

A real number always contains a decimal point. Optionally it may also contain a decimal scale factor. The letter E is pronounced as “times ten to the power of”.

+ + 
+number = integer | real.
+integer = digit {digit} | digit {hexDigit} "H".
+real = digit {digit} "." {digit} [ScaleFactor].
+ScaleFactor = "E" ["+" | "-"] digit {digit}.
+hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".
+digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".
+
+ +

Examples:

+ +
+ + + + + + + + + + + + + + + + + +
1987
100H= 256
12.3
4.567E8= 456700000
+
+ +

Strings are sequences of characters enclosed in quote marks ("). A string cannot contain the delimiting quote mark. Alternatively, a single-character string may be specified by the ordinal number of the character in hexadecimal notation followed by an "X". The number of characters in a string is called the length of the string.

+ + 
+string = """ {character} """ | digit {hexdigit} "X" .
+
+ +

Examples:

+ + 
+"OBERON"    "Don't worry!"    22X
+
+ +

Operators and delimiters are the special characters, character pairs, or reserved words listed below. These reserved words consist exclusively of capital letters and cannot be used in the role of identifiers.

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+:=ARRAYIMPORTTHEN
-^BEGININTO
*=BYISTRUE
/#CASEMODTYPE
~<CONSTMODULEUNTIL
&>DIVNILVAR
.<=DOOFWHILE
,>=ELSEOR
;..ELSIFPOINTER
|:ENDPROCEDURE
()FALSERECORD
[]FORREPEAT
{}IFRETURN
+
+ +

Comments may be inserted between any two symbols in a program. They are arbitrary character sequences opened by the bracket (* and closed by *). Comments do not affect the meaning of a program. They may be nested.

+ +

4. Declarations and scope rules

+ +

Every identifier occurring in a program must be introduced by a declaration, unless it is a predefined identifier. Declarations also serve to specify certain permanent properties of an object, such as whether it is a constant, a type, a variable, or a procedure.

+ +

The identifier is then used to refer to the associated object. This is possible in those parts of a program only which are within the scope of the declaration. No identifier may denote more than one object within a given scope. The scope extends textually from the point of the declaration to the end of the block (procedure or module) to which the declaration belongs and hence to which the object is local.

+ +

In its declaration, an identifier in the module's scope may be followed by an export mark (*) to indicate that it be exported from its declaring module. In this case, the identifier may be used in other modules, if they import the declaring module. The identifier is then prefixed by the identifier designating its module (see Ch. 11). The prefix and the identifier are separated by a period and together are called a qualified identifier.

+ + 
+qualident = [ident "."] ident.
+identdef = ident ["*"].
+
+ +

The following identifiers are predefined; their meaning is defined in section 6.1 (types) or 10.2 (procedures):

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
ABSASRASSERTBOOLEANBYTE
CHARCHRDECEXCLFLOOR
FLTINCINCLINTEGERLEN
LSLNEWODDORDPACK
REALRORSETUNPK
+
+ +

5. Constant declarations

+ +

A constant declaration associates an identifier with a constant value.

+ + 
+ConstDeclaration = identdef "=" ConstExpression.
+ConstExpression = expression.
+
+ +

A constant expression can be evaluated by a mere textual scan without actually executing the program. Its operands are constants (see Ch. 8). Examples of constant declarations are:

+ + 
+N = 100
+
+ + 
+limit = 2*N - 1
+
+ + 
+all = {0 .. WordSize - 1}
+
+ + 
+name = "Oberon"
+
+ +

6. Type declarations

+ +

A data type determines the set of values which variables of that type may assume, and the operators that are applicable. A type declaration is used to associate an identifier with a type. The types define the structure of variables of this type and, by implication, the operators that are applicable to components. There are two different data structures, namely arrays and records, with different component selectors.

+ + 
+TypeDeclaration = identdef "=" type.
+type = qualident | ArrayType | RecordType | PointerType | ProcedureType.
+
+ +

Examples:

+ + 
+Table = ARRAY N OF REAL
+
+ + 
+Tree = POINTER TO Node
+
+ + 
+Node = RECORD key: INTEGER;
+	left, right: Tree
+END
+
+ + 
+CenterNode = RECORD (Node)
+	name: ARRAY 32 OF CHAR;
+	subnode: Tree
+END
+
+ + 
+Function = PROCEDURE (x: INTEGER): INTEGER
+
+ +

6.1. Basic types

+ +

The following basic types are denoted by predeclared identifiers. The associated operators are defined in 8.2, and the predeclared function procedures in 10.2. The values of a given basic type are the following:

+ +
+
+
BOOLEAN
+
the truth values TRUE and FALSE
+ +
CHAR
+
the characters of a standard character set
+ +
INTEGER
+
the integers
+ +
REAL
+
real numbers
+ +
BYTE
+
the integers between 0 and 255
+ +
SET
+
the sets of integers between 0 and an implementation-dependent limit
+
+
+ +

The type BYTE is compatible with the type INTEGER, and vice-versa.

+ +

6.2. Array types

+ +

An array is a structure consisting of a fixed number of elements which are all of the same type, called the element type. The number of elements of an array is called its length. The elements of the array are designated by indices, which are integers between 0 and the length minus 1.

+ + 
+ArrayType = ARRAY length {"," length} OF type.
+length = ConstExpression.
+
+ +

A declaration of the form

+ + 
+ARRAY N0, N1, ... , Nk OF T
+
+ +

is understood as an abbreviation of the declaration

+ + 
+ARRAY N0 OF
+	ARRAY N1 OF
+		...
+			ARRAY Nk OF T
+
+ +

Examples of array types:

+ + 
+ARRAY N OF INTEGER
+
+ + 
+ARRAY 10, 20 OF REAL
+
+ +

6.3. Record types

+ +

A record type is a structure consisting of a fixed number of elements of possibly different types. The record type declaration specifies for each element, called field, its type and an identifier which denotes the field. The scope of these field identifiers is the record definition itself, but they are also visible within field designators (see 8.1) referring to elements of record variables.

+ + 
+RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.
+BaseType = qualident.
+FieldListSequence = FieldList {";" FieldList}.
+FieldList = IdentList ":" type.
+IdentList = identdef {"," identdef}.
+
+ +

If a record type is exported, field identifiers that are to be visible outside the declaring module must be marked. They are called public fields; unmarked fields are called private fields.

+ +

Record types are extensible, i.e. a record type can be defined as an extension of another record type. In the examples above, CenterNode (directly) extends Node, which is the (direct) base type of CenterNode. More specifically, CenterNode extends Node with the fields name and subnode.

+ +

Definition: A type T extends a type T0, if it equals T0, or if it directly extends an extension of T0. Conversely, a type T0 is a base type of T, if it equals T, or if it is the direct base type of a base type of T.

+ +

Examples of record types:

+ + 
+RECORD day, month, year: INTEGER
+END
+
+ + 
+RECORD
+	name, firstname: ARRAY 32 OF CHAR;
+	age: INTEGER;
+	salary: REAL
+END
+
+ +

6.4. Pointer types

+ +

Variables of a pointer type P assume as values pointers to variables of some type T. It must be a record type. The pointer type P is said to be bound to T, and T is the pointer base type of P. Pointer types inherit the extension relation of their base types, if there is any. If a type T is an extension of T0 and P is a pointer type bound to T, then P is also an extension of P0, the pointer type bound to T0.

+ + 
+PointerType = POINTER TO type.
+
+ +

If a type P is defined as POINTER TO T, the identifier T can be declared textually following the declaration of P, but [if so] it must lie within the same scope.

+ +

If p is a variable of type P = POINTER TO T, then a call of the predefined procedure NEW(p) has the following effect (see 10.2): A variable of type T is allocated in free storage, and a pointer to it is assigned to p. This pointer p is of type P and the referenced variable p^ is of type T. Failure of allocation results in p obtaining the value NIL. Any pointer variable may be assigned the value NIL, which points to no variable at all.

+ +

6.5. Procedure types

+ +

Variables of a procedure type T have a procedure (or NIL) as value. If a procedure P is assigned to a procedure variable of type T, the (types of the) formal parameters of P must be the same as those indicated in the formal parameters of T. The same holds for the result type in the case of a function procedure (see 10.1). P must not be declared local to another procedure, and neither can it be a standard procedure.

+ + 
+ProcedureType = PROCEDURE [FormalParameters].
+
+ +

7. Variable declarations

+ +

Variable declarations serve to introduce variables and associate them with identifiers that must be unique within the given scope. They also serve to associate fixed data types with the variables.

+ + 
+VariableDeclaration = IdentList ":" type.
+
+ +

Variables whose identifiers appear in the same list are all of the same type. Examples of variable declarations (refer to examples in Ch. 6):

+ + 
+i, j, k: INTEGER
+
+ + 
+x, y: REAL
+
+ + 
+p, q: BOOLEAN
+
+ 
+s: SET
+
+ + 
+f: Function
+
+ + 
+a: ARRAY 100 OF REAL
+
+ + 
+w: ARRAY 16 OF
+	RECORD ch: CHAR;
+		count: INTEGER
+	END
+
+ + 
+t: Tree
+
+ +

8. Expressions

+ +

Expressions are constructs denoting rules of computation whereby constants and current values of variables are combined to derive other values by the application of operators and function procedures. Expressions consist of operands and operators. Parentheses may be used to express specific associations of operators and operands.

+ +

8.1. Operands

+ +

With the exception of sets and literal constants, i.e. numbers and strings, operands are denoted by designators. A designator consists of an identifier referring to the constant, variable, or procedure to be designated. This identifier may possibly be qualified by module identifiers (see Ch. 4 and 11), and it may be followed by selectors, if the designated object is an element of a structure.

+ +

If A designates an array, then A[E] denotes that element of A whose index is the current value of the expression E. The type of E must be of type INTEGER. A designator of the form A[E1, E2, ... , En] stands for A[E1][E2] ... [En]. If p designates a pointer variable, p^ denotes the variable which is referenced by p. If r designates a record, then r.f denotes the field f of r. If p designates a pointer, p.f denotes the field f of the record p^, i.e. the dot implies dereferencing and p.f stands for p^.f.

+ +

The typeguard v(T0) asserts that v is of type T0 , i.e. it aborts program execution, if it is not of type T0 . The guard is applicable, if

+ +
    +
  1. T0 is an extension of the declared type T of v, and if
    2. +
  2. v is a variable parameter of record type, or v is a pointer.
    3. +
+ + 
+designator = qualident {selector}.
+selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".
+ExpList = expression {"," expression}.
+
+ +

If the designated object is a variable, then the designator refers to the variable's current value. If the object is a procedure, a designator without parameter list refers to that procedure. If it is followed by a (possibly empty) parameter list, the designator implies an activation of the procedure and stands for the value resulting from its execution. The (types of the) actual parameters must correspond to the formal parameters as specified in the procedure's declaration (see Ch. 10).

+ +

Examples of designators (see examples in Ch. 7):

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + +
i(INTEGER)
a[i](REAL)
w[3].ch(CHAR)
t.key(INTEGER)
t.left.right(Tree)
t(CenterNode).subnode(Tree)
+
+ +

8.2. Operators

+ +

The syntax of expressions distinguishes between four classes of operators with different precedences (binding strengths). The operator ~ has the highest precedence, followed by multiplication operators, addition operators, and relations. Operators of the same precedence associate from left to right. For example, x − y − z stands for (x − y) − z.

+ 
+expression = SimpleExpression [relation SimpleExpression].
+relation = "=" | "#" | "<" | "<=" | ">" | ">=" | IN | IS.
+SimpleExpression = ["+"|"-"] term {AddOperator term}.
+AddOperator = "+" | "-" | OR.
+term = factor {MulOperator factor}.
+MulOperator = "*" | "/" | DIV | MOD | "&" .
+factor = number | string | NIL | TRUE | FALSE |
+	set | designator [ActualParameters] | "(" expression ")" | "~" factor.
+set = "{" [element {"," element}] "}".
+element = expression [".." expression].
+ActualParameters = "(" [ExpList] ")" .
+
+ +

The set {m .. n} denotes {m, m+1, … , n-1, n}, and if m > n, the empty set. The available operators are listed in the following tables. In some instances, several different operations are designated by the same operator symbol. In these cases, the actual operation is identified by the type of the operands.

+ +

8.2.1. Logical operators

+ +
+ + + + + + + + + + + + + + + + + +
symbolresult
ORlogical disjunction
&logical conjunction
~negation
+
+ +

These operators apply to BOOLEAN operands and yield a BOOLEAN result.

+ +
+ + + + + + + + + + + + + + + + +
p OR qstands for“if p then TRUE, else q”
p & qstands for“if p then q, else FALSE”
~ pstands for“not p”
+
+ +

8.2.2. Arithmetic operators

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
symbolresult
+sum
−difference
*product
/quotient
DIVinteger quotient
MODmodulus
+
+ +

The operators +, −, *, and / apply to operands of numeric types. Both operands must be of the same type, which is also the type of the result. When used as unary operators, − denotes sign inversion and + denotes the identity operation.

+ +

The operators DIV and MOD apply to integer operands only. Let q = x DIV y, and r = x MOD y. Then quotient q and remainder r are defined by the equation

+ + 
+x = q*y + r       0 <= r < y
+
+ +

8.2.3. Set operators

+ +
+ + + + + + + + + + + + + + + + + + + + + +
symbolresult
+union
−difference
*intersection
/ symmetric set difference
+
+ +

When used with a single operand of type SET, the minus sign denotes the set complement.

+ +

8.2.4. Relations

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
symbolrelation
=equal
#unequal
<less
<=less or equal
>greater
>=greater or equal
INset membership
IStype test
+
+ +

Relations are Boolean. The ordering relations <, <=, >, >= apply to the numeric types, CHAR, and character arrays. The relations = and # also apply to the types BOOLEAN, SET, and to pointer and procedure types.

+ +

x IN s stands for “x is an element of s”. x must be of type INTEGER, and s of type SET.

+ +

v IS T stands for “v is of type T” and is called a type test. It is applicable, if

+ +
    +
  1. T is an extension of the declared type T0 of v, and if
    2. +
  2. v is a variable parameter of record type or v is a pointer.
    3. +
+ +

Assuming, for instance, that T is an extension of T0 and that v is a designator declared of type T0, then the test v IS T determines whether the actually designated variable is (not only a T0, but also) a T. The value of NIL IS T is undefined.

+ +

Examples of expressions (refer to examples in Ch. 7):

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
1987(INTEGER)
i DIV 3(INTEGER)
~p OR q(BOOLEAN)
(i+j) * (i-j)(INTEGER)
s - {8, 9, 13}(SET)
a[i+j] * a[i-j](REAL)
(0<=i) & (i<100)(BOOLEAN)
t.key = 0(BOOLEAN)
k IN {i .. j-1}(BOOLEAN)
t IS CenterNode(BOOLEAN)
+
+ +

9. Statements

+ +

Statements denote actions. There are elementary and structured statements. Elementary statements are not composed of any parts that are themselves statements. They are the assignment and the procedure call. Structured statements are composed of parts that are themselves statements. They are used to express sequencing and conditional, selective, and repetitive execution. A statement may also be empty, in which case it denotes no action. The empty statement is included in order to relax punctuation rules in statement sequences.

+ + 
+statement = [assignment | ProcedureCall | IfStatement | CaseStatement |
+	WhileStatement | RepeatStatement | ForStatement].
+
+ +

9.1. Assignments

+ +

The assignment serves to replace the current value of a variable by a new value specified by an expression. The assignment operator is written as “:=” and pronounced as becomes.

+ + 
+assignment = designator ":=" expression.
+
+ +

If a value parameter is structured (of array or record type), no assignment to it or to its elements are permitted. Neither may assignments be made to imported variables.

+ +

The type of the expression must be the same as that of the designator. The following exceptions hold:

+ +
    +
  1. The constant NIL can be assigned to variables of any pointer or procedure type.
    2. +
  2. Strings can be assigned to any array of characters, provided the number of characters in the string is less than that of the array. (A null character is appended). Single-character strings can also be assigned to variables of type CHAR.
    3. +
  3. In the case of records, the type of the source must be an extension of the type of the destination.
    4. +
  4. An open array may be assigned to an array of equal base type.
    5. +
+ +

Examples of assignments (see examples in Ch. 7):

+ + 
+i := 0
+
+ + 
+p := i = j
+
+ + 
+x := FLT(i + 1)
+
+ + 
+k := (i + j) DIV 2
+
+ + 
+f := log2
+
+ + 
+s := {2, 3, 5, 7, 11, 13}
+
+ + 
+a[i] := (x+y) * (x-y)
+
+ + 
+t.key := i
+
+ + 
+w[i+1].ch := "A"
+
+ +

9.2. Procedure calls

+ +

A procedure call serves to activate a procedure. The procedure call may contain a list of actual parameters which are substituted in place of their corresponding formal parameters defined in the procedure declaration (see Ch. 10). The correspondence is established by the positions of the parameters in the lists of actual and formal parameters respectively. There exist two kinds of parameters: variable and value parameters.

+ +

In the case of variable parameters, the actual parameter must be a designator denoting a variable. If it designates an element of a structured variable, the selector is evaluated when the formal/actual parameter substitution takes place, i.e. before the execution of the procedure. If the parameter is a value parameter, the corresponding actual parameter must be an expression. This expression is evaluated prior to the procedure activation, and the resulting value is assigned to the formal parameter which now constitutes a local variable (see also 10.1.).

+ + 
+ProcedureCall = designator [ActualParameters].
+
+ +

Examples of procedure calls:

+ +
+ + + + + + + + + + + + + +
ReadInt(i)(see Ch. 10)
WriteInt(2*j + 1, 6)
INC(w[k].count)
+
+ +

9.3. Statement sequences

+ +

Statement sequences denote the sequence of actions specified by the component statements which are separated by semicolons.

+ + 
+StatementSequence = statement {";" statement}.
+
+ +

9.4. If statements

+ + 
+IfStatement = IF expression THEN StatementSequence
+	{ELSIF expression THEN StatementSequence}
+	[ELSE StatementSequence]
+	END.
+
+ +

If statements specify the conditional execution of guarded statements. The Boolean expression preceding a statement is called its guard. The guards are evaluated in sequence of occurrence, until one evaluates to TRUE, whereafter its associated statement sequence is executed. If no guard is satisfied, the statement sequence following the symbol ELSE is executed, if there is one.

+ +

Example:

+ + 
+IF (ch >= "A") & (ch <= "Z") THEN ReadIdentifier
+ELSIF (ch >= "0") & (ch <= "9") THEN ReadNumber
+ELSIF ch = 22X THEN ReadString
+END
+
+ +

9.5. Case statements

+ +

Case statements specify the selection and execution of a statement sequence according to the value of an expression. First the case expression is evaluated, then the statement sequence is executed whose case label list contains the obtained value. If the case expression is of type INTEGER or CHAR, all labels must be integers or single-character strings, respectively.

+ + 
+CaseStatement = CASE expression OF case {"|" case} END.
+case = [CaseLabelList ":" StatementSequence].
+CaseLabelList = LabelRange {"," LabelRange}.
+LabelRange = label [".." label].
+label = integer | string | qualident.
+
+ +

Example:

+ + 
+CASE k OF
+	  0: x := x + y
+	| 1: x := x − y
+	| 2: x := x * y
+	| 3: x := x / y
+END
+
+ +

The type T of the case expression (case variable) may also be a record or pointer type. Then the +case labels must be extensions of T, and in the statements Si labelled by Ti, the case variable is considered as of type Ti.

+ +

Example:

+ + 
+TYPE R = RECORD a: INTEGER END;
+	R0 = RECORD (R) b: INTEGER END;
+	R1 = RECORD (R) b: REAL END;
+	R2 = RECORD (R) b: SET END;
+	P = POINTER TO R;
+	P0 = POINTER TO R0;
+	P1 = POINTER TO R1;
+	P2 = POINTER TO R2;
+VAR p: P;
+
+ + 
+CASE p OF
+	P0: p.b := 10 |
+	P1: p.b := 2.5 |
+	P2: p.b := {0, 2}
+END
+
+ +

9.6. While statements

+ +

While statements specify repetition. If any of the Boolean expressions (guards) yields TRUE, the corresponding statement sequence is executed. The expression evaluation and the statement execution are repeated until none of the Boolean expressions yields TRUE.

+ + 
+WhileStatement = WHILE expression DO StatementSequence
+	{ELSIF expression DO StatementSequence} END.
+
+ +

Examples:

+ + 
+WHILE j > 0 DO
+	j := j DIV 2; i := i+1
+END
+
+ + 
+WHILE (t # NIL) & (t.key # i) DO
+	t := t.left
+END
+
+ + 
+WHILE m > n DO m := m - n
+ELSIF n > m DO n := n - m
+END
+
+ +

9.7. Repeat Statements

+ +

A repeat statement specifies the repeated execution of a statement sequence until a condition is satisfied. The statement sequence is executed at least once.

+ + 
+RepeatStatement = REPEAT StatementSequence UNTIL expression.
+
+ +

9.8. For statements

+ +

A for statement specifies the repeated execution of a statement sequence for a given number of times, while a progression of values is assigned to an integer variable called the control variable of the for statement.

+ + 
+ForStatement =
+	FOR ident ":=" expression TO expression [BY ConstExpression] DO
+	StatementSequence END.
+
+ +

The for statement

+ + 
+FOR v := beg TO end BY inc DO S END
+
+ +

is, if inc > 0, equivalent to

+ + 
+v := beg;
+WHILE v <= end DO S; v := v + inc END
+
+ +

and if inc < 0 it is equivalent to

+ + 
+v := beg;
+WHILE v >= end DO S; v := v + inc END
+
+ +

The types of v, beg and end must be INTEGER, and inc must be an integer (constant expression). If the step is not specified, it is assumed to be 1.

+ +

10. Procedure declarations

+ +

Procedure declarations consist of a procedure heading and a procedure body. The heading specifies the procedure identifier, the formal parameters, and the result type (if any). The body contains declarations and statements. The procedure identifier is repeated at the end of the procedure declaration.

+ +

There are two kinds of procedures, namely proper procedures and function procedures. The latter are activated by a function designator as a constituent of an expression, and yield a result that is an operand in the expression. Proper procedures +are activated by a procedure call. A function procedure is distinguished in the declaration by indication of the type of its result following the parameter list. Its body must end with a RETURN clause which defines the result of the function procedure.

+ +

All constants, variables, types, and procedures declared within a procedure body are local to the procedure. The values of local variables are undefined upon entry to the procedure. Since procedures may be declared as local objects too, procedure declarations may be nested.

+ +

In addition to its formal parameters and locally declared objects, the objects declared globally are also visible in the procedure.

+ +

The use of the procedure identifier in a call within its declaration implies recursive activation of the procedure.

+ + 
+ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.
+ProcedureHeading = PROCEDURE identdef [FormalParameters].
+ProcedureBody = DeclarationSequence [BEGIN StatementSequence]
+	[RETURN expression] END.
+DeclarationSequence = [CONST {ConstDeclaration ";"}]
+	[TYPE {TypeDeclaration ";"}] [VAR {VariableDeclaration ";"}]
+	{ProcedureDeclaration ";"}.
+
+ +

10.1. Formal parameters

+ +

Formal parameters are identifiers which denote actual parameters specified in the procedure call. The correspondence between formal and actual parameters is established when the procedure is called. There are two kinds of parameters, namely +value and variable parameters. A variable parameter corresponds to an actual parameter that is a variable, and it stands for that variable. A value parameter corresponds to an actual parameter that is an expression, and it stands for its value, which cannot be changed by assignment. However, if a value parameter is of a basic type, it represents a local variable to which the value of the actual expression is initially assigned.

+ +

The kind of a parameter is indicated in the formal parameter list: Variable parameters are denoted by the symbol VAR and value parameters by the absence of a prefix.

+ +

A function procedure without parameters must have an empty parameter list. It must be called by a function designator whose actual parameter list is empty too.

+ +

Formal parameters are local to the procedure, i.e. their scope is the program text which constitutes the procedure declaration.

+ + 
+FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].
+FPSection = [VAR] ident {"," ident} ":" FormalType.
+FormalType = {ARRAY OF} qualident.
+
+ +

The type of each formal parameter is specified in the parameter list. For variable parameters, it must be identical to the corresponding actual parameter's type, except in the case of a record, where it must be a base type of the corresponding actual parameter's type.

+ +

If the formal parameter's type is specified as

+ + 
+ARRAY OF T
+
+ +

the parameter is said to be an open array, and the corresponding actual parameter may be of arbitrary length.

+ +

If a formal parameter specifies a procedure type, then the corresponding actual parameter must be either a procedure declared globally, or a variable (or parameter) of that procedure type. It cannot be a predefined procedure. The result type of a procedure can be neither a record nor an array.

+ +

Examples of procedure declarations:

+ + 
+PROCEDURE ReadInt(VAR x: INTEGER);
+	VAR i: INTEGER; ch: CHAR;
+BEGIN i := 0; Read(ch);
+	WHILE ("0" <= ch) & (ch <= "9") DO
+		i := 10*i + (ORD(ch) - ORD("0")); Read(ch)
+	END;
+	x := i
+END ReadInt
+
+ + 
+PROCEDURE WriteInt(x: INTEGER); (* 0 <= x < 10^5 *)
+	VAR i: INTEGER;
+	buf: ARRAY 5 OF INTEGER;
+BEGIN i := 0;
+	REPEAT buf[i] := x MOD 10; x := x DIV 10; INC(i) UNTIL x = 0;
+	REPEAT DEC(i); Write(CHR(buf[i] + ORD("0"))) UNTIL i = 0
+END WriteInt
+
+ + 
+PROCEDURE log2(x: INTEGER): INTEGER;
+	VAR y: INTEGER; (*assume x>0*)
+BEGIN y := 0;
+	WHILE x > 1 DO x := x DIV 2; INC(y) END;
+	RETURN y
+END log2
+
+ +

10.2. Predefined procedures

+ +

The following table lists the predefined procedures. Some are generic procedures, i.e. they apply to several types of operands. v stands for a variable, x and n for expressions, and T for a type.

+ +

Function procedures:

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NameArgument typeResult typeFunction
ABS(x)x: numeric typetype of xabsolute value
ODD(x)x: INTEGERBOOLEANx MOD 2 = 1
LEN(v) v: arrayINTEGERthe length of v
LSL(x, n)x, n: INTEGERINTEGERlogical shift left, x * 2n
ASR(x, n)x, n: INTEGERINTEGERsigned shift right, x DIV 2n
ROR(x, n)x, n: INTEGERINTEGERx rotated right by n bits
+
+ +

Type conversion functions:

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NameArgument typeResult typeFunction
FLOOR(x)REALINTEGERtruncation
FLT(x)INTEGERREALidentity
ORD(x)CHAR, BOOLEAN, SETINTEGERordinal number of x
CHR(x)INTEGERCHARcharacter with ordinal number x
+
+ +

Proper procedures:

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NameArgument typesFunction
INC(v)INTEGERv := v + 1
INC(v, n)INTEGERv := v + n
DEC(v)INTEGERv := v - 1
DEC(v, n)INTEGERv := v - n
INCL(v, x)v: SET; x: INTEGERv := v + {x}
EXCL(v, x)v: SET; x: INTEGERv := v - {x}
NEW(v)pointer typeallocate v^
ASSERT(b)BOOLEANabort, if ~b
PACK(x, n)REAL; INTEGERpack x and n into x
UNPK(x, n)REAL; INTEGERunpack x into x and n
+
+ +

The function FLOOR(x) yields the largest integer not greater than x.

+ + 
+FLOOR(1.5) = 1    FLOOR(-1.5) = -2
+
+ +

The parameter n of PACK represents the exponent of x. PACK(x, y) is equivalent to x := x * 2y. UNPK is the reverse operation. The resulting x is normalized, such that 1.0 <= x < 2.0.

+ +

11. Modules

+ +

A module is a collection of declarations of constants, types, variables, and procedures, and a sequence of statements for the purpose of assigning initial values to the variables. A module typically constitutes a text that is compilable as a unit.

+ + 
+module = MODULE ident ";" [ImportList] DeclarationSequence
+	[BEGIN StatementSequence] END ident "." .
+ImportList = IMPORT import {"," import} ";" .
+Import = ident [":=" ident].
+
+ +

The import list specifies the modules of which the module is a client. If an identifier x is exported from a module M, and if M is listed in a module's import list, then x is referred to as M.x. If the form “M := M1” is used in the import list, an exported object x declared within M1 is referenced in the importing module as M.x .

+ +

Identifiers that are to be visible in client modules, i.e. which are to be exported, must be marked by an asterisk (export mark) in their declaration. Variables are always exported in read-only mode.

+ +

The statement sequence following the symbol BEGIN is executed when the module is added to a system (loaded). Individual (parameterless) procedures can thereafter be activated from the system, and these procedures serve as commands.

+ +

Example:

+ + 
+MODULE Out; (*exported procedures: Write, WriteInt, WriteLn*)
+	IMPORT Texts, Oberon;
+	VAR W: Texts.Writer;
+
+	PROCEDURE Write*(ch: CHAR);
+	BEGIN Texts.Write(W, ch)
+	END;
+
+	PROCEDURE WriteInt*(x, n: INTEGER);
+		VAR i: INTEGER; a: ARRAY 16 OF CHAR;
+	BEGIN i := 0;
+		IF x < 0 THEN Texts.Write(W, "-"); x := -x END ;
+		REPEAT a[i] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(i) UNTIL x = 0;
+		REPEAT Texts.Write(W, " "); DEC(n) UNTIL n <= i;
+		REPEAT DEC(i); Texts.Write(W, a[i]) UNTIL i = 0
+	END WriteInt;
+
+	PROCEDURE WriteLn*;
+	BEGIN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
+	END WriteLn;
+
+BEGIN Texts.OpenWriter(W)
+END Out.
+
+ +

11.1 The Module SYSTEM

+ +

The optional module SYSTEM contains definitions that are necessary to program low-level operations referring directly to resources particular to a given computer and/or implementation. These include for example facilities for accessing devices that are controlled by the computer, and perhaps facilities to break the data type compatibility rules otherwise imposed by the language definition.

+ +

There are two reasons for providing facilities in Module SYSTEM; (1) Their value is implementation-dependent, that is, it is not derivable from the language's definition, and (2) they may corrupt a system (e.g. PUT). It is strongly recommended to restrict their use to specific low-level modules, as such modules are inherently non-portable and not “type-safe”. However, they are easily recognized due to the identifier SYSTEM appearing in the module's import lists. The subsequent definitions are generally applicable. However, individual implementations may include in their module SYSTEM additional definitions that are particular to the specific, underlying computer. In the following, v stands for a variable, x, a, and n for expressions.

+ +

Function procedures:

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + +
NameArgument typesResult typeFunction
ADR(v)anyINTEGERaddress of variable v
SIZE(T)any typeINTEGERsize in bytes
BIT(a, n)a, n: INTEGERBOOLEANbit n of mem[a]
+
+ +

Proper procedures:

+ +
+ + + + + + + + + + + + + + + + + + + + + +
NameArgument typesFunction
GET(a, v)a: INTEGER; v: any basic typev := mem[a]
PUT(a, x)a: INTEGER; x: any basic typemem[a] := x
COPY(src, dst, n)all INTEGERcopy n consecutive words from src to dst
+
+ +

The following are additional procedures accepted by the compiler for the RISC processor:

+ +

Function procedures:

+ +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
NameArgument typesResult typeFunction
VAL(T, n)scalarTidentity
ADC(m, n)INTEGERINTEGERadd with carry C
SBC(m, n)INTEGERINTEGERsubtract with carry C
UML(m, n)INTEGERINTEGERunsigned multiplication
COND(n)INTEGERBOOLEANIF Cond(n) THEN ...
+
+ +

Proper procedures:

+ +
+ + + + + + + + + + + +
NameArgument typesFunction
LED(n)INTEGERdisplay n on LEDs
+
+ +

Appendix

+ +

The Syntax of Oberon

+ + 
+letter = "A" | "B" | ... | "Z" | "a" | "b" | ... | "z".
+digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9".
+hexDigit = digit | "A" | "B" | "C" | "D" | "E" | "F".
+
+ + 
+ident = letter {letter | digit}.
+qualident = [ident "."] ident.
+identdef = ident ["*"].
+
+ + 
+integer = digit {digit} | digit {hexDigit} "H".
+real = digit {digit} "." {digit} [ScaleFactor].
+ScaleFactor = "E" ["+" | "-"] digit {digit}.
+number = integer | real.
+string = """ {character} """ | digit {hexDigit} "X".
+
+ + 
+ConstDeclaration = identdef "=" ConstExpression.
+ConstExpression = expression.
+
+ + 
+TypeDeclaration = identdef "=" type.
+type = qualident | ArrayType | RecordType | PointerType | ProcedureType.
+ArrayType = ARRAY length {"," length} OF type.
+length = ConstExpression.
+RecordType = RECORD ["(" BaseType ")"] [FieldListSequence] END.
+BaseType = qualident.
+FieldListSequence = FieldList {";" FieldList}.
+FieldList = IdentList ":" type.
+IdentList = identdef {"," identdef}.
+PointerType = POINTER TO type.
+ProcedureType = PROCEDURE [FormalParameters].
+
+ + 
+VariableDeclaration = IdentList ":" type.
+
+ + 
+expression = SimpleExpression [relation SimpleExpression].
+relation = "=" | "#" | "<" | "<=" | ">" | ">=" | IN | IS.
+SimpleExpression = ["+" | "-"] term {AddOperator term}.
+AddOperator = "+" | "-" | OR.
+term = factor {MulOperator factor}.
+MulOperator = "*" | "/" | DIV | MOD | "&".
+factor = number | string | NIL | TRUE | FALSE |
+	set | designator [ActualParameters] | "(" expression ")" | "~" factor.
+designator = qualident {selector}.
+selector = "." ident | "[" ExpList "]" | "^" | "(" qualident ")".
+set = "{" [element {"," element}] "}".
+element = expression [".." expression].
+ExpList = expression {"," expression}.
+ActualParameters = "(" [ExpList] ")" .
+
+ + 
+statement = [assignment | ProcedureCall | IfStatement | CaseStatement |
+	WhileStatement | RepeatStatement | ForStatement].
+assignment = designator ":=" expression.
+ProcedureCall = designator [ActualParameters].
+StatementSequence = statement {";" statement}.
+IfStatement = IF expression THEN StatementSequence
+	{ELSIF expression THEN StatementSequence}
+	[ELSE StatementSequence] END.
+CaseStatement = CASE expression OF case {"|" case} END.
+case = [CaseLabelList ":" StatementSequence].
+CaseLabelList = LabelRange {"," LabelRange}.
+LabelRange = label [".." label].
+label = integer | string | qualident.
+WhileStatement = WHILE expression DO StatementSequence
+	{ELSIF expression DO StatementSequence} END.
+RepeatStatement = REPEAT StatementSequence UNTIL expression.
+ForStatement = FOR ident ":=" expression TO expression [BY ConstExpression]
+	DO StatementSequence END.
+
+ + 
+ProcedureDeclaration = ProcedureHeading ";" ProcedureBody ident.
+ProcedureHeading = PROCEDURE identdef [FormalParameters].
+ProcedureBody = DeclarationSequence [BEGIN StatementSequence]
+	[RETURN expression] END.
+DeclarationSequence = [CONST {ConstDeclaration ";"}]
+	[TYPE {TypeDeclaration ";"}]
+	[VAR {VariableDeclaration ";"}]
+	{ProcedureDeclaration ";"}.
+FormalParameters = "(" [FPSection {";" FPSection}] ")" [":" qualident].
+FPSection = [VAR] ident {"," ident} ":" FormalType.
+FormalType = {ARRAY OF} qualident.
+
+ + 
+module = MODULE ident ";" [ImportList] DeclarationSequence
+	[BEGIN StatementSequence] END ident "." .
+ImportList = IMPORT import {"," import} ";".
+import = ident [":=" ident].
+
+ + diff --git a/share/man/man1/obnc-compile.1 b/share/man/man1/obnc-compile.1 new file mode 100644 index 0000000..f82218e --- /dev/null +++ b/share/man/man1/obnc-compile.1 @@ -0,0 +1,61 @@ +.TH OBNC-COMPILE 1 +.SH NAME +obnc-compile \- compile an Oberon module to C +.SH SYNOPSIS +.B obnc-compile +[\fB\-e\fR | \fB\-l\fR] +.IR INFILE +.br +.B obnc-compile +(\fB\-h\fR | \fB\-v\fR) +.SH DESCRIPTION +.B obnc-compile +compiles an Oberon module to C. The input filename is expected to end with +.IR .obn , +.IR .Mod +or +.IR .mod . +All output files (C implementation file, C header file, symbol file etc.) are stored in the subdirectory +.IR .obnc . +.P +The compiler accepts the Oberon language as defined in "The Programming Language Oberon", revision 2013-10-01 / 2016-05-03 (Oberon-07). The module SYSTEM provides the generally applicable procedures plus VAL, as defined in the language report. The underscore character is also accepted as a word separator in identifiers. The target language is ANSI C (C89). +.P +The generated C file uses the exception codes below. If an exception occurs the trap handler is called. By default it writes the exception code to the standard error stream and aborts the program. +.P +E1 = destination array too short for assignment +.br +E2 = array index out of bounds +.br +E3 = nil pointer dereference +.br +E4 = nil procedure variable call +.br +E5 = source in assignment is not an extension of target +.br +E6 = type guard failure +.br +E7 = unmatched expression in case statement +.br +E8 = assertion failure +.SH OPTIONS +.TP +.BR \-e +Create an entry point function (main). +.TP +.BR \-h +Display help and exit. +.TP +.BR \-l +Print names of imported modules to standard output and exit. +.TP +.BR \-v +Display version and exit. +.SH ENVIRONMENT +.IP OBNC_IMPORT_PATH +See +.BR obnc-path (1) +.SH AUTHOR +Written by Karl Landstr\[:o]m +.SH "SEE ALSO" +.BR obnc (1), +.BR obnc-path (1) diff --git a/share/man/man1/obnc-path.1 b/share/man/man1/obnc-path.1 new file mode 100644 index 0000000..4e6a7db --- /dev/null +++ b/share/man/man1/obnc-path.1 @@ -0,0 +1,35 @@ +.TH OBNC-PATH 1 +.SH NAME +obnc-path \- print directory path for Oberon module +.SH SYNOPSIS +.B obnc-path +[\fB\-v\fR] +MODULE +.br +.B obnc-path +(\fB\-h\fR | \fB\-v\fR) +.SH DESCRIPTION +.B obnc-path +prints the directory path for an Oberon module. For a module M, the printed path is the first directory found which contains either the Oberon source file, +.IR .obnc/M.sym +or +.IR M.sym . +.P +First the current directory is searched. Then paths in OBNC_IMPORT_PATH are searched. Finally the default library directory in the OBNC installation path is searched. +.P +For each path P, modules are searched both in P and in first-level subdirectories of P. Subdirectories represent individual libraries and are expected to be in lowercase. For the modules in a subdirectory L, only modules prefixed with L followed by an uppercase letter are searched. The other modules in L are considered local to the library. +.SH OPTIONS +.TP +.BR \-h +Display help and exit. +.TP +.BR \-v +Without argument, display version and exit. Otherwise, print each inspected directory path to standard output. +.SH ENVIRONMENT +.IP OBNC_IMPORT_PATH +List of directory paths to search Oberon modules in. Paths are separated with a colon on POSIX systems, and with a semicolon on MS Windows. +.SH AUTHOR +Written by Karl Landstr\[:o]m +.SH "SEE ALSO" +.BR obnc (1), +.BR obnc-compile (1) diff --git a/share/man/man1/obnc.1 b/share/man/man1/obnc.1 new file mode 100644 index 0000000..0c8e237 --- /dev/null +++ b/share/man/man1/obnc.1 @@ -0,0 +1,150 @@ +.TH OBNC 1 +.SH NAME +obnc \- build an executable for an Oberon module +.SH SYNOPSIS +.B obnc +[\fB\-o\fR +.IR OUTFILE ] +[\fB\-v\fR | \fB\-V\fR] [\fB\-x\fR] +.IR INFILE +.br +.B obnc +(\fB\-h\fR | \fB\-v\fR) +.SH DESCRIPTION +.B obnc +builds an executable file for an Oberon module. Before the module is compiled, object files for imported modules are recursively created or updated as needed. Oberon modules are first compiled to C with +.BR obnc-compile . +Each C file is then compiled to object code with an external C compiler. Finally, the object files are linked into an executable program. Oberon source filenames are expected to end with +.IR .obn , +.IR .Mod +or +.IR .mod . +All output files except the final executable are stored in the subdirectory +.IR .obnc . +.P +If for any module M there exists a file named +.I M.c +in the same directory as the Oberon source file then +.I M.c +will be used as the input to the C compiler instead of the generated file +.IR .obnc/M.c . +This provides a mechanism to implement a module in C. +.P +For any module M, environment variables for the C compiler specific to M and environment variables for the linker can be defined in a file named +.IR M.env , +located in the same directory as the Oberon source file. +.SH OPTIONS +.TP +.BR \-h +Display help and exit. +.TP +\fB\-o\fR OUTFILE +Use pathname OUTFILE for the generated executable file. +.TP +.BR \-v +Without argument, display version and exit. Otherwise, output progress of compiled modules. +.TP +.BR \-V +Output progress of compiled modules with compiler and linker subcommands. +.TP +.BR \-x +Compile and link modules from C source (if available) in a single command. When a program is cross-compiled, this option prevents using object files compiled for the host system. It also prevents leaving behind object files which are incompatible with the host system. +.SH ENVIRONMENT +.IP CC +Specifies the C compiler to use (default is cc). +.IP CFLAGS +Options for the C compiler. The following constants can be customized with the flag -D name=value and are intended to be used with the option -x: +.RS +.IP OBNC_CONFIG_C_INT_TYPE +Controls the size of type INTEGER and SET. The value is OBNC_CONFIG_SHORT, OBNC_CONFIG_INT, OBNC_CONFIG_LONG or OBNC_CONFIG_LONG_LONG. +.IP OBNC_CONFIG_C_REAL_TYPE +Controls the size of type REAL. The value is OBNC_CONFIG_FLOAT, OBNC_CONFIG_DOUBLE or OBNC_CONFIG_LONG_DOUBLE. +.IP OBNC_CONFIG_TARGET_EMB +Value 1 builds an executable for a freestanding execution environment (embedded platform). With this option the C main function takes no parameters. The garbage collector is disabled and any call to NEW is invalidated. The executable is not linked with the math library libm. +.RE +.IP LDFLAGS +Additional options for the linker. +.IP LDLIBS +Additional libraries to link with. +.IP OBNC_IMPORT_PATH +See +.BR obnc-path (1) +.SH EXAMPLES +.SS Getting Started +In Oberon, the program to print "hello, world" is +.P +.RS +MODULE hello; +.P +.RS +IMPORT Out; +.P +.RE +BEGIN +.RS +Out.String("hello, world"); +.br +Out.Ln +.RE +END hello. +.RE +.P +Save the above module in a file named +.IR hello.obn +and compile it with the command +.P +.RS +obnc hello.obn +.RE +.P +This will create an executable file named +.IR hello . +When you run +.IR hello +with the command +.P +.RS +\[char46]/hello +.RE +.P +it should print +.P +.RS +hello, world +.RE +.SS Interfacing to C +To implement a module M in C: +.IP 1. 3 +Create a file named +.I M.obn +with the the exported declarations +.IP 2. 3 +Create a file named +.I MTest.obn +which imports M (and preferably write unit tests for M) +.IP 3. 3 +Build MTest with the command +.P +.RS +obnc MTest.obn +.RE +.P +.IP 4. 3 +Copy the generated file +.IR .obnc/M.c +to the current directory. In +.IR M.c , +delete the generator comment on the first line and change the path in the include directive from +.IR M.h +to +.IR .obnc/M.h . +.IP 5. 3 +Implement +.IR M.c . +.P +Note: The initialization function M__Init is called each time a client module imports M. Its statements should therefore be guarded with an initialization flag to make sure they are executed only once. +.SH AUTHOR +Written by Karl Landstr\[:o]m +.SH "SEE ALSO" +.BR obnc-compile (1), +.BR obnc-path (1) diff --git a/share/man/man1/obncdoc.1 b/share/man/man1/obncdoc.1 new file mode 100644 index 0000000..4eb4340 --- /dev/null +++ b/share/man/man1/obncdoc.1 @@ -0,0 +1,29 @@ +.TH OBNCDOC 1 +.SH NAME +obncdoc \- extract exported features from Oberon modules +.SH SYNOPSIS +.B obncdoc +[\fB\-h\fR | \fB\-v\fR] +.SH DESCRIPTION +.B obncdoc +reads the Oberon source files in the current directory and creates module definitions in plain-text and HTML. A module index is also created. Each definition contains the exported declarations and the exported comments (start with an asterisk) for the corresponding module. The definition files are created, updated or deleted only as needed. A default style file, +.IR style.css , +is created only if not present. This provides for custom style sheets. All output files are written to the directory +.I obncdoc +in the current directory. Oberon source filenames are expected to end with +.IR .obn , +.IR .Mod +or +.IR .mod . +.P +.B obncdoc +is not a complete parser so no syntactical or semantical checks are performed. +.SH OPTIONS +.TP +.BR \-h +Display help and exit. +.TP +.BR \-v +Display version and exit. +.SH AUTHOR +Written by Karl Landstr\[:o]m diff --git a/share/obnc/style.css b/share/obnc/style.css new file mode 100644 index 0000000..ef1ab9c --- /dev/null +++ b/share/obnc/style.css @@ -0,0 +1,35 @@ +body { + font-family: sans-serif; + margin: 1em; +} + +pre { + font-family: inherit; + font-size: inherit; + + -moz-tab-size: 4; + -o-tab-size: 4; + tab-size: 4; +} + +pre em { + font-style: normal; + font-weight: bold; +} + +pre .comment { + color: #800000; + display: inline-block; + max-width: 42em; + vertical-align: text-top; + + white-space: pre-wrap; + white-space: -moz-pre-wrap; + white-space: -pre-wrap; + white-space: -o-pre-wrap; + word-wrap: break-word; +} + +pre .string { + color: #767676; +} diff --git a/src/Config.c b/src/Config.c new file mode 100644 index 0000000..d9b3ef4 --- /dev/null +++ b/src/Config.c @@ -0,0 +1,63 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Config.h" +#include "Util.h" +#include +#include + +static int initialized = 0; + +void Config_Init(void) +{ + if (! initialized) { + initialized = 1; + Util_Init(); + } +} + + +const char *Config_Prefix(void) +{ + static const char *prefix; + + assert(initialized); + + if (prefix == NULL) { + prefix = getenv("OBNC_PREFIX"); + if (prefix == NULL) { + prefix = CONFIG_DEFAULT_PREFIX; + } + } + return prefix; +} + + +const char *Config_LibDir(void) +{ + static const char *libdir; + + assert(initialized); + + if (libdir == NULL) { + libdir = getenv("OBNC_LIBDIR"); + if (libdir == NULL) { + libdir = CONFIG_DEFAULT_LIBDIR; + } + } + return libdir; +} diff --git a/src/Error.c b/src/Error.c new file mode 100644 index 0000000..b2a0108 --- /dev/null +++ b/src/Error.c @@ -0,0 +1,59 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Error.h" +#include +#include +#include + +static int initialized = 0; +static Error_Handler handleError; + +static void HandleError(const char msg[]) /*default error handler*/ +{ + assert(msg != NULL); + + fprintf(stderr, "%s\n", msg); + exit(EXIT_FAILURE); +} + + +void Error_Init(void) +{ + if (! initialized) { + initialized = 1; + handleError = HandleError; + } +} + + +void Error_SetHandler(Error_Handler h) +{ + assert(initialized); + assert(h != NULL); + + handleError = h; +} + + +void Error_Handle(const char msg[]) +{ + assert(initialized); + assert(msg != NULL); + + handleError(msg); +} diff --git a/src/Error.h b/src/Error.h new file mode 100644 index 0000000..92612e7 --- /dev/null +++ b/src/Error.h @@ -0,0 +1,29 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef ERROR_H +#define ERROR_H + +typedef void (*Error_Handler)(const char msg[]); + +void Error_Init(void); + +void Error_SetHandler(Error_Handler h); + +void Error_Handle(const char msg[]); + +#endif diff --git a/src/Files.c b/src/Files.c new file mode 100644 index 0000000..fbe9658 --- /dev/null +++ b/src/Files.c @@ -0,0 +1,186 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Files.h" +#include "Error.h" +#include "Util.h" +#include /*POSIX*/ +#include /*POSIX*/ +#include /*POSIX*/ +#include +#include +#include +#include +#include + +static int initialized = 0; + +void Files_Init(void) +{ + if (! initialized) { + initialized = 1; + Error_Init(); + } +} + + +int Files_Exists(const char filename[]) +{ + int error; + + assert(initialized); + assert(filename != NULL); + + error = access(filename, F_OK); + return ! error; +} + + +time_t Files_Timestamp(const char filename[]) +{ + struct stat buf; + int error; + time_t result = 0; + + assert(initialized); + assert(filename != NULL); + + error = stat(filename, &buf); + if (! error) { + result = buf.st_mtime; + } else { + Error_Handle(Util_String("Cannot get timestamp of filename: %s: %s", filename, strerror(errno))); + } + return result; +} + + +FILE *Files_New(const char filename[]) +{ + FILE *newFile; + + assert(initialized); + assert(filename != NULL); + + newFile = fopen(filename, "w+"); + if (newFile == NULL) { + Error_Handle(Util_String("Cannot open new file: %s: %s", filename, strerror(errno))); + } + + assert(newFile != NULL); + + return newFile; +} + + +FILE *Files_Old(const char filename[], int mode) +{ + const char *fopenMode; + FILE *oldFile; + + assert(initialized); + assert(filename != NULL); + assert((mode == FILES_READ) || (mode == FILES_WRITE) || (mode == FILES_APPEND)); + assert(Files_Exists(filename)); + + if (mode == FILES_READ) { + fopenMode = "r"; + } else if (mode == FILES_WRITE) { + fopenMode = "w"; + } else { + fopenMode = "a"; + } + oldFile = fopen(filename, fopenMode); + if (oldFile == NULL) { + Error_Handle(Util_String("Cannot open old file: %s: %s", filename, strerror(errno))); + } + + assert(oldFile != NULL); + + return oldFile; +} + + +void Files_Close(FILE **file) +{ + int error; + + assert(initialized); + assert(file != NULL); + + if (*file != NULL) { + error = fclose(*file); + if (error) { + Error_Handle(Util_String("Closing file failed")); + } + *file = NULL; + } +} + + +void Files_Move(const char sourceFilename[], const char destFilename[]) +{ + int error; + + assert(initialized); + assert(sourceFilename != NULL); + assert(destFilename != NULL); + +#ifdef _WIN32 + if (Files_Exists(destFilename)) { + Files_Remove(destFilename); + } +#endif + error = rename(sourceFilename, destFilename); + if (error) { + Error_Handle(Util_String("Cannot move file %s to %s: %s", sourceFilename, destFilename, strerror(errno))); + } +} + + +void Files_Remove(const char filename[]) +{ + int error; + + assert(initialized); + assert(filename != NULL); + + error = remove(filename); + if (error) { + Error_Handle(Util_String("Cannot remove file: %s: %s", filename, strerror(errno))); + } +} + + +void Files_CreateDir(const char dirname[]) +{ + int error; + + assert(initialized); + assert(dirname != NULL); + assert(! Files_Exists(dirname)); + +#ifdef _WIN32 + error = mkdir(dirname); +#else + error = mkdir(dirname, 0755); +#endif + if (error) { + Error_Handle(Util_String("Cannot create directory: %s: %s", dirname, strerror(errno))); + exit(EXIT_FAILURE); + } +} diff --git a/src/Files.h b/src/Files.h new file mode 100644 index 0000000..852afb1 --- /dev/null +++ b/src/Files.h @@ -0,0 +1,47 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef FILES_H +#define FILES_H + +#include +#include + +/*file access modes*/ +#define FILES_READ 0 +#define FILES_WRITE 1 +#define FILES_APPEND 2 + +void Files_Init(void); + +int Files_Exists(const char filename[]); + +time_t Files_Timestamp(const char filename[]); + +FILE *Files_New(const char filename[]); + +FILE *Files_Old(const char filename[], int mode); + +void Files_CreateDir(const char dirname[]); + +void Files_Move(const char sourceFilename[], const char destFilename[]); + +void Files_Remove(const char filename[]); + +void Files_Close(FILE **file); /*also sets *file to NULL*/ + +#endif diff --git a/src/Generate.c b/src/Generate.c new file mode 100644 index 0000000..d8d7f25 --- /dev/null +++ b/src/Generate.c @@ -0,0 +1,3035 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Generate.h" +#include "Config.h" +#include "Files.h" +#include "Maps.h" +#include "Oberon.h" +#include "Paths.h" +#include "Trees.h" +#include "Types.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" +#include "y.tab.h" +#include /*POSIX*/ +#include +#include +#include +#include +#include +#include +#include +#include + +#define CONST_SECTION 1 +#define TYPE_SECTION 2 +#define VAR_SECTION 3 +#define PROCEDURE_SECTION 4 +#define MODULE_SECTION 5 + +static int initialized = 0; + +static const char *inputFilename; +static const char *inputModuleName; +static int isEntryPointModule; + +static const char *headerComment; +static const char *tempCFilepath; +static const char *tempHFilepath; +static FILE *cFile; +static FILE *hFile; + +static Trees_Node importList; + +static Trees_Node declaredTypeIdent; + +static Trees_Node caseVariable; +static Trees_Node caseLabelType; + +static long int procedureDeclStart; +static struct ProcedureDeclNode { + Trees_Node procIdent; + Maps_Map localProcedures; + Trees_Node runtimeInitVars; + char *partialDecl; + struct ProcedureDeclNode *next; +} *procedureDeclStack; + +static int addressOperationUsed; + +void Generate_Init(void) +{ + if (! initialized) { + initialized = 1; + Config_Init(); + Files_Init(); + Oberon_Init(); + Trees_Init(); + Util_Init(); + } +} + + +static void GenerateInternalDeclarations(int section) +{ + static int globalSection; + static int internalImportsDeclared; + static int internalConstantsDeclared; + + if ((globalSection != PROCEDURE_SECTION) || (section == MODULE_SECTION)) { + globalSection = section; + switch (section) { + case CONST_SECTION: + case TYPE_SECTION: + case VAR_SECTION: + case PROCEDURE_SECTION: + case MODULE_SECTION: + if (! internalImportsDeclared) { + fprintf(cFile, "#include \n"); + if (! isEntryPointModule) { + fprintf(hFile, "#include \n"); + } + internalImportsDeclared = 1; + } + if (! internalConstantsDeclared) { + fprintf(cFile, "\n#define OBERON_SOURCE_FILENAME \"%s\"\n", inputFilename); + internalConstantsDeclared = 1; + } + } + } +} + + +static void Indent(FILE *file, int n) +{ + int i; + + for (i = 0; i < n; i++) { + fputc('\t', file); + } +} + +static void Generate(Trees_Node tree, FILE *file, int indent); + + +/*IDENTIFIER GENERATORS*/ + +static int ModulePrefixNeeded(Trees_Node ident) +{ + int imported, indirectlyImported, exported, global, isType, isField; + + imported = Trees_Imported(ident); + indirectlyImported = ! imported && (strchr(Trees_Name(ident), '.') != NULL); + exported = Trees_Exported(ident); + global = ! Trees_Local(ident); + isType = Types_IsType(ident); + isField = Trees_Kind(ident) == TREES_FIELD_KIND; + + return ! isEntryPointModule && ! imported && ! indirectlyImported && ((exported && ! isField) || (global && isType)); +} + + +static void GenerateLocalProcedurePrefix(Trees_Node ident, struct ProcedureDeclNode *node, FILE *file) +{ + if (node != NULL) { + GenerateLocalProcedurePrefix(ident, node->next, file); + fprintf(file, "%s_", Trees_Name(node->procIdent)); + } +} + + +static void GenerateLocalProcedureIdent(Trees_Node ident, FILE *file, int indent) +{ + assert(procedureDeclStack != NULL); + Indent(file, indent); + if (Maps_HasKey(Trees_Name(ident), procedureDeclStack->localProcedures)) { + GenerateLocalProcedurePrefix(ident, procedureDeclStack, file); + } else { + GenerateLocalProcedurePrefix(ident, procedureDeclStack->next, file); + } + fprintf(file, "%s_Local", Trees_Name(ident)); +} + + +static void GenerateIdent(Trees_Node ident, FILE *file, int indent) +{ + const char *name; + Trees_Node type; + + name = Trees_UnaliasedName(ident); + type = Trees_Type(ident); + if ((Trees_Kind(ident) == TREES_TYPE_KIND) && Types_Basic(type)) { + Generate(type, file, indent); + } else if (Trees_Internal(ident)) { + Indent(file, indent); + fprintf(file, "%s", name); + } else if (ModulePrefixNeeded(ident)) { + Indent(file, indent); + fprintf(file, "%s__%s_", inputModuleName, name); + } else if ((Trees_Kind(ident) == TREES_TYPE_KIND) && Trees_Local(ident) && Types_IsRecord(type)) { + /*With T = RECORD ... END in module scope and P = POINTER TO T and T = RECORD ... END in local scope, where P references the global T, we need access to global T's heap type when calling NEW, so T must not be shadowed.*/ + fprintf(file, "%s_Local", name); + } else if ((Trees_Kind(ident) == TREES_PROCEDURE_KIND) && Trees_Local(ident)) { + GenerateLocalProcedureIdent(ident, file, indent); + } else { + name = Util_Replace(".", "__", name); + Indent(file, indent); + fprintf(file, "%s_", name); + } +} + + +static const char *DirPrefix(void) +{ + static char result[16]; + static int initialized = 0; + const char *dir; + int i, j; + + if (! initialized) { + dir = Paths_Basename(Paths_CurrentDir()); + i = 0; + j = 0; + while ((dir[i] != '\0') && (j < LEN(result) - 2)) { + if (((j == 0) && isalpha(dir[i])) || ((j > 0) && isalnum(dir[i]))) { + result[j] = dir[i]; + j++; + } + i++; + } + result[j] = '_'; + result[j + 1] = '\0'; + initialized = 1; + } + return result; +} + + +static void GenerateObjectFileSymbolDefinitions(Trees_Node identList, const char *suffix, FILE *file, int indent) +{ + const char *dirPrefix; + Trees_Node ident; + + /*NOTE: To prevent potential name collisions at link time when two modules with the same name (from different directories) are combined, we add a directory prefix to object file symbols with external linkage.*/ + + dirPrefix = DirPrefix(); + if (strcmp(dirPrefix, "") != 0) { + while (identList != NULL) { + ident = Trees_Left(identList); + Indent(file, indent); + fprintf(file, "#define "); + GenerateIdent(ident, file, 0); + fprintf(file, "%s %s_", suffix, dirPrefix); + GenerateIdent(ident, file, 0); + fprintf(file, "%s\n", suffix); + identList = Trees_Right(identList); + } + } +} + + +/*LITERAL GENERATORS*/ + +static void GenerateReal(OBNC_REAL value, FILE *file) +{ + char buffer[256]; + + if (value > OBNC_REAL_MAX) { /*inf*/ + fprintf(file, "(1.0 / 0.0)"); + } else if (value < -OBNC_REAL_MAX) { /*-inf*/ + fprintf(file, "(-1.0 / 0.0)"); + } else if (value != value) { + if (value >= 0.0) { /*nan*/ + fprintf(file, "(0.0 / 0.0)"); + } else { /*-nan*/ + fprintf(file, "(-0.0 / 0.0)"); + } + } else { + sprintf(buffer, "%.*" OBNC_REAL_MOD_W "g", LDBL_DIG, value); + if (strpbrk(buffer, ".e") == NULL) { /*formatted as integer?*/ + strcat(buffer, ".0"); + } + if (value <= DBL_MAX) { + fprintf(file, "%s", buffer); + } else { + fprintf(file, "OBNC_REAL_SUFFIX(%s)", buffer); + } + } +} + + +static void GenerateString(const char s[], FILE *file) +{ + int i; + + fputc('"', file); + if (((unsigned char) s[0] >= 128) && (s[1] == '\0')) { + fprintf(file, "\\x%02x", (unsigned char) s[0]); + } else { + i = 0; + while (s[i] != '\0') { + if ((unsigned char) s[i] <= 127) { + if (isprint(s[i])) { + if ((s[i] == '"') || (s[i] == '\\')) { + fputc('\\', file); + } + fputc(s[i], file); + } else { + fprintf(file, "\" \"\\x%02x\" \"", (unsigned char) s[i]); + } + } else { + fputc(s[i], file); + } + i++; + } + } + fputc('"', file); +} + + +static void GenerateChar(char ch, FILE *file) +{ + switch (ch) { + case '\'': + case '\\': + fprintf(file, "'\\%c'", ch); + break; + default: + if (isprint(ch)) { + fprintf(file, "'%c'", ch); + } else { + fprintf(file, "'\\x%02x'", (unsigned char) ch); + } + } +} + + +/*CONSTANT DECLARATION GENERATORS*/ + +void Generate_ConstDeclaration(Trees_Node ident) +{ + assert(initialized); + + GenerateInternalDeclarations(CONST_SECTION); + if (Trees_Exported(ident)) { + /*add constant declaration to header file to provide access to it from hand-written C file*/ + fprintf(hFile, "\n#define "); + Generate(ident, hFile, 0); + fprintf(hFile, " "); + Generate(Trees_Value(ident), hFile, 0); + fprintf(hFile, "\n"); + } +} + + +/*TYPE DECLARATION GENERATORS*/ + +static void GenerateDeclaration(Trees_Node declaration, FILE *file, int indent); + +static void GenerateFields(Trees_Node type, FILE *file, int indent) +{ + Trees_Node typeDesc, baseType, pointerBaseType, fieldListSeq, identList; + + assert(type != NULL); + + typeDesc = Types_Descriptor(type); + fieldListSeq = Types_Fields(typeDesc); + baseType = Types_RecordBaseType(typeDesc); + if (baseType != NULL) { + if (Types_IsPointer(baseType)) { + pointerBaseType = Types_PointerBaseType(baseType); + if (Trees_Symbol(pointerBaseType) == RECORD) { + Indent(file, indent); + fprintf(file, "struct "); + Generate(baseType, file, 0); + } else { + assert(Trees_Symbol(pointerBaseType) == IDENT); + Generate(pointerBaseType, file, indent); + } + } else { + Generate(baseType, file, indent); + } + fprintf(file, " base;\n"); + } else if (fieldListSeq == NULL) { + Indent(file, indent); + fprintf(file, "char dummy;\n"); + } + while (fieldListSeq != NULL) { + identList = Trees_Left(fieldListSeq); + GenerateDeclaration(Trees_NewNode(TREES_NOSYM, identList, NULL), file, indent); + fieldListSeq = Trees_Right(fieldListSeq); + } +} + + +static void GenerateRecord(Trees_Node type, Trees_Node declIdent, FILE *file, int indent) +{ + Indent(file, indent); + fprintf(file, "struct "); + if ((declIdent != NULL) && (Trees_Kind(declIdent) == TREES_TYPE_KIND)) { + Generate(declIdent, file, 0); + fprintf(file, " "); + } + fprintf(file, "{\n"); + GenerateFields(type, file, indent + 1); + Indent(file, indent); + fprintf(file, "}"); +} + + +static Trees_Node TypeDescIdent(Trees_Node type) +{ + Trees_Node result, initialIdent, unaliasedIdent, typeStruct, pointerBaseType; + + result = NULL; + initialIdent = type; + if (Trees_Symbol(type) == POINTER) { + initialIdent = Trees_Left(type); + assert(Trees_Symbol(initialIdent) == IDENT); + } + unaliasedIdent = Types_UnaliasedIdent(initialIdent); + typeStruct = Types_Structure(unaliasedIdent); + switch (Trees_Symbol(typeStruct)) { + case RECORD: + result = unaliasedIdent; + break; + case POINTER: + pointerBaseType = Types_PointerBaseType(typeStruct); + switch (Trees_Symbol(pointerBaseType)) { + case RECORD: + result = unaliasedIdent; + break; + case IDENT: + result = Types_UnaliasedIdent(pointerBaseType); + break; + default: + assert(0); + } + break; + default: + assert(0); + } + + assert(result != NULL); + + return result; +} + + +static void GenerateStorageClassSpecifier(Trees_Node ident, FILE *file) +{ + if (Trees_Kind(ident) == TREES_TYPE_KIND) { + fprintf(file, "typedef "); + } else if ((Trees_Kind(ident) == TREES_VARIABLE_KIND) && ! Trees_Local(ident)) { + if (file == hFile) { + fprintf(file, "extern "); + } else if (! Trees_Exported(ident)) { + fprintf(file, "static "); + } + } +} + + +static int TypePossiblyIncomplete(Trees_Node type, Trees_Node ident) +{ + return ((Trees_Symbol(Trees_Type(ident)) == POINTER) + && ((Trees_Kind(ident) == TREES_TYPE_KIND) || (Trees_Kind(ident) == TREES_FIELD_KIND)) + && ((Trees_Type(type) == NULL) || Types_IsRecord(type))) + || (type == declaredTypeIdent); +} + + +static void GenerateTypeSpecifier(Trees_Node ident, Trees_Node type, FILE *file, int indent) +{ + Trees_Node elementType; + + switch (Trees_Symbol(type)) { + case IDENT: + if (TypePossiblyIncomplete(type, ident)) { + fprintf(file, "struct "); + } + Generate(type, file, 0); + break; + case ARRAY: + elementType = Types_ElementType(type); + while (Types_IsArray(elementType)) { + elementType = Types_ElementType(elementType); + } + GenerateTypeSpecifier(ident, elementType, file, indent); + break; + case RECORD: + GenerateRecord(type, ident, file, indent); + break; + case POINTER: + GenerateTypeSpecifier(ident, Types_PointerBaseType(type), file, indent); + break; + case PROCEDURE: + if (Types_ResultType(type) != NULL) { + GenerateTypeSpecifier(ident, Types_ResultType(type), file, indent); + } else { + fprintf(file, "void"); + } + break; + default: + Generate(type, file, indent); + } +} + + +static Trees_Node EntireVar(Trees_Node var) +{ + assert(Trees_Symbol(var) == TREES_DESIGNATOR); + return Trees_Left(var); +} + + +static void GenerateArrayLength(Trees_Node arrayType, Trees_Node varIdent, int dim, FILE *file) +{ + assert(Types_IsArray(arrayType)); + assert(Trees_Symbol(varIdent) == IDENT); + assert(dim >= 0); + + if (Types_IsOpenArray(arrayType)) { + Generate(varIdent, file, 0); + fprintf(file, "len"); + if (dim > 0) { + fprintf(file, "%d", dim); + } + } else { + fprintf(file, "%" OBNC_INT_MOD "d", Trees_Integer(Types_ArrayLength(arrayType))); + } +} + + +static void GenerateFlattenedArrayLength(Trees_Node arrayType, Trees_Node varIdent, int dim, FILE *file) +{ + Trees_Node type; + int i; + + assert(Types_IsArray(arrayType)); + assert(Trees_Symbol(varIdent) == IDENT); + assert(dim >= 0); + + type = arrayType; + i = 0; + while (Types_IsArray(type)) { + if (i > 0) { + fprintf(file, " * "); + } + GenerateArrayLength(type, varIdent, dim + i, file); + type = Types_ElementType(type); + i++; + } +} + + +static void GenerateFormalParameterList(Trees_Node paramList, FILE *file); + +static void GenerateDeclarator(Trees_Node ident, FILE *file) +{ + Trees_Node type, firstNonArrayType, resultType; + + type = Trees_Type(ident); + firstNonArrayType = type; + while (Trees_Symbol(firstNonArrayType) == ARRAY) { + firstNonArrayType = Types_ElementType(firstNonArrayType); + } + if ((Trees_Symbol(firstNonArrayType) == POINTER) + || (Types_IsPointer(firstNonArrayType) && TypePossiblyIncomplete(firstNonArrayType, ident))) { + fprintf(file, "*"); + } else if (Trees_Symbol(firstNonArrayType) == PROCEDURE) { + resultType = Types_ResultType(firstNonArrayType); + if ((declaredTypeIdent != NULL) && (resultType == declaredTypeIdent)) { + fprintf(file, "*"); + } + fprintf(file, "(*"); + } + Generate(ident, file, 0); + if (Trees_Symbol(type) == ARRAY) { + /*NOTE: Since multi-dimensional open array parameters must be generated as one-dimensional arrays, we must also generate (non-open) multi-dimensional arrays as one-dimensional arrays to enable parameter substitution with correct type.*/ + fprintf(file, "["); + GenerateFlattenedArrayLength(type, ident, 0, file); + fprintf(file, "]"); + } + if (Trees_Symbol(firstNonArrayType) == PROCEDURE) { + fprintf(file, ")("); + if (Types_Parameters(firstNonArrayType) != NULL) { + GenerateFormalParameterList(Types_Parameters(firstNonArrayType), file); + } else { + fprintf(file, "void"); + } + fprintf(file, ")"); + } +} + + +static void SearchPointersAndProceduresRec(Trees_Node type, int *hasPointer, int *hasProcedure) +{ + Trees_Node recordBaseType, fieldListSeq, fieldList, ident; + + if ((type != NULL) && ! (*hasPointer && *hasProcedure)) { + switch (Trees_Symbol(Types_Structure(type))) { + case ARRAY: + SearchPointersAndProceduresRec(Types_ElementType(type), hasPointer, hasProcedure); + break; + case RECORD: + recordBaseType = Types_RecordBaseType(type); + if (recordBaseType != NULL) { + SearchPointersAndProceduresRec( + Types_Descriptor(recordBaseType), hasPointer, hasProcedure); + } + fieldListSeq = Types_Fields(type); + while ((fieldListSeq != NULL) && ! (*hasPointer && *hasProcedure)) { + fieldList = Trees_Left(fieldListSeq); + ident = Trees_Left(fieldList); + SearchPointersAndProceduresRec(Trees_Type(ident), hasPointer, hasProcedure); + fieldListSeq = Trees_Right(fieldListSeq); + } + break; + case POINTER: + *hasPointer = 1; + break; + case PROCEDURE: + *hasProcedure = 1; + break; + } + } +} + + +static void SearchPointersAndProcedures(Trees_Node type, int *hasPointer, int *hasProcedure) +{ + *hasPointer = 0; + *hasProcedure = 0; + SearchPointersAndProceduresRec(type, hasPointer, hasProcedure); +} + + +static void GenerateDeclaration(Trees_Node declaration, FILE *file, int indent) +{ + Trees_Node identList, firstIdent, ident; + int hasPointer, hasProcedure; + + if (Trees_Symbol(Trees_Left(declaration)) == IDENT) { + identList = Trees_NewNode(TREES_IDENT_LIST, Trees_Left(declaration), NULL); + } else { + identList = Trees_Left(declaration); + } + firstIdent = Trees_Left(identList); + + Indent(file, indent); + GenerateStorageClassSpecifier(firstIdent, file); + GenerateTypeSpecifier(firstIdent, Trees_Type(firstIdent), file, indent); + fprintf(file, " "); + + do { + ident = Trees_Left(identList); + GenerateDeclarator(ident, file); + + if ((Trees_Kind(firstIdent) == TREES_VARIABLE_KIND) && Trees_Local(firstIdent) && (file != hFile)) { + switch (Trees_Symbol(Types_Structure(Trees_Type(firstIdent)))) { + case ARRAY: + case RECORD: + SearchPointersAndProcedures(Trees_Type(firstIdent), &hasPointer, &hasProcedure); + if (hasPointer || hasProcedure) { + fprintf(file, " = {0}"); + } + break; + case POINTER: + case PROCEDURE: + fprintf(file, " = 0"); + break; + } + } + if (Trees_Right(identList) != NULL) { + fprintf(file, ", "); + } + identList = Trees_Right(identList); + } while (identList != NULL); + + fprintf(file, ";\n"); +} + + +static void GenerateTypeIDs(Trees_Node type) +{ + Trees_Node baseType; + + baseType = Types_RecordBaseType(type); + if (baseType != NULL) { + GenerateTypeIDs(baseType); + fprintf(cFile, ", "); + } + fprintf(cFile, "&"); + Generate(TypeDescIdent(type), cFile, 0); + fprintf(cFile, "id"); +} + + +static void GenerateHeapTypeDecl(Trees_Node typeIdent, FILE* file, int indent) +{ + Indent(file, indent); + fprintf(file, "struct "); + Generate(typeIdent, file, 0); + fprintf(file, "Heap {\n"); + Indent(file, indent + 1); + fprintf(file, "const OBNC_Td *td;\n"); + Indent(file, indent + 1); + fprintf(file, "struct "); + Generate(typeIdent, file, 0); + Indent(file, indent); + fprintf(file, " fields;\n"); + Indent(file, indent); + fprintf(file, "};\n"); +} + + +static void GenerateTypeDescDecl(Trees_Node typeIdent, int indent) +{ + int extensionLevel; + Trees_Node identList; + const char *storageClass; + + + /*generate type descriptor (type ID used for its unique address only)*/ + extensionLevel = Types_ExtensionLevel(typeIdent); + if (ModulePrefixNeeded(typeIdent)) { + identList = Trees_NewNode(TREES_NOSYM, typeIdent, NULL); + + fprintf(hFile, "\n"); + GenerateObjectFileSymbolDefinitions(identList, "id", hFile, 0); + Indent(hFile, indent); + fprintf(hFile, "extern const int "); + Generate(typeIdent, hFile, 0); + fprintf(hFile, "id;\n\n"); + + GenerateObjectFileSymbolDefinitions(identList, "ids", hFile, 0); + Indent(hFile, indent); + fprintf(hFile, "extern const int *const "); + Generate(typeIdent, hFile, 0); + fprintf(hFile, "ids[%d];\n\n", extensionLevel + 1); + + GenerateObjectFileSymbolDefinitions(identList, "td", hFile, 0); + Indent(hFile, indent); + fprintf(hFile, "extern const OBNC_Td "); + Generate(typeIdent, hFile, 0); + fprintf(hFile, "td;\n"); + + storageClass = ""; + } else { + storageClass = "static "; + } + fprintf(cFile, "\n"); + Indent(cFile, indent); + fprintf(cFile, "%sconst int ", storageClass); + Generate(typeIdent, cFile, 0); + fprintf(cFile, "id;\n"); + + Indent(cFile, indent); + fprintf(cFile, "%sconst int *const ", storageClass); + Generate(typeIdent, cFile, 0); + fprintf(cFile, "ids[%d] = {", extensionLevel + 1); + GenerateTypeIDs(typeIdent); + fprintf(cFile, "};\n"); + + Indent(cFile, indent); + fprintf(cFile, "%sconst OBNC_Td ", storageClass); + Generate(typeIdent, cFile, 0); + fprintf(cFile, "td = {"); + Generate(typeIdent, cFile, 0); + fprintf(cFile, "ids, %d};\n", extensionLevel + 1); +} + + +void Generate_TypeDeclaration(Trees_Node ident) +{ + int indent = Trees_Local(ident)? 1: 0; + Trees_Node type, declaration, typeDescIdent; + int modulePrefixNeeded; + + assert(initialized); + GenerateInternalDeclarations(TYPE_SECTION); + + type = Trees_Type(ident); + modulePrefixNeeded = ModulePrefixNeeded(ident); + + declaredTypeIdent = ident; + declaration = Trees_NewNode(TREES_NOSYM, ident, type); + if (modulePrefixNeeded) { + fprintf(hFile, "\n"); + GenerateDeclaration(declaration, hFile, indent); + } else { + if (! Trees_Local(ident)) { + fprintf(cFile, "\n"); + } + GenerateDeclaration(declaration, cFile, indent); + } + declaredTypeIdent = NULL; + if ((Trees_Symbol(type) == RECORD) + || ((Trees_Symbol(type) == POINTER) && (Trees_Symbol(Types_PointerBaseType(type)) == RECORD))) { + typeDescIdent = TypeDescIdent(ident); + + if (modulePrefixNeeded) { + fprintf(hFile, "\n"); + GenerateHeapTypeDecl(typeDescIdent, hFile, 0); + } else { + fprintf(cFile, "\n"); + GenerateHeapTypeDecl(typeDescIdent, cFile, indent); + } + GenerateTypeDescDecl(typeDescIdent, indent); + } +} + + +/*VARIABLE DECLARATION GENERATORS*/ + +static int HasExportedIdent(Trees_Node identList) +{ + while ((identList != NULL) && ! Trees_Exported(Trees_Left(identList))) { + identList = Trees_Right(identList); + } + return identList != NULL; +} + + +static int NameEquivalenceNeeded(Trees_Node type) +{ + int result; + + assert(type != NULL); + + switch (Trees_Symbol(type)) { + case ARRAY: + result = NameEquivalenceNeeded(Types_ElementType(type)); + break; + case RECORD: + result = 1; + break; + case POINTER: + result = (Trees_Symbol(Types_PointerBaseType(type)) == RECORD); + break; + default: + result = 0; + } + return result; +} + + +void Generate_VariableDeclaration(Trees_Node identList) +{ + static int typeCounter; + + const char *newTypeName; + int allExported; + Trees_Node ident, type, declaration, newTypeIdent, newTypeDecl, p, exportedIdents, nonExportedIdents, exportedDecl, nonExportedDecl; + int indent; + + assert(initialized); + GenerateInternalDeclarations(VAR_SECTION); + + ident = Trees_Left(identList); + indent = Trees_Local(ident)? 1: 0; + type = Trees_Type(ident); + declaration = Trees_NewNode(TREES_NOSYM, identList, type); + if (! Trees_Local(ident)) { + fprintf(cFile, "\n"); + } + if (HasExportedIdent(identList) && ! isEntryPointModule) { + fprintf(hFile, "\n"); + if (NameEquivalenceNeeded(type)) { + /*declare anonymous type in header file*/ + newTypeName = Util_String("%s_T%d", inputModuleName, typeCounter); + + newTypeIdent = Trees_NewIdent(newTypeName); + Trees_SetKind(TREES_TYPE_KIND, newTypeIdent); + Trees_SetType(type, newTypeIdent); + Trees_SetInternal(newTypeIdent); + newTypeDecl = Trees_NewNode(TREES_NOSYM, newTypeIdent, type); + + GenerateDeclaration(newTypeDecl, hFile, indent); + + /*replace anonymous type with named type*/ + p = identList; + do { + ident = Trees_Left(p); + Trees_SetType(newTypeIdent, ident); + p = Trees_Right(p); + } while (p != NULL); + + typeCounter++; + } + + allExported = 1; + p = identList; + do { + ident = Trees_Left(p); + if (! Trees_Exported(ident)) { + allExported = 0; + } + p = Trees_Right(p); + } while ((p != NULL) && allExported); + + if (allExported) { + GenerateObjectFileSymbolDefinitions(identList, "", hFile, indent); + GenerateDeclaration(declaration, hFile, indent); + GenerateDeclaration(declaration, cFile, indent); + } else { + exportedIdents = NULL; + nonExportedIdents = NULL; + p = identList; + do { + ident = Trees_Left(p); + if (Trees_Exported(ident)) { + exportedIdents = Trees_NewNode(TREES_IDENT_LIST, ident, exportedIdents); + } else { + nonExportedIdents = Trees_NewNode(TREES_IDENT_LIST, ident, nonExportedIdents); + } + p = Trees_Right(p); + } while (p != NULL); + assert(exportedIdents != NULL); + Trees_ReverseList(&exportedIdents); + exportedDecl = Trees_NewNode(TREES_NOSYM, exportedIdents, Trees_Right(declaration)); + GenerateObjectFileSymbolDefinitions(exportedIdents, "", hFile, indent); + GenerateDeclaration(exportedDecl, hFile, indent); + GenerateDeclaration(exportedDecl, cFile, indent); + if (nonExportedIdents != NULL) { + Trees_ReverseList(&nonExportedIdents); + nonExportedDecl = Trees_NewNode(TREES_NOSYM, nonExportedIdents, Trees_Right(declaration)); + GenerateDeclaration(nonExportedDecl, cFile, indent); + } + } + + if (Trees_Symbol(type) != IDENT) { + /*reset original type*/ + p = identList; + do { + ident = Trees_Left(p); + Trees_SetType(type, ident); + p = Trees_Right(p); + } while (p != NULL); + } + } else { + GenerateDeclaration(declaration, cFile, indent); + } +} + + +/*EXPRESSION GENERATORS*/ + +static Trees_Node NextSelector(Trees_Node var) +{ + return Trees_Right(var); +} + + +static Trees_Node PrevSelector(Trees_Node var, Trees_Node selector) +{ + Trees_Node p; + + assert(Trees_Symbol(var) == TREES_DESIGNATOR); + assert(selector != NULL); + + p = Trees_Right(var); + while ((p != NULL) && (NextSelector(p) != selector)) { + p = NextSelector(p); + } + return p; +} + + +static int IsVarParam(Trees_Node var) +{ + return (Trees_Kind(EntireVar(var)) == TREES_VAR_PARAM_KIND) + && ((NextSelector(var) == NULL) + || ((Trees_Symbol(NextSelector(var)) == '(') && (NextSelector(NextSelector(var)) == NULL))); +} + + +static int IsProcedureCall(int symbol) +{ + int result; + + switch (symbol) { + case TREES_ABS_PROC: + case TREES_ODD_PROC: + case TREES_LEN_PROC: + case TREES_LSL_PROC: + case TREES_ASR_PROC: + case TREES_ROR_PROC: + case TREES_FLOOR_PROC: + case TREES_FLT_PROC: + case TREES_ORD_PROC: + case TREES_CHR_PROC: + case TREES_INC_PROC: + case TREES_DEC_PROC: + case TREES_INCL_PROC: + case TREES_EXCL_PROC: + /*case TREES_NEW_PROC*/ + case TREES_ASSERT_PROC: + case TREES_PACK_PROC: + case TREES_UNPK_PROC: + case TREES_ADR_PROC: + case TREES_SIZE_PROC: + case TREES_BIT_PROC: + case TREES_GET_PROC: + case TREES_PUT_PROC: + case TREES_COPY_PROC: + case TREES_VAL_PROC: + case TREES_PROCEDURE_CALL: + result = 1; + break; + default: + result = 0; + } + return result; +} + + +static void PrintCOperator(Trees_Node opNode, FILE *file) +{ + int leftType, rightType; + + leftType = Trees_Symbol(Types_Structure(Trees_Type(Trees_Left(opNode)))); + if (Trees_Right(opNode) != NULL) { + rightType = Trees_Symbol(Types_Structure(Trees_Type(Trees_Right(opNode)))); + } else { + rightType = -1; + } + + switch (Trees_Symbol(opNode)) { + case '#': + fprintf(file, "!="); + break; + case '&': + fprintf(file, "&&"); + break; + case '*': + if (leftType == TREES_SET_TYPE) { + fprintf(file, "&"); + } else { + fprintf(file, "*"); + } + break; + case '+': + if ((leftType == TREES_SET_TYPE) && (rightType >= 0)) { + fprintf(file, "|"); + } else { + fprintf(file, "+"); + } + break; + case '-': + if (leftType == TREES_SET_TYPE) { + if (rightType == -1) { + fprintf(file, "~"); + } else { + fprintf(file, "& ~"); + } + } else { + fprintf(file, "-"); + } + break; + case '/': + if (leftType == TREES_SET_TYPE) { + fprintf(file, "^"); + } else { + fprintf(file, "/"); + } + break; + case '<': + fprintf(file, "<"); + break; + case '=': + fprintf(file, "=="); + break; + case '>': + fprintf(file, ">"); + break; + case '~': + fprintf(file, "! "); + break; + case OR: + fprintf(file, "||"); + break; + case GE: + fprintf(file, ">="); + break; + case LE: + fprintf(file, "<="); + break; + default: + assert(0); + } +} + + +static int ArrayDimension(Trees_Node arrayVar) +{ + Trees_Node selector; + int dim; + + assert(Types_IsArray(Trees_Type(arrayVar))); + + dim = 0; + selector = Trees_Right(arrayVar); + while (selector != NULL) { + if (Trees_Symbol(selector) == '[') { + dim++; + } else { + dim = 0; + } + selector = NextSelector(selector); + } + return dim; +} + + +static void GenerateWithPrecedence(Trees_Node exp, FILE *file) +{ + if (Trees_IsLeaf(exp) + || (Trees_Symbol(exp) == TREES_DESIGNATOR) + || IsProcedureCall(Trees_Symbol(exp))) { + Generate(exp, file, 0); + } else { + fprintf(file, "("); + Generate(exp, file, 0); + fprintf(file, ")"); + } +} + + +static int ContainsProcedureCall(Trees_Node exp) +{ + int result; + + result = 0; + if (exp != NULL) { + if (Trees_Symbol(exp) == TREES_PROCEDURE_CALL) { + result = 1; + } else { + result = ContainsProcedureCall(Trees_Left(exp)); + if (result == 0) { + result = ContainsProcedureCall(Trees_Right(exp)); + } + } + } + return result; +} + + +static void GenerateNonScalarOperation(Trees_Node opNode, FILE *file, int indent) +{ + Trees_Node operands[2]; + Trees_Node types[2]; + int i; + + operands[0] = Trees_Left(opNode); + operands[1] = Trees_Right(opNode); + types[0] = Types_Structure(Trees_Type(operands[0])); + types[1] = Types_Structure(Trees_Type(operands[1])); + + switch (Trees_Symbol(opNode)) { + case '=': + case '#': + case '<': + case LE: + case '>': + case GE: + Indent(file, indent); + if (ContainsProcedureCall(operands[0]) || ContainsProcedureCall(operands[1])) { + fprintf(file, "OBNC_Cmp("); + } else { + fprintf(file, "OBNC_CMP("); + } + for (i = 0; i < 2; i++) { + if (i > 0) { + fprintf(file, ", "); + } + if (Types_IsArray(types[i]) && (ArrayDimension(operands[i]) > 0)) { + fprintf(file, "&"); + } + GenerateWithPrecedence(operands[i], file); + fprintf(file, ", "); + if (Trees_Symbol(types[i]) == TREES_STRING_TYPE) { + fprintf(file, "%lu", (long unsigned int) strlen(Trees_String(operands[i])) + 1); + } else { + GenerateArrayLength(types[i], EntireVar(operands[i]), ArrayDimension(operands[i]), file); + } + } + fprintf(file, ") "); + PrintCOperator(opNode, file); + fprintf(file, " 0"); + break; + default: + assert(0); + } +} + + +static Trees_Node LastSelector(Trees_Node var) +{ + Trees_Node result; + + assert(var != NULL); + assert(Trees_Symbol(var) == TREES_DESIGNATOR); + + result = Trees_Right(var); + while ((result != NULL) && (Trees_Right(result) != NULL)) { + result = Trees_Right(result); + } + return result; +} + + +static void GenerateTypeDescExp(Trees_Node var, FILE *file, int indent) +{ + Trees_Node type, lastSelector; + + type = Trees_Type(var); + lastSelector = LastSelector(var); + if (Types_IsPointer(type)) { + fprintf(file, "OBNC_TD("); + Generate(var, file, 0); + fprintf(file, ", struct "); + Generate(TypeDescIdent(type), file, 0); + fprintf(file, "Heap)"); + } else if ((lastSelector != NULL) && Types_IsPointer(Trees_Type(lastSelector))) { + fprintf(file, "OBNC_TD(&("); + Generate(var, file, 0); + fprintf(file, "), struct "); + Generate(TypeDescIdent(type), file, 0); + fprintf(file, "Heap)"); + } else { + assert(Types_IsRecord(type)); + if (IsVarParam(var)) { + GenerateIdent(EntireVar(var), file, indent); + fprintf(file, "td"); + } else { + fprintf(file, "&"); + GenerateIdent(TypeDescIdent(type), file, 0); + fprintf(file, "td"); + } + } +} + + +static void GenerateISExpression(Trees_Node var, Trees_Node type, FILE *file) +{ + fprintf(file, "OBNC_IS("); + if (Types_IsPointer(Trees_Type(var))) { + Generate(var, file, 0); + } else { + fprintf(file, "&("); + Generate(var, file, 0); + fprintf(file, ")"); + } + fprintf(file, ", "); + GenerateTypeDescExp(var, file, 0); + fprintf(file, ", &"); + Generate(TypeDescIdent(type), file, 0); + fprintf(file, "id, %d)", Types_ExtensionLevel(type)); +} + + +static void GenerateOperator(Trees_Node opNode, FILE *file) +{ + Trees_Node leftOperand, rightOperand, leftType, rightType; + int opSym; + + leftOperand = Trees_Left(opNode); + rightOperand = Trees_Right(opNode); + opSym = Trees_Symbol(opNode); + + if (Trees_Right(opNode) == NULL) { + /*unary operator*/ + PrintCOperator(opNode, file); + GenerateWithPrecedence(leftOperand, file); + } else { + /*binary operator*/ + leftType = Trees_Type(leftOperand); + rightType = Trees_Type(rightOperand); + + if ((Types_IsString(leftType) || Types_IsCharacterArray(leftType)) + && (Types_IsString(rightType) || Types_IsCharacterArray(rightType))) { + GenerateNonScalarOperation(opNode, file, 0); + } else { + switch (opSym) { + case DIV: + case MOD: + if (opSym == DIV) { + if (ContainsProcedureCall(leftOperand) || ContainsProcedureCall(rightOperand)) { + fprintf(file, "OBNC_Div("); + } else { + fprintf(file, "OBNC_DIV("); + } + } else { + if (ContainsProcedureCall(leftOperand) || ContainsProcedureCall(rightOperand)) { + fprintf(file, "OBNC_Mod("); + } else { + fprintf(file, "OBNC_MOD("); + } + } + Generate(leftOperand, file, 0); + fprintf(file, ", "); + Generate(rightOperand, file, 0); + fprintf(file, ")"); + break; + case '<': + case LE: + case '>': + case GE: + if (Types_IsChar(Trees_Type(leftOperand))) { + fprintf(file, "(unsigned char) "); + } + GenerateWithPrecedence(leftOperand, file); + fprintf(file, " "); + PrintCOperator(opNode, file); + fprintf(file, " "); + if (Types_IsChar(Trees_Type(rightOperand))) { + fprintf(file, "(unsigned char) "); + } + GenerateWithPrecedence(rightOperand, file); + break; + default: + if (Types_IsPointer(leftType) && (Trees_Symbol(leftOperand) != NIL) && ! Types_Same(leftType, rightType) && (Trees_Symbol(rightOperand) != NIL)) { + if (Types_Extends(leftType, rightType)) { + GenerateWithPrecedence(leftOperand, file); + fprintf(file, " "); + PrintCOperator(opNode, file); + fprintf(file, " ("); + Generate(leftType, file, 0); + fprintf(file, ") "); + GenerateWithPrecedence(rightOperand, file); + } else { + fprintf(file, "("); + Generate(rightType, file, 0); + fprintf(file, ") "); + GenerateWithPrecedence(leftOperand, file); + fprintf(file, " "); + PrintCOperator(opNode, file); + fprintf(file, " "); + GenerateWithPrecedence(rightOperand, file); + } + } else { + GenerateWithPrecedence(leftOperand, file); + fprintf(file, " "); + PrintCOperator(opNode, file); + fprintf(file, " "); + GenerateWithPrecedence(rightOperand, file); + } + } + } + } +} + + +static int IsConstExpression(Trees_Node exp) +{ + int result; + + result = 0; + switch (Trees_Symbol(exp)) { + case TRUE: + case FALSE: + case STRING: + case INTEGER: + case REAL: + case TREES_SET_CONSTANT: + result = 1; + } + return result; +} + + +static void GenerateArrayIndex(Trees_Node var, Trees_Node indexSelector, FILE *file) +{ + Trees_Node arrayType, indexExp, selector, currArrayType, currArrayType1; + int trapNeeded, dim, dim1; + + arrayType = Trees_Type(indexSelector); + assert(Types_IsArray(arrayType)); + + selector = indexSelector; + currArrayType = arrayType; + dim = 0; + do { + if (dim > 0) { + fprintf(file, " + "); + } + indexExp = Trees_Left(selector); + trapNeeded = Types_IsOpenArray(arrayType) || ! IsConstExpression(indexExp); + if (trapNeeded) { + if (ContainsProcedureCall(indexExp)) { + fprintf(file, "OBNC_IT1("); + } else { + fprintf(file, "OBNC_IT("); + } + } + Generate(indexExp, file, 0); + if (trapNeeded) { + fprintf(file, ", "); + GenerateArrayLength(currArrayType, EntireVar(var), dim, file); + fprintf(file, ", %d)", Trees_LineNumber(indexExp)); + } + currArrayType1 = Types_ElementType(currArrayType); + dim1 = dim + 1; + while ((currArrayType1 != NULL) && Types_IsArray(currArrayType1)) { + fprintf(file, " * "); + GenerateArrayLength(currArrayType1, EntireVar(var), dim1, file); + currArrayType1 = Types_ElementType(currArrayType1); + dim1++; + } + selector = NextSelector(selector); + currArrayType = Types_ElementType(currArrayType); + dim++; + } while ((selector != NULL) && (Trees_Symbol(selector) == '[')); +} + + +static void GenerateDesignatorVar(Trees_Node ident, FILE *file) +{ + int identKind, paramDerefNeeded; + Trees_Node identType; + + identKind = Trees_Kind(ident); + identType = Trees_Type(ident); + paramDerefNeeded = ((identKind == TREES_VALUE_PARAM_KIND) && Types_IsRecord(identType)) + || ((identKind == TREES_VAR_PARAM_KIND) && ! Types_IsArray(identType)); + + if (paramDerefNeeded) { + fprintf(file, "(*"); + Generate(ident, file, 0); + fprintf(file, ")"); + } else { + Generate(ident, file, 0); + } +} + + +static void GenerateDesignatorRec(Trees_Node des, Trees_Node selector, FILE *file) +{ + Trees_Node field, fieldIdent, fieldBaseType, typeIdent, prevSelector, firstDimSelector; + int castNeeded; + + if (selector == NULL) { + if ((caseVariable != NULL) && (caseLabelType != NULL) && (EntireVar(des) == caseVariable) && ! Types_Same(Trees_Type(caseVariable), caseLabelType)) { + fprintf(file, "(*(("); + Generate(caseLabelType, file, 0); + fprintf(file, " *) &"); + GenerateDesignatorVar(EntireVar(des), file); + fprintf(file, "))"); + } else { + GenerateDesignatorVar(EntireVar(des), file); + } + } else { + switch (Trees_Symbol(selector)) { + case '[': + firstDimSelector = selector; + prevSelector = PrevSelector(des, selector); + while ((prevSelector != NULL) && (Trees_Symbol(prevSelector) == '[')) { + firstDimSelector = prevSelector; + prevSelector = PrevSelector(des, prevSelector); + } + GenerateDesignatorRec(des, prevSelector, file); + fprintf(file, "["); + GenerateArrayIndex(des, firstDimSelector, file); + fprintf(file, "]"); + break; + case '.': + field = Trees_Left(selector); + Types_GetFieldIdent(Trees_Name(field), Trees_Type(selector), Trees_Imported(EntireVar(des)), &fieldIdent, &fieldBaseType); + castNeeded = ! Types_Same(fieldBaseType, Trees_Type(selector)); + if (castNeeded) { + fprintf(file, "(*(("); + Generate(fieldBaseType, file, 0); + if (Types_IsRecord(fieldBaseType)) { + fprintf(file, " *"); + } + fprintf(file, ") &"); + } + GenerateDesignatorRec(des, PrevSelector(des, selector), file); + if (castNeeded) { + fprintf(file, "))"); + } + fprintf(file, "."); + Generate(Trees_Left(selector), file, 0); + break; + case '^': + fprintf(file, "(*OBNC_PT("); + GenerateDesignatorRec(des, PrevSelector(des, selector), file); + fprintf(file, ", %d))", Trees_LineNumber(des)); + break; + case '(': + typeIdent = Trees_Left(selector); + + fprintf(file, "(*(("); + Generate(typeIdent, file, 0); + if (Types_IsRecord(typeIdent)) { + fprintf(file, "*) OBNC_RTT(&("); + } else { + fprintf(file, "*) OBNC_PTT(&("); + } + GenerateDesignatorRec(des, PrevSelector(des, selector), file); + fprintf(file, "), "); + if (Types_IsRecord(typeIdent)) { + if ((Trees_Kind(EntireVar(des)) == TREES_VAR_PARAM_KIND) && (selector == NextSelector(des))) { + GenerateIdent(EntireVar(des), file, 0); + fprintf(file, "td"); + } else { + fprintf(file, "&"); + GenerateIdent(TypeDescIdent(Trees_Type(selector)), file, 0); + fprintf(file, "td"); + } + } else { + assert(Types_IsPointer(typeIdent)); + fprintf(file, "OBNC_TD("); + GenerateDesignatorRec(des, PrevSelector(des, selector), file); + fprintf(file, ", struct "); + Generate(TypeDescIdent(Trees_Type(selector)), file, 0); + fprintf(file, "Heap)"); + } + fprintf(file, ", &"); + Generate(TypeDescIdent(typeIdent), file, 0); + fprintf(file, "id, %d, %d)))", Types_ExtensionLevel(typeIdent), Trees_LineNumber(des)); + break; + default: + assert(0); + } + } +} + + +static void GenerateDesignator(Trees_Node des, FILE *file) +{ + GenerateDesignatorRec(des, LastSelector(des), file); +} + + +static void GenerateSingleElementSet(Trees_Node node, FILE *file) +{ + fprintf(file, "(0x1u << "); + GenerateWithPrecedence(Trees_Left(node), file); + fprintf(file, ")"); +} + + +static void GenerateRangeSet(Trees_Node node, FILE *file) +{ + Trees_Node low = Trees_Left(node); + Trees_Node high = Trees_Right(node); + + if (ContainsProcedureCall(low) || ContainsProcedureCall(high)) { + fprintf(file, "OBNC_Range("); + } else { + fprintf(file, "OBNC_RANGE("); + } + Generate(low, file, 0); + fprintf(file, ", "); + Generate(high, file, 0); + fprintf(file, ")"); +} + + +static void GenerateExpList(Trees_Node expList, FILE *file) +{ + Trees_Node exp, tail; + + exp = Trees_Left(expList); + Generate(exp, file, 0); + tail = Trees_Right(expList); + if (tail != NULL) { + fprintf(file, ", "); + Generate(tail, file, 0); + } +} + + +/*STATEMENT GENERATORS*/ + +static void GenerateArrayAssignment(Trees_Node source, Trees_Node target, FILE *file, int indent) +{ + Trees_Node sourceType, targetType; + + assert(Trees_Symbol(target) == TREES_DESIGNATOR); + + sourceType = Trees_Type(source); + targetType = Types_Structure(Trees_Type(target)); + assert(Trees_Symbol(targetType) == ARRAY); + + if (Types_IsOpenArray(sourceType) || Types_IsOpenArray(targetType)) { + Indent(file, indent); + fprintf(file, "OBNC_AAT("); + if (Trees_Symbol(source) == STRING) { + fprintf(file, "%lu", (long unsigned int) strlen(Trees_String(source)) + 1); + } else { + GenerateArrayLength(sourceType, EntireVar(source), ArrayDimension(source), file); + } + fprintf(file, ", "); + GenerateArrayLength(targetType, EntireVar(target), ArrayDimension(target), file); + fprintf(file, ", %d);\n", Trees_LineNumber(target)); + } + Indent(file, indent); + fprintf(file, "OBNC_COPY_ARRAY("); + if (Types_IsArray(sourceType) && (ArrayDimension(source) > 0)) { + fprintf(file, "&"); + } + GenerateWithPrecedence(source, file); + fprintf(file, ", "); + if (Types_IsArray(targetType) && (ArrayDimension(target) > 0)) { + fprintf(file, "&"); + } + GenerateWithPrecedence(target, file); + fprintf(file, ", "); + if (Trees_Symbol(source) == STRING) { + fprintf(file, "%lu", (long unsigned int) strlen(Trees_String(source)) + 1); + } else { + GenerateFlattenedArrayLength(sourceType, EntireVar(source), ArrayDimension(source), file); + } + fprintf(file, ");\n"); +} + + +static void GenerateRecordAssignment(Trees_Node source, Trees_Node target, FILE *file, int indent) +{ + Trees_Node sourceType, targetType; + + sourceType = Trees_Type(source); + targetType = Trees_Type(target); + + Indent(file, indent); + if (IsVarParam(target)) { + fprintf(file, "OBNC_RAT("); + GenerateTypeDescExp(source, file, 0); + fprintf(file, ", "); + GenerateTypeDescExp(target, file, 0); + fprintf(file, ", %d);\n", Trees_LineNumber(target)); + } + if (Types_Same(sourceType, targetType) && ! IsVarParam(target)) { + GenerateDesignator(target, file); + fprintf(file, " = "); + Generate(source, file, 0); + fprintf(file, ";\n"); + } else { + Generate(target, file, 0); + fprintf(file, " = "); + if (! Types_Same(sourceType, targetType)) { + assert(Types_Extends(targetType, sourceType)); + fprintf(file, "*("); + Generate(targetType, file, 0); + fprintf(file, " *) &"); + } + Generate(source, file, 0); + fprintf(file, ";\n"); + } +} + + +static int CastNeeded(Trees_Node sourceType, Trees_Node targetType) +{ + return (Types_IsByte(targetType) && ! Types_IsByte(sourceType)) + || ((Types_IsRecord(targetType) || Types_IsPointer(targetType)) + && (Trees_Symbol(sourceType) != TREES_NIL_TYPE) + && Types_Extends(targetType, sourceType) + && ! Types_Same(targetType, sourceType)); +} + + +static void GenerateAssignment(Trees_Node becomesNode, FILE *file, int indent) +{ + Trees_Node source, target; + Trees_Node sourceType, targetType; + + source = Trees_Right(becomesNode); + target = Trees_Left(becomesNode); + sourceType = Trees_Type(source); + targetType = Trees_Type(target); + + switch (Trees_Symbol(Types_Structure(targetType))) { + case ARRAY: + GenerateArrayAssignment(source, target, file, indent); + break; + case RECORD: + GenerateRecordAssignment(source, target, file, indent); + break; + default: + Indent(file, indent); + GenerateDesignator(target, file); + fprintf(file, " = "); + if (CastNeeded(sourceType, targetType)) { + fprintf(file, "("); + Generate(targetType, file, 0); + fprintf(file, ") "); + GenerateWithPrecedence(source, file); + } else { + Generate(source, file, 0); + } + fprintf(file, ";\n"); + } +} + + +static void GenerateProcedureCall(Trees_Node call, FILE *file, int indent) +{ + Trees_Node designator, designatorTypeStruct, expList, fpList, fpType, exp, expType, resultType, componentFPType, componentExpType; + int procKind, isProcVar, isValueParam, isVarParam, dim; + + designator = Trees_Left(call); + designatorTypeStruct = Types_Structure(Trees_Type(designator)); + procKind = Trees_Kind(Trees_Left(designator)); + assert(Types_IsProcedure(designatorTypeStruct)); + resultType = Types_ResultType(designatorTypeStruct); + isProcVar = procKind != TREES_PROCEDURE_KIND; + + Indent(file, indent); + if (isProcVar) { + fprintf(file, "OBNC_PCT("); + Generate(designator, file, 0); + fprintf(file, ", %d)", Trees_LineNumber(designator)); + } else { + Generate(designator, file, 0); + } + + fprintf(file, "("); + + expList = Trees_Right(call); + fpList = Types_Parameters(designatorTypeStruct); + while (expList != NULL) { + assert(fpList != NULL); + exp = Trees_Left(expList); + expType = Trees_Type(exp); + isValueParam = Trees_Kind(Trees_Left(fpList)) == TREES_VALUE_PARAM_KIND; + isVarParam = Trees_Kind(Trees_Left(fpList)) == TREES_VAR_PARAM_KIND; + fpType = Trees_Type(Trees_Left(fpList)); + + if (CastNeeded(expType, fpType)) { + fprintf(file, "("); + Generate(fpType, file, 0); + if ((isVarParam && ! Types_IsArray(fpType)) || Types_IsRecord(fpType)) { + fprintf(file, " *"); + } + fprintf(file, ") "); + } + if ((Types_IsArray(expType) && (ArrayDimension(exp) > 0)) + || (isValueParam && Types_IsRecord(fpType)) + || (isVarParam && ! Types_IsArray(fpType))) { + fprintf(file, "&"); + } + GenerateWithPrecedence(exp, file); + + /*additional type info parameters*/ + if (Types_IsOpenArray(fpType)) { + if (Trees_Symbol(exp) == STRING) { + fprintf(file, ", %lu", (long unsigned int) strlen(Trees_String(exp)) + 1); + } else { + componentFPType = fpType; + componentExpType = expType; + dim = ArrayDimension(exp); + do { + fprintf(file, ", "); + GenerateArrayLength(componentExpType, EntireVar(exp), dim, file); + componentFPType = Types_ElementType(componentFPType); + componentExpType = Types_ElementType(componentExpType); + dim++; + } while (Types_IsArray(componentFPType)); + } + } else if (isVarParam && Types_IsRecord(fpType)) { + fprintf(file, ", "); + GenerateTypeDescExp(exp, file, 0); + } + + if (Trees_Right(expList) != NULL) { + fprintf(file, ", "); + } + expList = Trees_Right(expList); + fpList = Trees_Right(fpList); + } + + fprintf(file, ")"); + if (resultType == NULL) { + fprintf(file, ";\n"); + } +} + + +static void GenerateAssert(Trees_Node node, FILE *file, int indent) +{ + Trees_Node exp; + + exp = Trees_Left(node); + Indent(file, indent); + fprintf(file, "OBNC_ASSERT("); + Generate(exp, file, 0); + fprintf(file, ", \"%s\", %d);\n", Paths_Basename(inputFilename), Trees_LineNumber(exp)); +} + + +static void GenerateIntegralCaseStatement(Trees_Node caseStmtNode, FILE *file, int indent) +{ + Trees_Node expNode, currCaseRepNode, currCaseNode, currCaseLabelListNode, currStmtSeqNode, currLabelRangeNode; + OBNC_INTEGER rangeMin, rangeMax, label; + + expNode = Trees_Left(caseStmtNode); + + Indent(file, indent); + fprintf(file, "switch ("); + Generate(expNode, file, 0); + fprintf(file, ") {\n"); + currCaseRepNode = Trees_Right(caseStmtNode); + while (currCaseRepNode != NULL) { + currCaseNode = Trees_Left(currCaseRepNode); + currStmtSeqNode = Trees_Right(currCaseNode); + + /*generate case labels for current case*/ + currCaseLabelListNode = Trees_Left(currCaseNode); + do { + currLabelRangeNode = Trees_Left(currCaseLabelListNode); + if (Trees_Right(currLabelRangeNode) == NULL) { + /*generate single label*/ + Indent(file, indent + 1); + fprintf(file, "case "); + Generate(currLabelRangeNode, file, 0); + fprintf(file, ":\n"); + } else { + /*generate label range*/ + if (Trees_Symbol(Trees_Left(currLabelRangeNode)) == INTEGER) { + rangeMin = Trees_Integer(Trees_Left(currLabelRangeNode)); + rangeMax = Trees_Integer(Trees_Right(currLabelRangeNode)); + for (label = rangeMin; label <= rangeMax; label++) { + Indent(file, indent + 1); + fprintf(file, "case %" OBNC_INT_MOD "d:\n", label); + } + } else { + rangeMin = Trees_Char(Trees_Left(currLabelRangeNode)); + rangeMax = Trees_Char(Trees_Right(currLabelRangeNode)); + for (label = rangeMin; label <= rangeMax; label++) { + Indent(file, indent + 1); + fprintf(file, "case "); + assert(label >= CHAR_MIN); + assert(label <= CHAR_MAX); + GenerateChar((char) label, file); + fprintf(file, ":\n"); + } + } + } + currCaseLabelListNode = Trees_Right(currCaseLabelListNode); + } while (currCaseLabelListNode != NULL); + + /*generate statement sequence for current case*/ + Generate(currStmtSeqNode, file, indent + 2); + Indent(file, indent + 2); + fprintf(file, "break;\n"); + + currCaseRepNode = Trees_Right(currCaseRepNode); + } + Indent(file, indent + 1); + fprintf(file, "default:\n"); + Indent(file, indent + 2); + fprintf(file, "OBNC_CT(%d);\n", Trees_LineNumber(expNode)); + Indent(file, indent); + fprintf(file, "}\n"); +} + + +static void GenerateTypeCaseStatement(Trees_Node caseStmtNode, FILE *file, int indent) +{ + Trees_Node caseExp, caseList, caseNode, label, statementSeq; + int caseNumber; + + caseExp = Trees_Left(caseStmtNode); + assert(Trees_Symbol(caseExp) == TREES_DESIGNATOR); + caseVariable = Trees_Left(caseExp); + + caseList = Trees_Right(caseStmtNode); + caseNumber = 0; + while (caseList != NULL) { + caseNode = Trees_Left(caseList); + label = Trees_Left(Trees_Left(caseNode)); + statementSeq = Trees_Right(caseNode); + + if (caseNumber == 0) { + Indent(file, indent); + fprintf(file, "if ("); + } else { + fprintf(file, " else if ("); + } + GenerateISExpression(caseExp, label, file); + fprintf(file, ") {\n"); + caseLabelType = label; + Generate(statementSeq, file, indent + 1); + caseLabelType = NULL; + Indent(file, indent); + fprintf(file, "}"); + caseList = Trees_Right(caseList); + if (caseList == NULL) { + fprintf(file, "\n"); + } + caseNumber++; + } + + caseVariable = NULL; +} + + +static void GenerateCaseStatement(Trees_Node caseStmtNode, FILE *file, int indent) +{ + Trees_Node expNode, expType; + + expNode = Trees_Left(caseStmtNode); + expType = Trees_Type(expNode); + if (Types_IsInteger(expType) || Types_IsChar(expType)) { + GenerateIntegralCaseStatement(caseStmtNode, file, indent); + } else { + GenerateTypeCaseStatement(caseStmtNode, file, indent); + } +} + + +static void GenerateWhileStatement(Trees_Node whileNode, FILE *file, int indent) +{ + Trees_Node expNode, doNode, stmtSeqNode, elsifNode; + + expNode = Trees_Left(whileNode); + doNode = Trees_Right(whileNode); + stmtSeqNode = Trees_Left(doNode); + elsifNode = Trees_Right(doNode); + if (elsifNode == NULL) { + Indent(file, indent); + fprintf(file, "while ("); + Generate(expNode, file, 0); + fprintf(file, ") {\n"); + Generate(stmtSeqNode, file, indent + 1); + Indent(file, indent); + fprintf(file, "}\n"); + } else { + Indent(file, indent); + fprintf(file, "while (1) {\n"); + Indent(file, indent + 1); + fprintf(file, "if ("); + Generate(expNode, file, 0); + fprintf(file, ") {\n"); + Generate(stmtSeqNode, file, indent + 2); + Indent(file, indent + 1); + fprintf(file, "}\n"); + Generate(elsifNode, file, indent + 1); + Indent(file, indent + 1); + fprintf(file, "else {\n"); + Indent(file, indent + 2); + fprintf(file, "break;\n"); + Indent(file, indent + 1); + fprintf(file, "}\n"); + Indent(file, indent); + fprintf(file, "}\n"); + } +} + + +static void GenerateForStatement(Trees_Node forNode, FILE *file, int indent) +{ + Trees_Node initNode, controlVarNode, toNode, limit, byNode, statementSeq; + OBNC_INTEGER inc; + + initNode = Trees_Left(forNode); + controlVarNode = Trees_Left(initNode); + toNode = Trees_Right(forNode); + limit = Trees_Left(toNode); + byNode = Trees_Right(toNode); + inc = Trees_Integer(Trees_Left(byNode)); + assert(inc != 0); + statementSeq = Trees_Right(byNode); + + Indent(file, indent); + fprintf(file, "for ("); + Generate(controlVarNode, file, 0); + fprintf(file, " = "); + Generate(Trees_Right(initNode), file, 0); + fprintf(file, "; "); + Generate(controlVarNode, file, 0); + if (inc > 0) { + fprintf(file, " <= "); + } else { + fprintf(file, " >= "); + } + Generate(limit, file, 0); + fprintf(file, "; "); + Generate(controlVarNode, file, 0); + fprintf(file, " += %" OBNC_INT_MOD "d) {\n", inc); + Generate(statementSeq, file, indent + 1); + Indent(file, indent); + fprintf(file, "}\n"); +} + + +static void GenerateMemoryAllocation(Trees_Node var, FILE *file, int indent) +{ + Trees_Node type; + int hasPointer, hasProcedure; + const char *allocKind; + + assert(var != NULL); + assert(Trees_Symbol(var) == TREES_DESIGNATOR); + + type = Trees_Type(var); + SearchPointersAndProcedures(Types_PointerBaseType(type), &hasPointer, &hasProcedure); + allocKind = "OBNC_ATOMIC_NOINIT_ALLOC"; + if (hasPointer) { + allocKind = "OBNC_REGULAR_ALLOC"; + } else if (hasProcedure) { + allocKind = "OBNC_ATOMIC_ALLOC"; + } + if ((Trees_Symbol(type) == IDENT) || (Trees_Symbol(Types_PointerBaseType(type)) == IDENT)) { + Indent(file, indent); + fprintf(file, "OBNC_NEW("); + Generate(var, file, 0); + fprintf(file, ", &"); + Generate(TypeDescIdent(type), file, 0); + fprintf(file, "td, struct "); + Generate(TypeDescIdent(type), file, 0); + fprintf(file, "Heap, %s);\n", allocKind); + } else { + Indent(file, indent); + fprintf(file, "OBNC_NEW_ANON("); + Generate(var, file, 0); + fprintf(file, ", %s);\n", allocKind); + } +} + + +/*PROCEDURE DECLARATION GENERATORS*/ + +static void CopyText(FILE *source, long int pos, int count, FILE *target) +{ + long int oldPos; + int i, ch; + + assert(source != NULL); + assert(pos >= 0); + assert(count >= 0); + assert(target != NULL); + + oldPos = ftell(source); + if (oldPos >= 0) { + fseek(source, pos, SEEK_SET); + if (! ferror(source)) { + i = 0; + ch = fgetc(source); + while ((i < count) && (ch != EOF)) { + fputc(ch, target); + i++; + ch = fgetc(source); + } + } + fseek(source, oldPos, SEEK_SET); + } + + if (ferror(source) || ferror(target)) { + fprintf(stderr, "obnc-compile: copying text failed: %s\n", strerror(errno)); + exit(EXIT_FAILURE); + } +} + + +static void ReadText(FILE *fp, long int startPos, long int endPos, char result[], int resultLen) +{ + long int oldPos; + int i, ch; + + assert(startPos >= 0); + assert(startPos <= endPos); + assert(resultLen > 0); + + oldPos = ftell(fp); + if (oldPos >= 0) { + fseek(fp, startPos, SEEK_SET); + if (! ferror(fp)) { + i = 0; + ch = fgetc(fp); + while ((ch != EOF) && (ftell(fp) <= endPos)) { + result[i] = (char) ch; + i++; + ch = fgetc(fp); + } + assert(i < resultLen); + result[i] = '\0'; + fseek(fp, oldPos, SEEK_SET); + } + } + if (ferror(fp)) { + fprintf(stderr, "obnc-compile: reading text failed: %s\n", strerror(errno)); + exit(EXIT_FAILURE); + } +} + + +static void PushProcedureDeclaration(Trees_Node procIdent) +{ + struct ProcedureDeclNode *node; + int generatedLen, isFirstLocalProc, ch; + + NEW(node); + node->procIdent = procIdent; + node->localProcedures = Maps_New(); + node->runtimeInitVars = NULL; + if (Trees_Local(procIdent)) { + /*save unfinished procedure declaration*/ + generatedLen = (int) (ftell(cFile) - procedureDeclStart + 1); + NEW_ARRAY(node->partialDecl, generatedLen); + ReadText(cFile, procedureDeclStart, ftell(cFile), node->partialDecl, generatedLen); + } else { + node->partialDecl = NULL; + } + node->next = procedureDeclStack; + + if (Trees_Local(procIdent)) { + assert(procedureDeclStack != NULL); + isFirstLocalProc = (procedureDeclStack->next == NULL) && Maps_IsEmpty(procedureDeclStack->localProcedures); + Maps_Put(Trees_Name(procIdent), NULL, &(procedureDeclStack->localProcedures)); + + /*set file position for writing local procedure*/ + fseek(cFile, procedureDeclStart, SEEK_SET); + if (! ferror(cFile)) { + if (isFirstLocalProc) { + /*keep function signature for global procedure*/ + do { + ch = fgetc(cFile); + } while ((ch != EOF) && (ch != ')')); + assert(ch == ')'); + fseek(cFile, 0, SEEK_CUR); + fprintf(cFile, ";\n"); + } + } + if (ferror(cFile)) { + fprintf(stderr, "obnc-compile: pushing procedure declaration failed: %s\n", strerror(errno)); + exit(EXIT_FAILURE); + } + } + + procedureDeclStack = node; +} + + +static void PopProcedureDeclaration(void) +{ + assert(procedureDeclStack != NULL); + procedureDeclStart = ftell(cFile); + if (! ferror(cFile)) { + if (procedureDeclStack->partialDecl != NULL) { + fprintf(cFile, "%s", procedureDeclStack->partialDecl); + } + procedureDeclStack = procedureDeclStack->next; + } + if (ferror(cFile)) { + fprintf(stderr, "obnc-compile: popping procedure declaration failed: %s\n", strerror(errno)); + exit(EXIT_FAILURE); + } +} + + +static void GenerateOpenArrayParameter(Trees_Node param, FILE *file) +{ + Trees_Node elementType; + int ndims, i; + + elementType = Types_ElementType(Trees_Type(param)); + ndims = 1; + while (Types_IsArray(elementType)) { + elementType = Types_ElementType(elementType); + ndims++; + } + Generate(elementType, file, 0); + fprintf(file, " "); + Generate(param, file, 0); + fprintf(file, "[]"); + for (i = 0; i < ndims; i++) { + fprintf(file, ", OBNC_INTEGER "); + Generate(param, file, 0); + fprintf(file, "len"); + if (i > 0) { + fprintf(file, "%d", i); + } + } +} + + +static void GenerateFormalParameter(Trees_Node param, FILE *file) +{ + int kind; + Trees_Node type; + + kind = Trees_Kind(param); + type = Trees_Type(param); + if (kind == TREES_VALUE_PARAM_KIND) { + if (Types_IsArray(type) || Types_IsRecord(type)) { + fprintf(file, "const "); + } + if (Types_IsRecord(type) || (type == declaredTypeIdent)) { + fprintf(file, "struct "); + } + if (Types_IsOpenArray(type)) { + GenerateOpenArrayParameter(param, file); + } else { + if (Types_IsRecord(type)) { + Generate(Types_UnaliasedIdent(type), file, 0); + } else { + Generate(type, file, 0); + } + fprintf(file, " "); + if (Types_IsRecord(type) || (type == declaredTypeIdent)) { + fprintf(file, "*"); + } + Generate(param, file, 0); + } + } else { + assert(kind == TREES_VAR_PARAM_KIND); + if (type == declaredTypeIdent) { + fprintf(file, "struct "); + } + if (Types_IsOpenArray(type)) { + GenerateOpenArrayParameter(param, file); + } else { + Generate(type, file, 0); + fprintf(file, " "); + if (! Types_IsArray(type)) { + fprintf(file, "*"); + } + if (Types_IsPointer(type) && (type == declaredTypeIdent)) { + fprintf(file, "*"); + } + Generate(param, file, 0); + if (Types_IsRecord(type)) { + fprintf(file, ", const OBNC_Td *"); + Generate(param, file, 0); + fprintf(file, "td"); + } + } + } +} + + +static void GenerateFormalParameterList(Trees_Node paramList, FILE *file) +{ + Trees_Node param; + + assert(paramList != NULL); + + do { + param = Trees_Left(paramList); + GenerateFormalParameter(param, file); + if (Trees_Right(paramList) != NULL) { + fprintf(file, ", "); + } + paramList = Trees_Right(paramList); + } while (paramList != NULL); +} + + +void Generate_ProcedureHeading(Trees_Node procIdent) +{ + Trees_Node procType, resultType, paramList; + + assert(initialized); + GenerateInternalDeclarations(PROCEDURE_SECTION); + + PushProcedureDeclaration(procIdent); + procedureDeclStart = ftell(cFile); + fprintf(cFile, "\n"); + + /*generate export status*/ + if (! Trees_Exported(procIdent)) { + fprintf(cFile, "static "); + } + + /*generate return type*/ + procType = Trees_Type(procIdent); + resultType = Types_ResultType(procType); + if (resultType != NULL) { + Generate(resultType, cFile, 0); + fprintf(cFile, " "); + } else { + fprintf(cFile, "void "); + } + + /*generate function identifier*/ + Generate(procIdent, cFile, 0); + + /*generate parameter list*/ + fprintf(cFile, "("); + paramList = Types_Parameters(procType); + if (paramList != NULL) { + GenerateFormalParameterList(paramList, cFile); + } else { + fprintf(cFile, "void"); + } + fprintf(cFile, ")"); + + if (Trees_Exported(procIdent)) { + fprintf(hFile, "\n"); + GenerateObjectFileSymbolDefinitions(Trees_NewNode(TREES_NOSYM, procIdent, NULL), "", hFile, 0); + CopyText(cFile, procedureDeclStart + 1, (int) (ftell(cFile) - procedureDeclStart), hFile); + fprintf(hFile, ";\n"); + } + + fprintf(cFile, "\n{\n"); +} + + +void Generate_ProcedureStatements(Trees_Node stmtSeq) +{ + assert(initialized); + fprintf(cFile, "\n"); + Generate(stmtSeq, cFile, 1); +} + + +void Generate_ReturnClause(Trees_Node exp) +{ + Trees_Node resultType; + + assert(initialized); + assert(procedureDeclStack != NULL); + + resultType = Types_ResultType(Trees_Type(procedureDeclStack->procIdent)); + + Indent(cFile, 1); + fprintf(cFile, "return "); + if (CastNeeded(Trees_Type(exp), resultType)) { + fprintf(cFile, "("); + Generate(resultType, cFile, 0); + fprintf(cFile, ") "); + } + Generate(exp, cFile, 0); + fprintf(cFile, ";\n"); +} + + +void Generate_ProcedureEnd(Trees_Node procIdent) +{ + assert(initialized); + (void) procIdent; /*prevent "unused" warning*/ + fprintf(cFile, "}\n\n"); + PopProcedureDeclaration(); +} + + +/*MODULE GENERATORS*/ + +static void GenerateInitCalls(int indent) +{ + Trees_Node current, moduleAndDirPath, module; + + current = importList; + while (current != NULL) { + moduleAndDirPath = Trees_Left(current); + module = Trees_Left(moduleAndDirPath); + Indent(cFile, indent); + fprintf(cFile, "%s__Init();\n", Trees_Name(module)); + current = Trees_Right(current); + } +} + + +static int Generated(const char filename[]) +{ + FILE *file; + const char *p; + ptrdiff_t n; + int result, ch, i; + + assert(filename != NULL); + + result = 0; + file = Files_Old(filename, FILES_READ); + p = strrchr(headerComment, ' '); + if (p != NULL) { + n = p - headerComment; /*ignore version string*/ + i = 0; + ch = fgetc(file); + while ((ch != EOF) && (i < n) && (headerComment[i] == ch)) { + i++; + ch = fgetc(file); + } + result = (i == n) && (headerComment[i] == ch); + } + Files_Close(&file); + return result; +} + + +static void DeleteTemporaryFiles(void) +{ + if (Files_Exists(tempCFilepath)) { + Files_Close(&cFile); + Files_Remove(tempCFilepath); + } + if (Files_Exists(tempHFilepath)) { + Files_Close(&hFile); + Files_Remove(tempHFilepath); + } +} + + +void Generate_Open(const char inputFile[], int isEntryPoint) +{ + assert(initialized); + + inputFilename = inputFile; + inputModuleName = Paths_SansSuffix(Paths_Basename(inputFile)); + isEntryPointModule = isEntryPoint; + + /*initialize header comment*/ + if (strcmp(CONFIG_VERSION, "") != 0) { + headerComment = Util_String("/*GENERATED BY OBNC %s*/", CONFIG_VERSION); + } else { + headerComment = Util_String("/*GENERATED BY OBNC*/"); + } + + /*make sure output directory exists*/ + if (! Files_Exists(".obnc")) { + Files_CreateDir(".obnc"); + } + + /*create temporary C file*/ + tempCFilepath = Util_String(".obnc/%s.c.%d", inputModuleName, getpid()); + cFile = Files_New(tempCFilepath); + + /*create temporary header file*/ + tempHFilepath = Util_String(".obnc/%s.h.%d", inputModuleName, getpid()); + hFile = Files_New(tempHFilepath); + + atexit(DeleteTemporaryFiles); +} + + +void Generate_ModuleHeading(void) +{ + assert(initialized); + + fprintf(cFile, "%s\n\n", headerComment); + if (! isEntryPointModule) { + fprintf(cFile, "#include \"%s.h\"\n", inputModuleName); + } + + fprintf(hFile, "%s\n\n", headerComment); + fprintf(hFile, "#ifndef %s_h\n", inputModuleName); + fprintf(hFile, "#define %s_h\n\n", inputModuleName); +} + + +static int StartsWith(const char pattern[], const char s[]) +{ + return strstr(s, pattern) == s; +} + +static int IsInstalledLibrary(const char *path) +{ + const char *dotObncPath, *prefix = Config_Prefix(); + + dotObncPath = Util_String("%s/.obnc", path); + return StartsWith(prefix, path) && (path[strlen(prefix)] == '/') && ! Files_Exists(dotObncPath); +} + + +static const char *RelativeInstalledLibraryPath(const char *path) +{ + const char *prefix = Config_Prefix(); + const char *libdir = Config_LibDir(); + const char *result, *tail; + + result = path; + if (StartsWith(prefix, path)) { + tail = result + strlen(prefix); + if (tail[0] == '/') { + tail++; + if (StartsWith(libdir, tail)) { + tail += strlen(libdir); + if (tail[0] == '/') { + result = tail + 1; + } + } + } + } + return result; +} + + +void Generate_ImportList(Trees_Node list) +{ + const char *hFileDir; + + Trees_Node moduleAndDirPath, module, dirPathNode; + const char *dirPath, *parentDirPrefix, *relativePath; + + assert(initialized); + importList = list; + + while (list != NULL) { + moduleAndDirPath = Trees_Left(list); + module = Trees_Left(moduleAndDirPath); + dirPathNode = Trees_Right(moduleAndDirPath); + dirPath = Trees_String(dirPathNode); + if (IsInstalledLibrary(dirPath)) { + relativePath = RelativeInstalledLibraryPath(dirPath); + fprintf(cFile, "#include <%s/%s.h>\n", relativePath, Trees_Name(module)); + fprintf(hFile, "#include <%s/%s.h>\n", relativePath, Trees_Name(module)); + } else if (strcmp(dirPath, ".") == 0) { + fprintf(cFile, "#include \"%s.h\"\n", Trees_Name(module)); + fprintf(hFile, "#include \"%s.h\"\n", Trees_Name(module)); + } else { + parentDirPrefix = ""; + if ((dirPath[0] != '\0') && Files_Exists(".obnc")) { + if (! Paths_Absolute(dirPath)) { + if (StartsWith("./", dirPath)) { + parentDirPrefix = "."; + } else { + parentDirPrefix = "../"; + } + } + } + hFileDir = Util_String("%s/.obnc", dirPath); + if (! Files_Exists(hFileDir)) { + hFileDir = Util_String("%s", dirPath); + } + fprintf(cFile, "#include \"%s%s/%s.h\"\n", parentDirPrefix, hFileDir, Trees_Name(module)); + fprintf(hFile, "#include \"%s%s/%s.h\"\n", parentDirPrefix, hFileDir, Trees_Name(module)); + } + list = Trees_Right(list); + } +} + + +static void SearchAddressOperations(Trees_Node node) +{ + if (node != NULL) { + switch (Trees_Symbol(node)) { + case TREES_ADR_PROC: + case TREES_BIT_PROC: + case TREES_COPY_PROC: + case TREES_GET_PROC: + case TREES_PUT_PROC: + addressOperationUsed = 1; + break; + default: + SearchAddressOperations(Trees_Left(node)); + SearchAddressOperations(Trees_Right(node)); + } + } +} + + +static void GenerateIntegerSizeAssertion(int indent) +{ + Indent(cFile, indent); + fprintf(cFile, "OBNC_C_ASSERT(sizeof (OBNC_INTEGER) == sizeof (void *)); /*SYSTEM procedure requirement*/\n"); +} + + +void Generate_ModuleStatements(Trees_Node stmtSeq) +{ + const char *initFuncName; + Trees_Node initFuncIdent; + + assert(initialized); + + GenerateInternalDeclarations(MODULE_SECTION); + SearchAddressOperations(stmtSeq); + if (isEntryPointModule) { + fprintf(cFile, "\n"); + fprintf(cFile, "#if OBNC_CONFIG_TARGET_EMB\n"); + fprintf(cFile, "int main(void)\n"); + fprintf(cFile, "{\n"); + Indent(cFile, 1); + fprintf(cFile, "OBNC_Init(0, NULL);\n"); + fprintf(cFile, "#else\n"); + fprintf(cFile, "int main(int argc, char *argv[])\n"); + fprintf(cFile, "{\n"); + Indent(cFile, 1); + fprintf(cFile, "OBNC_Init(argc, argv);\n"); + fprintf(cFile, "#endif\n"); + if (addressOperationUsed) { + GenerateIntegerSizeAssertion(1); + } + if (importList != NULL) { + GenerateInitCalls(1); + } + Generate(stmtSeq, cFile, 1); + Indent(cFile, 1); + fprintf(cFile, "return 0;\n"); + fprintf(cFile, "}\n"); + } else { + initFuncName = Util_String("%s__Init", inputModuleName); + fprintf(cFile, "\nvoid %s(void)\n", initFuncName); + fprintf(cFile, "{\n"); + if ((importList != NULL) || (stmtSeq != NULL)) { + Indent(cFile, 1); + fprintf(cFile, "static int initialized = 0;\n\n"); + Indent(cFile, 1); + fprintf(cFile, "if (! initialized) {\n"); + if (addressOperationUsed) { + GenerateIntegerSizeAssertion(2); + } + GenerateInitCalls(2); + Generate(stmtSeq, cFile, 2); + Indent(cFile, 2); + fprintf(cFile, "initialized = 1;\n"); + Indent(cFile, 1); + fprintf(cFile, "}\n"); + } + fprintf(cFile, "}\n"); + + fprintf(hFile, "\n"); + initFuncIdent = Trees_NewIdent(initFuncName); + Trees_SetInternal(initFuncIdent); + GenerateObjectFileSymbolDefinitions(Trees_NewNode(TREES_NOSYM, initFuncIdent, NULL), "", hFile, 0); + fprintf(hFile, "void %s(void);\n", initFuncName); + } +} + + +void Generate_ModuleEnd(void) +{ + assert(initialized); + fprintf(hFile, "\n#endif\n"); +} + + +void Generate_Close(void) +{ + const char *cFilepath, *hFilepath; + + assert(initialized); + + /*close temporary files*/ + Files_Close(&cFile); + Files_Close(&hFile); + + /*move temporary C file to permanent C file*/ + cFilepath = Util_String(".obnc/%s.c", inputModuleName); + if (! Files_Exists(cFilepath) || Generated(cFilepath)) { + Files_Move(tempCFilepath, cFilepath); + } else { + fprintf(stderr, "obnc-compile: error: C file generated by obnc-compile expected, will not overwrite: %s\n", cFilepath); + exit(EXIT_FAILURE); + } + + hFilepath = Util_String(".obnc/%s.h", inputModuleName); + if (isEntryPointModule) { + /*delete generated header file*/ + if (Files_Exists(hFilepath)) { + if (Generated(hFilepath)) { + Files_Remove(hFilepath); + } else { + fprintf(stderr, "obnc-compile: error: header file generated by obnc-compile expected, will not delete: %s\n", hFilepath); + exit(EXIT_FAILURE); + } + } + } else { + /*move temporary header file to permanent header file*/ + if (! Files_Exists(hFilepath) || Generated(hFilepath)) { + Files_Move(tempHFilepath, hFilepath); + } else { + fprintf(stderr, "obnc-compile: error: header file generated by obnc-compile expected, will not overwrite: %s\n", hFilepath); + exit(EXIT_FAILURE); + } + } +} + + +/*GENERAL GENERATOR*/ + +static void Generate(Trees_Node node, FILE *file, int indent) +{ + int symbol; + + if (node != NULL) { + symbol = Trees_Symbol(node); + switch (symbol) { + case '#': + case '&': + case '*': + case '+': + case '-': + case '/': + case '<': + case '=': + case '>': + case '~': + case DIV: + case MOD: + case OR: + case GE: + case LE: + GenerateOperator(node, file); + break; + case BECOMES: + GenerateAssignment(node, file, indent); + break; + case CASE: + GenerateCaseStatement(node, file, indent); + break; + case ELSE: + Indent(file, indent); + fprintf(file, "else {\n"); + Generate(Trees_Left(node), file, indent + 1); + Indent(file, indent); + fprintf(file, "}\n"); + break; + case ELSIF: + Indent(file, indent); + fprintf(file, "else if ("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ") "); + Generate(Trees_Right(node), file, indent); + break; + case FALSE: + fprintf(file, "0"); + break; + case FOR: + GenerateForStatement(node, file, indent); + break; + case IDENT: + GenerateIdent(node, file, indent); + break; + case IF: + Indent(file, indent); + fprintf(file, "if ("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ") "); + Generate(Trees_Right(node), file, indent); + break; + case IN: + fprintf(file, "OBNC_IN("); + Generate(Trees_Left(node), file, indent); + fprintf(file, ", "); + Generate(Trees_Right(node), file, indent); + fprintf(file, ")"); + break; + case INTEGER: + { + OBNC_INTEGER i = Trees_Integer(node); + + if (i == OBNC_INT_MIN) { + fprintf(file, "(%" OBNC_INT_MOD "d - 1)", (OBNC_INTEGER) (i + 1)); + } else { + fprintf(file, "%" OBNC_INT_MOD "d", i); + } + } + break; + case IS: + GenerateISExpression(Trees_Left(node), Trees_Right(node), file); + break; + case NIL: + fprintf(file, "0"); + break; + case POINTER: + Generate(Trees_Left(node), file, indent); + fprintf(file, " *"); + break; + case REAL: + GenerateReal(Trees_Real(node), file); + break; + case REPEAT: + Indent(file, indent); + fprintf(file, "do {\n"); + Generate(Trees_Left(node), file, indent + 1); + Indent(file, indent); + fprintf(file, "} while (! "); + GenerateWithPrecedence(Trees_Right(node), file); + fprintf(file, ");\n"); + break; + case STRING: + GenerateString(Trees_String(node), file); + break; + case THEN: + fprintf(file, "{\n"); + Generate(Trees_Left(node), file, indent + 1); + Indent(file, indent); + fprintf(file, "}\n"); + Generate(Trees_Right(node), file, indent); + break; + case TREES_NOSYM: + Generate(Trees_Left(node), file, indent); + Generate(Trees_Right(node), file, indent); + break; + case TREES_ABS_PROC: + if (Types_IsInteger(Trees_Type(Trees_Left(node)))) { + fprintf(file, "OBNC_ABS_INT("); + } else { + fprintf(file, "OBNC_ABS_FLT("); + } + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_ADR_PROC: + fprintf(file, "OBNC_ADR("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + addressOperationUsed = 1; + break; + case TREES_ASR_PROC: + Indent(file, indent); + fprintf(file, "OBNC_ASR("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_ASSERT_PROC: + GenerateAssert(node, file, indent); + break; + case TREES_BIT_PROC: + fprintf(file, "OBNC_BIT("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + addressOperationUsed = 1; + break; + case TREES_BOOLEAN_TYPE: + fprintf(file, "int"); + break; + case TREES_BYTE_TYPE: + fprintf(file, "unsigned char"); + break; + case TREES_CHAR_CONSTANT: + GenerateChar(Trees_Char(node), file); + break; + case TREES_CHAR_TYPE: + fprintf(file, "char"); + break; + case TREES_CHR_PROC: + fprintf(file, "OBNC_CHR("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_COPY_PROC: + Indent(file, indent); + fprintf(file, "OBNC_COPY("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ");\n"); + addressOperationUsed = 1; + break; + case TREES_DEC_PROC: + { + Trees_Node params = Trees_Left(node); + + Indent(file, indent); + if (Trees_Right(params) == NULL) { + fprintf(file, "OBNC_DEC("); + } else { + fprintf(file, "OBNC_DEC_N("); + } + Generate(params, file, 0); + fprintf(file, ");\n"); + } + break; + case TREES_DESIGNATOR: + GenerateDesignator(node, file); + break; + case TREES_EXCL_PROC: + Indent(file, indent); + fprintf(file, "OBNC_EXCL("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ");\n"); + break; + case TREES_EXP_LIST: + GenerateExpList(node, file); + break; + case TREES_FIELD_LIST_SEQUENCE: + Generate(Trees_Left(node), file, indent); + Generate(Trees_Right(node), file, indent); + break; + case TREES_FLOOR_PROC: + fprintf(file, "OBNC_FLOOR("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_FLT_PROC: + fprintf(file, "OBNC_FLT("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_GET_PROC: + { + Trees_Node params = Trees_Left(node); + + Indent(file, indent); + fprintf(file, "OBNC_GET("); + Generate(params, file, 0); + fprintf(file, ", "); + Generate(Trees_Type(Trees_Left(Trees_Right(params))), file, indent); + fprintf(file, ");\n"); + addressOperationUsed = 1; + } + break; + case TREES_INC_PROC: + { + Trees_Node params = Trees_Left(node); + + Indent(file, indent); + if (Trees_Right(params) == NULL) { + fprintf(file, "OBNC_INC("); + } else { + fprintf(file, "OBNC_INC_N("); + } + Generate(params, file, 0); + fprintf(file, ");\n"); + } + break; + case TREES_INCL_PROC: + Indent(file, indent); + fprintf(file, "OBNC_INCL("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ");\n"); + break; + case TREES_INTEGER_TYPE: + fprintf(file, "OBNC_INTEGER"); + break; + case TREES_LEN_PROC: + { + Trees_Node params, var; + + params = Trees_Left(node); + var = Trees_Left(params); + GenerateArrayLength(Trees_Type(var), EntireVar(var), ArrayDimension(var), file); + } + break; + case TREES_LSL_PROC: + fprintf(file, "OBNC_LSL("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_NEW_PROC: + GenerateMemoryAllocation(Trees_Left(Trees_Left(node)), file, indent); + break; + case TREES_ODD_PROC: + fprintf(file, "OBNC_ODD("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_ORD_PROC: + fprintf(file, "OBNC_ORD("); + if (Types_IsChar(Trees_Type(Trees_Left(Trees_Left(node))))) { + fprintf(file, "(unsigned char) "); + } + GenerateWithPrecedence(Trees_Left(node), file); + fprintf(file, ")"); + break; + case TREES_PACK_PROC: + { + Trees_Node params = Trees_Left(node); + + Indent(file, indent); + if (ContainsProcedureCall(params)) { + fprintf(file, "OBNC_Pack(&("); + Generate(Trees_Left(params), file, 0); + fprintf(file, "), "); + Generate(Trees_Right(params), file, 0); + fprintf(file, ");\n"); + } else { + fprintf(file, "OBNC_PACK("); + Generate(params, file, 0); + fprintf(file, ");\n"); + } + } + break; + case TREES_PROCEDURE_CALL: + GenerateProcedureCall(node, file, indent); + break; + case TREES_PUT_PROC: + { + Trees_Node params = Trees_Left(node); + Trees_Node firstParam = Trees_Left(params); + Trees_Node secondParam = Trees_Left(Trees_Right(params)); + + Indent(file, indent); + fprintf(file, "OBNC_PUT("); + Generate(firstParam, file, 0); + fprintf(file, ", "); + if (Types_IsSingleCharString(Trees_Type(secondParam))) { + GenerateChar(Trees_String(secondParam)[0], file); + fprintf(file, ", char"); + } else { + Generate(secondParam, file, 0); + fprintf(file, ", "); + Generate(Trees_Type(secondParam), file, 0); + } + fprintf(file, ");\n"); + addressOperationUsed = 1; + } + break; + case TREES_RANGE_SET: + GenerateRangeSet(node, file); + break; + case TREES_REAL_TYPE: + fprintf(file, "OBNC_REAL"); + break; + case TREES_ROR_PROC: + if (ContainsProcedureCall(Trees_Left(node)) || ContainsProcedureCall(Trees_Right(node))) { + fprintf(file, "OBNC_Ror("); + } else { + fprintf(file, "OBNC_ROR("); + } + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_SET_CONSTANT: + fprintf(file, "0x%" OBNC_INT_MOD "Xu", Trees_Set(node)); + break; + case TREES_SET_TYPE: + fprintf(file, "unsigned OBNC_INTEGER"); + break; + case TREES_SINGLE_ELEMENT_SET: + GenerateSingleElementSet(node, file); + break; + case TREES_SIZE_PROC: + fprintf(file, "OBNC_SIZE("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TREES_STATEMENT_SEQUENCE: + Generate(Trees_Left(node), file, indent); + Generate(Trees_Right(node), file, indent); + break; + case TREES_UNPK_PROC: + { + Trees_Node params = Trees_Left(node); + + Indent(file, indent); + if (ContainsProcedureCall(params)) { + fprintf(file, "OBNC_Unpk(&("); + Generate(Trees_Left(params), file, 0); + fprintf(file, "), &("); + Generate(Trees_Right(params), file, 0); + fprintf(file, "));\n"); + } else { + fprintf(file, "OBNC_UNPK("); + Generate(params, file, 0); + fprintf(file, ");\n"); + } + } + break; + case TREES_VAL_PROC: + fprintf(file, "OBNC_VAL("); + Generate(Trees_Left(node), file, 0); + fprintf(file, ")"); + break; + case TRUE: + fprintf(file, "1"); + break; + case WHILE: + GenerateWhileStatement(node, file, indent); + break; + default: + fprintf(stderr, "obnc-compile: unknown symbol: %d\n", Trees_Symbol(node)); + assert(0); + } + } +} diff --git a/src/Generate.h b/src/Generate.h new file mode 100644 index 0000000..c077deb --- /dev/null +++ b/src/Generate.h @@ -0,0 +1,51 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef GENERATE_H +#define GENERATE_H + +#include "Trees.h" + +void Generate_Init(void); + +void Generate_Open(const char inputFile[], int isEntryPoint); + +void Generate_ModuleHeading(void); + +void Generate_ImportList(Trees_Node importList); + +void Generate_ConstDeclaration(Trees_Node constIdent); + +void Generate_TypeDeclaration(Trees_Node typeIdent); + +void Generate_VariableDeclaration(Trees_Node varIdentList); + +void Generate_ProcedureHeading(Trees_Node procIdent); + +void Generate_ProcedureStatements(Trees_Node stmtSeq); + +void Generate_ReturnClause(Trees_Node exp); + +void Generate_ProcedureEnd(Trees_Node procIdent); + +void Generate_ModuleStatements(Trees_Node stmtSeq); + +void Generate_ModuleEnd(void); + +void Generate_Close(void); + +#endif diff --git a/src/Maps.c b/src/Maps.c new file mode 100644 index 0000000..6f2bbcf --- /dev/null +++ b/src/Maps.c @@ -0,0 +1,120 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Maps.h" +#include "Util.h" +#include +#include +#include + +struct Maps_MapDesc { + char *key; + void *value; + Maps_Map next; +}; + +static int initialized = 0; + +void Maps_Init(void) +{ + if (! initialized) { + initialized = 1; + Util_Init(); + } +} + + +Maps_Map Maps_New(void) +{ + assert(initialized); + return NULL; +} + + +int Maps_IsEmpty(Maps_Map map) +{ + return map == NULL; +} + + +void Maps_Put(const char key[], void *value, Maps_Map *map) +{ + Maps_Map node; + + assert(key != NULL); + assert(map != NULL); + + NEW(node); + NEW_ARRAY(node->key, strlen(key) + 1); + strcpy(node->key, key); + node->value = value; + node->next = *map; + *map = node; +} + + +int Maps_HasKey(const char key[], Maps_Map map) +{ + assert(key != NULL); + + while ((map != NULL) && (strcmp(map->key, key) != 0)) { + map = map->next; + } + return map != NULL; +} + + +void *Maps_At(const char key[], Maps_Map map) +{ + void *result; + + assert(key != NULL); + + while ((map != NULL) && (strcmp(map->key, key) != 0)) { + map = map->next; + } + if (map != NULL) { + result = map->value; + } else { + result = NULL; + } + return result; +} + + +static Maps_Map DeletedDuplicates(Maps_Map map) +{ + Maps_Map result = Maps_New(); + + while (map != NULL) { + if (! Maps_HasKey(map->key, result)) { + Maps_Put(map->key, map->value, &result); + } + map = map->next; + } + return result; +} + + +void Maps_Apply(Maps_Applicator f, Maps_Map map, void *data) +{ + map = DeletedDuplicates(map); + while (map != NULL) { + f(map->key, map->value, data); + map = map->next; + } +} diff --git a/src/Maps.h b/src/Maps.h new file mode 100644 index 0000000..ae01aa4 --- /dev/null +++ b/src/Maps.h @@ -0,0 +1,38 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef MAPS_H +#define MAPS_H + +typedef struct Maps_MapDesc *Maps_Map; +typedef void (*Maps_Applicator)(const char key[], void *value, void *data); + +void Maps_Init(void); + +Maps_Map Maps_New(void); + +int Maps_IsEmpty(Maps_Map map); + +void Maps_Put(const char key[], void *value, Maps_Map *map); + +int Maps_HasKey(const char key[], Maps_Map map); + +void *Maps_At(const char key[], Maps_Map map); + +void Maps_Apply(Maps_Applicator f, Maps_Map map, void *data); + +#endif diff --git a/src/MapsTest.c b/src/MapsTest.c new file mode 100644 index 0000000..c4c6d20 --- /dev/null +++ b/src/MapsTest.c @@ -0,0 +1,89 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Maps.h" +#include "Util.h" +#include +#include + +typedef struct { int value; } *BoxedInteger; + +int count; + +static void Count(const char key[], void *value, void *data) +{ + count++; +} + + +static void Increment(const char key[], void *value, void *data) +{ + ((BoxedInteger) value)->value++; +} + + +int main(void) +{ + Maps_Map map; + BoxedInteger boxedInteger; + struct { const char *key; int value; } items[] = {{"foo", 1}, {"bar", 2}, {"baz", 3}}; + int i; + + Maps_Init(); + Util_Init(); + map = Maps_New(); + assert(Maps_IsEmpty(map)); + + /*insert items*/ + for (i = 0; i < LEN(items); i++) { + NEW(boxedInteger); + boxedInteger->value = items[i].value; + Maps_Put(items[i].key, boxedInteger, &map); + } + assert(! Maps_IsEmpty(map)); + + /*retrieve keys*/ + for (i = 0; i < LEN(items); i++) { + assert(Maps_HasKey(items[i].key, map)); + } + + /*retrieve values*/ + for (i = 0; i < LEN(items); i++) { + boxedInteger = Maps_At(items[i].key, map); + assert(boxedInteger->value == items[i].value); + } + + /*reinsert element*/ + NEW(boxedInteger); + boxedInteger->value = 1; + Maps_Put("foo", boxedInteger, &map); + + /*count elements*/ + count = 0; + Maps_Apply(Count, map, NULL); + assert(count == 3); + + /*increment all values by one*/ + Maps_Apply(Increment, map, NULL); + for (i = 0; i < LEN(items); i++) { + assert(Maps_HasKey(items[i].key, map)); + boxedInteger = Maps_At(items[i].key, map); + assert(boxedInteger->value == items[i].value + 1); + } + + return 0; +} diff --git a/src/ModulePaths.c b/src/ModulePaths.c new file mode 100644 index 0000000..16bbd3b --- /dev/null +++ b/src/ModulePaths.c @@ -0,0 +1,214 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "ModulePaths.h" +#include "Config.h" +#include "Files.h" +#include "Util.h" +#include +#include +#include +#include +#include + +#ifdef _WIN32 + #define PATH_SEPARATOR ';' +#else + #define PATH_SEPARATOR ':' +#endif + +static int initialized = 0; + +void ModulePaths_Init(void) +{ + if (! initialized) { + initialized = 1; + Config_Init(); + Files_Init(); + Util_Init(); + } +} + + +static const char *AsPrefix(const char dir[]) +{ + return (strcmp(dir, ".") == 0)? "": Util_String("%s/", dir); +} + + +const char *ModulePaths_SourceFile(const char module[], const char dir[]) +{ + static const char *suffixes[] = {".obn", ".Mod", ".mod"}; + int i; + const char *result; + + assert(initialized); + + i = -1; + do { + i++; + result = Util_String("%s%s%s", AsPrefix(dir), module, suffixes[i % LEN(suffixes)]); + } while ((i < LEN(suffixes)) && ! Files_Exists(result)); + + return result; +} + + +static char *ModulePrefix(const char module[]) +{ + char *result; + int i; + + i = 0; + while ((module[i] != '\0') && ! isupper(module[i])) { + i++; + } + if ((i > 0) && isupper(module[i])) { + NEW_ARRAY(result, i + 1); + memcpy(result, module, i); + result[i] = '\0'; + } else { + result = NULL; + } + return result; +} + + +static const char *SearchDir(const char dir[], const char module[]) +{ + const char *oberonFile = ModulePaths_SourceFile(module, dir); + const char *localSymfile = Util_String("%s/.obnc/%s.sym", dir, module); + const char *globalSymfile = Util_String("%s/%s.sym", dir, module); + + return (Files_Exists(oberonFile) || Files_Exists(localSymfile) || Files_Exists(globalSymfile)) + ? dir + : NULL; +} + + +static const char *SearchPath(const char dir[], const char module[]) +{ + const char *result, *modulePrefix, *libDir; + + result = SearchDir(dir, module); + if (result == NULL) { + modulePrefix = ModulePrefix(module); + if (modulePrefix != NULL) { + libDir = Util_String("%s/%s", dir, modulePrefix); + result = SearchDir(libDir, module); + } + } + return result; +} + + +static void GetSearchPath(const char dir[], const char module[], int verbose, const char *result[]) +{ + *result = SearchPath(dir, module); + if (verbose && (*result == NULL)) { + printf("%s\n", dir); + } +} + + +static int CharCount(char ch, const char s[]) +{ + int i = 0, result = 0; + + assert(s != NULL); + + while (s[i] != '\0') { + if (s[i] == ch) { + result++; + } + i++; + } + return result; +} + + +static char **Split(const char s[], char sep) +{ + char **result; + int resultLen, i, pos, n; + + assert(s != NULL); + + resultLen = CharCount(sep, s) + 2; + NEW_ARRAY(result, resultLen); + + pos = 0; + for (i = 0; i < resultLen - 1; i++) { + n = 0; + while ((s[pos + n] != '\0') && (s[pos + n] != PATH_SEPARATOR)) { + n++; + } + NEW_ARRAY(result[i], n + 1); + memcpy(result[i], s + pos, n); + result[i][n] = '\0'; + pos += n + 1; + } + result[resultLen - 1] = NULL; + return result; +} + + +static char **CustomImportPaths(void) +{ + static char **result; + const char *paths; + + if (result == NULL) { + paths = getenv("OBNC_IMPORT_PATH"); + if (paths != NULL) { + result = Split(paths, PATH_SEPARATOR); + } else { + NEW_ARRAY(result, 1); + result[0] = NULL; + } + } + return result; +} + + +const char *ModulePaths_Directory(const char module[], const char relativeDir[], int verbose) +{ + const char *result, *obncLibPath; + char **paths; + int i; + + assert(initialized); + assert(module != NULL); + assert(relativeDir != NULL); + + GetSearchPath(relativeDir, module, verbose, &result); + if (result == NULL) { + paths = CustomImportPaths(); + i = 0; + while ((result == NULL) && (paths[i] != NULL)) { + if (paths[i][0] != '\0') { + GetSearchPath(paths[i], module, verbose, &result); + } + i++; + } + if (result == NULL) { + obncLibPath = Util_String("%s/%s/obnc", Config_Prefix(), Config_LibDir()); + GetSearchPath(obncLibPath, module, verbose, &result); + } + } + return result; +} diff --git a/src/ModulePaths.h b/src/ModulePaths.h new file mode 100644 index 0000000..e34217a --- /dev/null +++ b/src/ModulePaths.h @@ -0,0 +1,27 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef MODULEPATHS_H +#define MODULEPATHS_H + +void ModulePaths_Init(void); + +const char *ModulePaths_SourceFile(const char module[], const char dir[]); + +const char *ModulePaths_Directory(const char module[], const char relativeDir[], int verbose); + +#endif diff --git a/src/Oberon.h b/src/Oberon.h new file mode 100644 index 0000000..06de4df --- /dev/null +++ b/src/Oberon.h @@ -0,0 +1,33 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef OBERON_H +#define OBERON_H + +/*parse modes*/ +#define OBERON_NORMAL_MODE 0 +#define OBERON_ENTRY_POINT_MODE 1 +#define OBERON_IMPORT_LIST_MODE 2 + +void Oberon_Init(void); + +void Oberon_Parse(const char inputFile[], int mode); + +void Oberon_PrintError(const char format[], ...) + __attribute__ ((format (printf, 1, 2))); + +#endif diff --git a/src/Oberon.l b/src/Oberon.l new file mode 100644 index 0000000..2f1974e --- /dev/null +++ b/src/Oberon.l @@ -0,0 +1,224 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +%option always-interactive + +%{ +#include "Oberon.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" +#include "Trees.h" /*needed by YYSTYPE in y.tab.h*/ +#include "y.tab.h" +#include +#include +#include +#include +#include +#include +#include +#include + +static int KeywordToken(const char word[]); + +%} + +WORD [A-Za-z](_?[A-Za-z0-9])* + +INTEGER [0-9]+|[0-9][0-9A-F]*H + +REAL [0-9]+"."[0-9]*(E[+-]?[0-9]+)? + +QUOTED-STRING \"[^"\n]*\" + +ORDINAL-STRING [0-9][0-9A-F]*X + +%% + +[ \t\r]+ + +\n { + yylineno++; +} + +":=" return BECOMES; + +".." return DOTDOT; + +"<=" return LE; + +">=" return GE; + +[][*+/&~.,;|({^:)}=#<>-] return yytext[0]; + +{WORD} { + int token; + char *lexeme; + + token = KeywordToken(yytext); + if (token < 0) { + token = IDENT; + NEW_ARRAY(lexeme, yyleng + 1); + strcpy(lexeme, yytext); + yylval.ident = lexeme; + } + return token; +} + +{INTEGER}/".."? { + int base; + unsigned long int max, lexeme; + + base = (yytext[yyleng - 1] == 'H')? 16: 10; + max = (yytext[yyleng - 1] == 'H')? OBNC_UINT_MAX: OBNC_INT_MAX; + errno = 0; + lexeme = strtoul(yytext, NULL, base); + if ((errno != 0) || (lexeme > max)) { + if (base == 10) { + Oberon_PrintError("warning: %s: %s > %lu", strerror(ERANGE), yytext, max); + } else { + Oberon_PrintError("warning: %s: %s > 0%lXH", strerror(ERANGE), yytext, max); + } + } + yylval.integer = (OBNC_INTEGER) lexeme; + return INTEGER; +} + +{REAL} { + int n = sscanf(yytext, "%" OBNC_REAL_MOD_R "f", &yylval.real); + if (n != 1) { + Oberon_PrintError("warning: %s: %s > %" OBNC_REAL_MOD_W "G", strerror(ERANGE), yytext, OBNC_REAL_MAX); + } + return REAL; +} + +{QUOTED-STRING} { + int lexemeLen; + char *lexeme; + + lexemeLen = yyleng - 1; + NEW_ARRAY(lexeme, lexemeLen); + memcpy(lexeme, yytext + 1, (size_t) (lexemeLen - 1)); + lexeme[lexemeLen - 1] = '\0'; + yylval.string = lexeme; + return STRING; +} + +{ORDINAL-STRING} { + long ordinalNumber; + char *lexeme; + + if (strcmp(yytext, "0X") == 0) { + ordinalNumber = 0; + } else { + errno = 0; + ordinalNumber = strtol(yytext, NULL, 16); + if ((errno != 0) || (ordinalNumber > UCHAR_MAX)) { + Oberon_PrintError("warning: %s: %s > 0%XX", strerror(ERANGE), yytext, UCHAR_MAX); + } + } + NEW_ARRAY(lexeme, 2); + lexeme[0] = (char) ordinalNumber; + lexeme[1] = '\0'; + yylval.string = lexeme; + return STRING; +} + +"(*" { + int linenoStart, level, ch; + + linenoStart = yylineno; + level = 1; + do { + ch = input(); + switch (ch) { + case '(': + ch = input(); + if (ch == '*') { + level++; + } else { + unput(ch); + } + break; + case '*': + ch = input(); + if (ch == ')') { + level--; + } else { + unput(ch); + } + break; + case '\n': + yylineno++; + break; + } + } while ((level > 0) && (ch > 0)); + assert((ch >= 0) || (ch == EOF)); + + /*Note: In Flex 2.6.0 and earlier, input returns EOF (-1) instead of 0 when end-of-file is reached.*/ + + if (level > 0) { + Oberon_PrintError("error: unterminated comment starting at line %d", linenoStart); + exit(EXIT_FAILURE); + } +} + +. { + if (isprint(yytext[0])) { + Oberon_PrintError("error: unexpected character: %c", yytext[0]); + } else { + Oberon_PrintError("error: unexpected character: %02X (hex)", yytext[0]); + } + exit(EXIT_FAILURE); +} + +%% + +static int Cmp(const void *word, const void *keywordPtr) +{ + return strcmp((char *) word, * (char **) keywordPtr); +} + + +static int KeywordToken(const char word[]) +{ + static const char *keywords[] = {"ARRAY", "BEGIN", "BY", "CASE", "CONST", "DIV", "DO", "ELSE", "ELSIF", "END", "FALSE", "FOR", "IF", "IMPORT", "IN", "IS", "MOD", "MODULE", "NIL", "OF", "OR", "POINTER", "PROCEDURE", "RECORD", "REPEAT", "RETURN", "THEN", "TO", "TRUE", "TYPE", "UNTIL", "VAR", "WHILE"}; + + static const int keywordTokens[] = {ARRAY, BEGIN_, BY, CASE, CONST, DIV, DO, ELSE, ELSIF, END, FALSE, FOR, IF, IMPORT, IN, IS, MOD, MODULE, NIL, OF, OR, POINTER, PROCEDURE, RECORD, REPEAT, RETURN, THEN, TO, TRUE, TYPE, UNTIL, VAR, WHILE}; + + const char **keywordPtr; + ptrdiff_t pos; + int token; + + keywordPtr = bsearch(word, keywords, LEN(keywords), sizeof keywords[0], Cmp); + if (keywordPtr != NULL) { + pos = keywordPtr - keywords; + assert(pos >= 0); + assert(pos < LEN(keywordTokens)); + token = keywordTokens[pos]; + } else { + token = -1; + } + return token; +} + + +int yywrap(void) +{ + const int done = 1; + + return done; +} diff --git a/src/Oberon.y b/src/Oberon.y new file mode 100644 index 0000000..86855a4 --- /dev/null +++ b/src/Oberon.y @@ -0,0 +1,4128 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +%{ +#include "Config.h" +#include "Error.h" +#include "Files.h" +#include "Generate.h" +#include "lex.yy.h" +#include "Maps.h" +#include "Oberon.h" +#include "ModulePaths.h" +#include "Paths.h" +#include "Range.h" +#include "Table.h" +#include "Types.h" +#include "Trees.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" +#include +#include +#include +#include +#include +#include +#include +#include + +/*assignment contexts*/ +#define ASSIGNMENT_CONTEXT 0 +#define PARAM_SUBST_CONTEXT 1 +#define PROC_RESULT_CONTEXT 2 + +static int initialized = 0; + +static const char *inputFilename; +static int parseMode; +static char *inputModuleName; + +static Trees_Node unresolvedPointerTypes; +static Trees_Node currentTypeIdentdef; +static Trees_Node recordDeclarationStack; +static Trees_Node caseExpressionStack; +static Trees_Node caseLabelsStack; +static Trees_Node procedureDeclarationStack; + +void yyerror(const char msg[]); +static void CheckUnusedIdentifiers(void); + +/*constant predicate functions*/ + +static int IsBoolean(Trees_Node node); +static int IsChar(Trees_Node node); +static int IsInteger(Trees_Node node); +static int IsReal(Trees_Node node); +static int IsString(Trees_Node node); +static int IsSet(Trees_Node node); + +/*functions for type declaration productions*/ + +static Trees_Node ResolvedType(Trees_Node type, int isTypeDecl); +static void ResolvePointerTypes(Trees_Node baseType); +static const char *TypeString(Trees_Node type); + +/*functions for expression productions*/ + +static Trees_Node Designator(const char ident[], Trees_Node selectorList); +static int IsDesignator(Trees_Node exp); +static Trees_Node BaseIdent(Trees_Node designator); +static Trees_Node FirstSelector(Trees_Node designator); +static const char *DesignatorString(Trees_Node designator); +static void CheckIsValueExpression(Trees_Node exp); +static void SetSelectorTypes(Trees_Node identType, Trees_Node designator, int *parameterListFound); +static void RemoveActualParameters(Trees_Node *designator, Trees_Node *actualParameters); +static int IsConstExpression(Trees_Node exp); +static Trees_Node ExpressionConstValue(int relation, Trees_Node expA, Trees_Node expB); +static Trees_Node SimpleExpressionConstValue(int addOperator, Trees_Node expA, Trees_Node expB); +static Trees_Node TermConstValue(int mulOperator, Trees_Node expA, Trees_Node expB); +static const char *OperatorString(int operator); + +/*functions for statement productions*/ + +static int Writable(Trees_Node designator); +static void ValidateAssignment(Trees_Node expression, Trees_Node targetType, int context, int paramPos); +static void HandleProcedureCall(Trees_Node designator, Trees_Node actualParameters, int isFunctionCall, Trees_Node *ast); +static void CheckCaseLabelUniqueness(Trees_Node label); + +/*functions for module productions*/ + +static void ExportSymbolTable(const char symfilePath[]); +%} + +%union { + const char *ident; + OBNC_INTEGER integer; + OBNC_REAL real; + const char *string; + Trees_Node node; +} + +%token TOKEN_START + +/*reserved words (underscore avoids name clash)*/ +%token ARRAY BEGIN_ BY CASE CONST DIV DO ELSE ELSIF END FALSE FOR IF IMPORT IN IS MOD MODULE NIL OF OR POINTER PROCEDURE RECORD REPEAT RETURN THEN TO TRUE TYPE UNTIL VAR WHILE + +/*two-character operators and delimiters*/ +%token BECOMES DOTDOT GE LE + +/*tokens with semantic values*/ +%token IDENT +%token INTEGER +%token REAL +%token STRING + +%token TOKEN_END + +/*nonterminals with semantic values*/ +%type AddOperator +%type ArrayLengthOf +%type ArrayType +%type assignment +%type BaseType +%type BaseTypeOpt +%type BecomesIdentOpt +%type ByOpt +%type case +%type CaseExpression +%type CaseLabelList +%type CaseRep +%type CaseStatement +%type ConstExpression +%type designator +%type element +%type ElementRep +%type ElseIfDoOptRep +%type ElseIfThenOptRep +%type ElseOpt +%type ExpList +%type ExportMarkOpt +%type expression +%type factor +%type FieldList +%type FieldListSequence +%type FieldListSequenceOpt +%type ForInit +%type ForLimit +%type FormalParameters +%type FormalParametersOpt +%type FormalType +%type ForStatement +%type FPSection +%type FPSectionRep +%type FPSectionsOpt +%type guard +%type identdef +%type IdentRep +%type IfStatement +%type IdentList +%type import +%type ImportRep +%type length +%type label +%type LabelRange +%type LengthRep +%type ModuleStatements +%type MulOperator +%type number +%type OpenArrayOptRep +%type ParameterKindOpt +%type PointerTo +%type PointerType +%type ProcedureCall +%type ProcedureHeading +%type ProcedureHeadingSansParam +%type ProcedureType +%type ProcedureTypeSansParam +%type qualident +%type RecordHeading +%type RecordType +%type relation +%type RepeatStatement +%type ResultTypeOpt +%type ReturnExpressionOpt +%type selector +%type SelectorOptRep +%type set +%type SignOpt +%type SimpleExpression +%type statement +%type StatementSequence +%type StatementSequenceOpt +%type StatementSequenceReversed +%type term +%type type +%type TypeIdentDef +%type TypeKeyword +%type TypeSectionOpt +%type WhileStatement + +%start module + +%% + +/*IDENTIFIER RULES*/ + +qualident: + IDENT + { + $$ = Trees_NewIdent($1); + } + | IDENT '.' IDENT + { + $$ = Trees_NewIdent(Util_String("%s.%s", $1, $3)); + } + ; + +identdef: + IDENT ExportMarkOpt + { + if (! Table_LocallyDeclared($1) || (recordDeclarationStack != NULL)) { + $$ = Trees_NewIdent($1); + if ($2) { + Trees_SetExported($$); + } + if (Table_ScopeLocal()) { + Trees_SetLocal($$); + } + } else { + Oberon_PrintError("error: redeclaration of identifier: %s", $1); + YYABORT; + } + } + ; + +ExportMarkOpt: + '*' + { + $$ = 1; + } + | /*empty*/ + { + $$ = 0; + } + ; + + +/*NUMBER RULE*/ + +number: + INTEGER + { + $$ = Trees_NewInteger($1); + } + | REAL + { + $$ = Trees_NewReal($1); + } + ; + + +/*CONSTANT DECLARATION RULES*/ + +ConstDeclaration: + identdef '=' ConstExpression + { + if (! (Trees_Exported($1) && Trees_Local($1))) { + Trees_SetKind(TREES_CONSTANT_KIND, $1); + Trees_SetType(Trees_Type($3), $1); + Trees_SetValue($3, $1); + Table_Put($1); + Generate_ConstDeclaration($1); + } else { + Oberon_PrintError("error: cannot export local constant: %s", Trees_Name($1)); + YYABORT; + } + } + ; + +ConstExpression: + expression + { + if (IsConstExpression($1)) { + $$ = $1; + } else { + Oberon_PrintError("error: constant expression expected"); + YYABORT; + } + } + ; + + +/*TYPE DECLARATION RULES*/ + +TypeDeclaration: + TypeIdentDef type + { + Trees_Node sourceType; + + sourceType = ResolvedType($2, 1); + if (sourceType != NULL) { + if (! (Trees_Exported($1) && Trees_Local($1))) { + Trees_SetType(sourceType, $1); + ResolvePointerTypes($1); + currentTypeIdentdef = NULL; + Generate_TypeDeclaration($1); + } else { + Oberon_PrintError("error: cannot export local type: %s", Trees_Name($1)); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name($2)); + YYABORT; + } + } + ; + +TypeIdentDef: + identdef '=' + { + Trees_SetKind(TREES_TYPE_KIND, $1); + currentTypeIdentdef = $1; + Table_Put($1); + $$ = $1; + } + ; + +type: + qualident + | ArrayType + | RecordType + | PointerType + | ProcedureType + ; + +ArrayType: + ArrayLengthOf type + { + Trees_Node reversedLengths, length; + + $$ = ResolvedType($2, 0); + if ($$ != NULL) { + reversedLengths = $1; + do { + length = Trees_Left(reversedLengths); + $$ = Types_NewArray(length, $$); + reversedLengths = Trees_Right(reversedLengths); + } while (reversedLengths != NULL); + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name($2)); + exit(EXIT_FAILURE); + } + } + ; + +ArrayLengthOf: + ARRAY LengthRep OF + { + if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) { + Trees_SetType(Trees_NewLeaf(ARRAY), currentTypeIdentdef); /*incomplete type*/ + } + $$ = $2; + } + ; + +LengthRep: + length + { + $$ = Trees_NewNode(TREES_NOSYM, $1, NULL); + } + | LengthRep ',' length + { + $$ = Trees_NewNode(TREES_NOSYM, $3, $1); + } + ; + +length: + ConstExpression + { + if (Types_IsInteger(Trees_Type($1))) { + if (IsInteger($1)) { + if (Trees_Integer($1) <= 0) { + Oberon_PrintError("error: positive length expected: %" OBNC_INT_MOD "d", Trees_Integer($1)); + YYABORT; + } + } else { + Oberon_PrintError("error: fully evaluated constant expression expected as increment"); + YYABORT; + } + } else { + Oberon_PrintError("error: integer length expected"); + YYABORT; + } + } + ; + +RecordType: + RecordHeading FieldListSequenceOpt END + { + recordDeclarationStack = Trees_Right(recordDeclarationStack); + $$ = Types_NewRecord(Types_RecordBaseType($1), $2); + } + ; + +RecordHeading: + RECORD BaseTypeOpt + { + $$ = Types_NewRecord($2, NULL); + if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) { + Trees_SetType($$, currentTypeIdentdef); + } + recordDeclarationStack = Trees_NewNode(TREES_NOSYM, $$, recordDeclarationStack); + } + ; + +BaseTypeOpt: + '(' BaseType ')' + { + $$ = $2; + } + | /*empty*/ + { + $$ = NULL; + } + ; + +BaseType: + qualident + { + const char *name; + Trees_Node symbol; + + $$ = NULL; + name = Trees_Name($1); + symbol = Table_At(name); + if (symbol != NULL) { + if (Trees_Kind(symbol) == TREES_TYPE_KIND) { + if (symbol != currentTypeIdentdef) { + switch (Trees_Symbol(Types_Structure(symbol))) { + case POINTER: + if (Types_Same(Types_PointerBaseType(symbol), currentTypeIdentdef)) { + Oberon_PrintError("error: self-referring base type: %s", name); + YYABORT; + } + /*fall through*/ + case RECORD: + $$ = symbol; + break; + default: + Oberon_PrintError("error: record or pointer base type expected: %s", name); + YYABORT; + } + } else { + Oberon_PrintError("error: self-referring base type: %s", name); + YYABORT; + } + } else { + Oberon_PrintError("error: type name expected: %s", name); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", name); + YYABORT; + } + } + ; + +FieldListSequenceOpt: + FieldListSequence + { + Trees_ReverseList(&$1); /*correct order*/ + $$ = $1; + } + | /*empty*/ + { + $$ = NULL; + } + ; + +FieldListSequence: + FieldList + { + $$ = Trees_NewNode(TREES_FIELD_LIST_SEQUENCE, $1, NULL); + } + | FieldListSequence ';' FieldList + { + Trees_Node currSeq, currList, currSeqList; + const char *seqIdentName, *listIdentName; + + currList = $3; + while (currList != NULL) { + listIdentName = Trees_Name(Trees_Left(currList)); + currSeq = $1; + while (currSeq != NULL) { + currSeqList = Trees_Left(currSeq); + while (currSeqList != NULL) { + seqIdentName = Trees_Name(Trees_Left(currSeqList)); + if (strcmp(listIdentName, seqIdentName) == 0) { + Oberon_PrintError("error: redeclaration of field: %s", listIdentName); + YYABORT; + } + currSeqList = Trees_Right(currSeqList); + } + currSeq = Trees_Right(currSeq); + } + currList = Trees_Right(currList); + } + $$ = Trees_NewNode(TREES_FIELD_LIST_SEQUENCE, $3, $1); + } + ; + +FieldList: + IdentList ':' type + { + Trees_Node type, tail, ident, p, directBaseType, baseTypeField, baseType; + + $$ = NULL; + type = ResolvedType($3, 0); + if (type != NULL) { + if (! ((type == currentTypeIdentdef) && ! Types_IsPointer(type))) { + Trees_ReverseList(&$1); /*correct order*/ + tail = $1; + do { + ident = Trees_Left(tail); + p = $1; + while ((p != tail) && (strcmp(Trees_Name(ident), Trees_Name(Trees_Left(p))) != 0)) { + p = Trees_Right(p); + } + if (p == tail) { + assert(recordDeclarationStack != NULL); + directBaseType = Types_RecordBaseType(Trees_Left(recordDeclarationStack)); + if (directBaseType != NULL) { + Types_GetFieldIdent(Trees_Name(ident), directBaseType, 0, &baseTypeField, &baseType); + } + if ((directBaseType == NULL) || (baseTypeField == NULL)) { + Trees_SetKind(TREES_FIELD_KIND, ident); + Trees_SetType(type, ident); + } else { + Oberon_PrintError("error: redeclaration of field: %s defined in %s", Trees_Name(ident), Trees_Name(baseType)); + YYABORT; + } + } else { + Oberon_PrintError("error: redeclaration of field: %s", Trees_Name(ident)); + YYABORT; + } + tail = Trees_Right(tail); + } while (tail != NULL); + + $$ = $1; + } else { + Oberon_PrintError("error: recursive field type must be a pointer: %s", Trees_Name($3)); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared type: %s", Trees_Name($3)); + YYABORT; + } + } + ; + +IdentList: + identdef + { + $$ = Trees_NewNode(TREES_IDENT_LIST, $1, NULL); + } + | IdentList ',' identdef + { + Trees_Node reversedIdents; + + reversedIdents = Trees_NewNode(TREES_IDENT_LIST, $3, $1); + $$ = reversedIdents; + } + ; + +PointerType: + PointerTo type + { + const char *baseTypeName; + Trees_Node declaredBaseType; + + $$ = NULL; + if (Trees_Symbol($2) == IDENT) { + baseTypeName = Trees_Name($2); + declaredBaseType = Table_At(baseTypeName); + if (declaredBaseType != NULL) { + if (Types_IsRecord(declaredBaseType)) { + $$ = Types_NewPointer(declaredBaseType); + } else { + Oberon_PrintError("error: record expected as pointer base type: %s", baseTypeName); + YYABORT; + } + } else if (currentTypeIdentdef != NULL) { + Trees_SetKind(TREES_TYPE_KIND, $2); + Trees_SetType(Types_NewRecord(NULL, NULL), $2); + $$ = Types_NewPointer($2); + unresolvedPointerTypes = Trees_NewNode(TREES_NOSYM, $$, unresolvedPointerTypes); + } else { + Oberon_PrintError("error: undeclared type: %s", baseTypeName); + YYABORT; + } + } else if(Trees_Symbol($2) == RECORD) { + $$ = Types_NewPointer($2); + } else { + Oberon_PrintError("error: record expected as pointer base type"); + YYABORT; + } + } + ; + +PointerTo: + POINTER TO + { + if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) { + Trees_SetType(Types_NewPointer(NULL), currentTypeIdentdef); /*incomplete type*/ + } + } + ; + +ProcedureType: + ProcedureTypeSansParam FormalParametersOpt + { + $$ = $2; + } + ; + +ProcedureTypeSansParam: + PROCEDURE + { + $$ = NULL; + } + ; + +FormalParametersOpt: + FormalParameters + | /*empty*/ + { + $$ = Trees_NewLeaf(PROCEDURE); + } + ; + + +/*VARIABLE DECLARATION RULE*/ + +VariableDeclaration: + IdentList ':' type + { + Trees_Node type, identList, ident; + + type = ResolvedType($3, 0); + if (type != NULL) { + Trees_ReverseList(&$1); /*correct order*/ + identList = $1; + do { + ident = Trees_Left(identList); + if (! (Trees_Exported(ident) && Trees_Local(ident))) { + if (! Table_LocallyDeclared(Trees_Name(ident))) { + Trees_SetKind(TREES_VARIABLE_KIND, ident); + Trees_SetType(type, ident); + Table_Put(ident); + } else { + Oberon_PrintError("error: redeclaration of identifier with the same name: %s", Trees_Name(ident)); + YYABORT; + } + } else { + Oberon_PrintError("error: cannot export local variable: %s", Trees_Name(ident)); + YYABORT; + } + identList = Trees_Right(identList); + } while (identList != NULL); + + Generate_VariableDeclaration($1); + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name($3)); + exit(EXIT_FAILURE); + } + } + ; + + +/*EXPRESSION RULES*/ + +expression: + SimpleExpression + | SimpleExpression relation SimpleExpression + { + Trees_Node expA, expB, typeA, typeB; + int op = (int) $2; + + expA = $1; + expB = $3; + typeA = Trees_Type($1); + typeB = Trees_Type($3); + + CheckIsValueExpression($1); + if (op == IS) { + if (IsDesignator($1)) { + if (! (Types_IsRecord(typeA) && (Trees_Kind(BaseIdent($1)) != TREES_VAR_PARAM_KIND))) { + expB = BaseIdent($3); + typeB = BaseIdent($3); + } else { + Oberon_PrintError("error: variable parameter expected as first operand of IS"); + YYABORT; + } + } else { + Oberon_PrintError("error: identifier expected as first operand of IS"); + YYABORT; + } + } else { + CheckIsValueExpression($3); + } + if (Types_ExpressionCompatible(op, typeA, typeB)) { + $$ = ExpressionConstValue(op, expA, expB); + if ($$ == NULL) { + if (IsString(expA) && Types_IsChar(typeB)) { + expA = Trees_NewChar(Trees_String(expA)[0]); + } else if (Types_IsChar(typeA) && IsString(expB)) { + expB = Trees_NewChar(Trees_String(expB)[0]); + } + $$ = Trees_NewNode(op, expA, expB); + Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), $$); + } + } else { + Oberon_PrintError("error: incompatible types in relation \"%s\": %s, %s", + OperatorString(op), TypeString(typeA), TypeString(typeB)); + YYABORT; + } + } + ; + +relation: + '=' + { + $$ = '='; + } + | '#' + { + $$ = '#'; + } + | '<' + { + $$ = '<'; + } + | LE + { + $$ = LE; + } + | '>' + { + $$ = '>'; + } + | GE + { + $$ = GE; + } + | IN + { + $$ = IN; + } + | IS + { + $$ = IS; + } + ; + +SimpleExpression: + SignOpt term + { + int op = (int) $1; + $$ = $2; + if (op >= 0) { + CheckIsValueExpression($2); + if (Types_ExpressionCompatible(op, Trees_Type($2), NULL)) { + $$ = SimpleExpressionConstValue(op, $2, NULL); + if ($$ == NULL) { + $$ = Trees_NewNode(op, $2, NULL); + if (Types_IsByte(Trees_Type($2))) { + Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), $$); + } else { + Trees_SetType(Trees_Type($2), $$); + } + } + } else { + Oberon_PrintError("error: incompatible type in unary operation \"%s\": %s", OperatorString(op), TypeString(Trees_Type($2))); + YYABORT; + } + } + } + | SimpleExpression AddOperator term + { + int op = (int) $2; + + $$ = NULL; + + CheckIsValueExpression($1); + CheckIsValueExpression($3); + + if (Types_ExpressionCompatible(op, Trees_Type($1), Trees_Type($3))) { + $$ = SimpleExpressionConstValue(op, $1, $3); + if ($$ == NULL) { + $$ = Trees_NewNode(op, $1, $3); + if (Types_IsByte(Trees_Type($1)) || Types_IsByte(Trees_Type($3))) { + Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), $$); + } else { + Trees_SetType(Trees_Type($1), $$); + } + } + } else { + Oberon_PrintError("error: incompatible types in operation \"%s\": %s, %s", + OperatorString(op), TypeString(Trees_Type($1)), TypeString(Trees_Type($3))); + YYABORT; + } + assert($$ != NULL); + } + ; + +SignOpt: + '+' + { + $$ = '+'; + } + | '-' + { + $$ = '-'; + } + | /*empty*/ + { + $$ = -1; + } + ; + +AddOperator: + '+' + { + $$ = '+'; + } + | '-' + { + $$ = '-'; + } + | OR + { + $$ = OR; + } + ; + +term: + factor + | term MulOperator factor + { + int op = (int) $2; + + $$ = NULL; + + CheckIsValueExpression($1); + CheckIsValueExpression($3); + + if (Types_ExpressionCompatible(op, Trees_Type($1), Trees_Type($3))) { + $$ = TermConstValue(op, $1, $3); + if ($$ == NULL) { + $$ = Trees_NewNode(op, $1, $3); + if (Types_IsByte(Trees_Type($1)) || Types_IsByte(Trees_Type($3))) { + Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), $$); + } else { + Trees_SetType(Trees_Type($1), $$); + } + } + } else { + Oberon_PrintError("error: incompatible types in operation \"%s\": %s, %s", + OperatorString(op), TypeString(Trees_Type($1)), TypeString(Trees_Type($3))); + YYABORT; + } + + assert($$ != NULL); + } + ; + +MulOperator: + '*' + { + $$ = '*'; + } + | '/' + { + $$ = '/'; + } + | DIV + { + $$ = DIV; + } + | MOD + { + $$ = MOD; + } + | '&' + { + $$ = '&'; + } + ; + +factor: + number + | STRING + { + $$ = Trees_NewString($1); + } + | NIL + { + $$ = Trees_NewLeaf(NIL); + Trees_SetType(Trees_NewLeaf(TREES_NIL_TYPE), $$); + } + | TRUE + { + $$ = Trees_NewBoolean(1); + } + | FALSE + { + $$ = Trees_NewBoolean(0); + } + | set + { + $$ = $1; + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), $$); + } + /*NOTE: actual parameters are parsed by rule `designator'*/ + | designator + { + const int isFunctionCall = 1; + Trees_Node designator, actualParameters, ident; + + $$ = NULL; + if (Trees_Symbol($1) == TREES_PROCEDURE_CALL) { + designator = Trees_Left($1); + actualParameters = Trees_Right($1); + HandleProcedureCall(designator, actualParameters, isFunctionCall, &$$); + } else { + ident = Trees_Left($1); + if (Trees_Kind(ident) == TREES_CONSTANT_KIND) { + $$ = Trees_Value(ident); + } else { + $$ = $1; + } + } + assert($$ != NULL); + } + | '(' expression ')' + { + CheckIsValueExpression($2); + $$ = $2; + } + | '~' factor + { + $$ = NULL; + CheckIsValueExpression($2); + if (Types_ExpressionCompatible('~', Trees_Type($2), NULL)) { + if (IsBoolean($2)) { + $$ = Trees_NewBoolean(! Trees_Boolean($2)); + } else { + $$ = Trees_NewNode('~', $2, NULL); + Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), $$); + } + } else { + Oberon_PrintError("error: incompatible type in operation \"~\": %s", TypeString(Trees_Type($2))); + YYABORT; + } + assert($$ != NULL); + } + ; + +designator: + /*NOTE: qualified (imported) identifiers are parsed as field designators and detected semantically*/ + IDENT SelectorOptRep + { + Trees_Node designator, identType, actualParameters; + int parameterListFound; /*possibly empty*/ + + Trees_ReverseList(&$2); /*correct order*/ + designator = Designator($1, $2); + + identType = Trees_Type(BaseIdent(designator)); + SetSelectorTypes(identType, designator, ¶meterListFound); + if (parameterListFound) { + RemoveActualParameters(&designator, &actualParameters); + $$ = Trees_NewNode(TREES_PROCEDURE_CALL, designator, actualParameters); + } else { + $$ = designator; + } + } + ; + +SelectorOptRep: + SelectorOptRep selector + { + Trees_Node curr; + + if ((Trees_Symbol($2) == '[') && (Trees_Right($2) != NULL)) { /*multi-dimensional element selector*/ + /*attatch last element selector node to $1*/ + Trees_ReverseList(&$2); + $$ = $1; + curr = $2; + do { + $$ = Trees_NewNode('[', Trees_Left(curr), $$); + curr = Trees_Right(curr); + } while (curr != NULL); + Trees_ReverseList(&$$); + } else { + $$ = Trees_NewNode(Trees_Symbol($2), Trees_Left($2), $1); + } + } + | /*empty*/ + { + $$ = NULL; + } + ; + +selector: + '.' IDENT + { + Trees_Node field; + + field = Trees_NewIdent($2); + Trees_SetKind(TREES_FIELD_KIND, field); + $$ = Trees_NewNode('.', field, NULL); + } + | '[' ExpList ']' + { + Trees_Node curr, exp; + + /*create one selector node per index*/ + $$ = NULL; + curr = $2; /*NOTE: ExpList is reversed*/ + do { + exp = Trees_Left(curr); + if (Types_IsInteger(Trees_Type(exp))) { + $$ = Trees_NewNode('[', Trees_Left(curr), $$); + } else { + Oberon_PrintError("error: integer array index expected"); + YYABORT; + } + curr = Trees_Right(curr); + } while (curr != NULL); + } + | '^' + { + $$ = Trees_NewNode('^', NULL, NULL); + } + /*NOTE: Procedure calls are parsed as designators and distinguished from type guards through semantic analysis.*/ + | '(' ExpList ')' /*type guard or actual parameters*/ + { + Trees_ReverseList(&$2); /*correct order*/ + $$ = Trees_NewNode('(', $2, NULL); + } + | '(' ')' /*actual parameters*/ + { + $$ = Trees_NewNode('(', NULL, NULL); + } + ; + +set: + '{' '}' + { + $$ = Trees_NewSet(0x0u); + } + | '{' ElementRep '}' + { + $$ = $2; + } + ; + +ElementRep: + element + | ElementRep ',' element + { + if ((Trees_Symbol($1) == TREES_SET_CONSTANT) + && (Trees_Symbol($3) == TREES_SET_CONSTANT)) { + $$ = Trees_NewSet(Trees_Set($1) | Trees_Set($3)); + } else { + $$ = Trees_NewNode('+', $1, $3); + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), $$); + } + } + ; + +element: + expression + { + OBNC_INTEGER i; + Trees_Node type; + + CheckIsValueExpression($1); + $$ = NULL; + type = Trees_Type($1); + if (IsInteger($1)) { + i = Trees_Integer($1); + Range_CheckSetElement(i); + $$ = Trees_NewSet(1u << i); + } else if (Types_IsInteger(type)) { + $$ = Trees_NewNode(TREES_SINGLE_ELEMENT_SET, $1, NULL); + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), $$); + } else { + Oberon_PrintError("error: element must have integer type"); + YYABORT; + } + } + | expression DOTDOT expression + { + CheckIsValueExpression($1); + CheckIsValueExpression($3); + $$ = NULL; + if (IsInteger($1)) { + Range_CheckSetElement(Trees_Integer($1)); + } + if (IsInteger($3)) { + Range_CheckSetElement(Trees_Integer($3)); + } + if (IsInteger($1) && IsInteger($3)) { + $$ = Trees_NewSet(OBNC_RANGE(Trees_Integer($1), Trees_Integer($3))); + } else if (Types_IsInteger(Trees_Type($1)) && Types_IsInteger(Trees_Type($3))) { + $$ = Trees_NewNode(TREES_RANGE_SET, $1, $3); + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), $$); + } else { + Oberon_PrintError("error: element must have integer type"); + YYABORT; + } + } + ; + +ExpList: + expression + { + $$ = Trees_NewNode(TREES_EXP_LIST, $1, NULL); + Trees_SetType(Trees_Type($1), $$); + } + | ExpList ',' expression + { + Trees_Node reversedList; + + reversedList = Trees_NewNode(TREES_EXP_LIST, $3, $1); + $$ = reversedList; + Trees_SetType(Trees_Type($3), $$); + } + ; + + +/*STATEMENT RULES*/ + +statement: + assignment + | ProcedureCall + | IfStatement + | CaseStatement + | WhileStatement + | RepeatStatement + | ForStatement + | /*empty*/ + { + $$ = NULL; + } + ; + +assignment: + designator BECOMES expression + { + Trees_Node designator, ident, designatorType, exp; + + CheckIsValueExpression($3); + switch (Trees_Symbol($1)) { + case TREES_DESIGNATOR: + designator = $1; + exp = $3; + ident = BaseIdent($1); + designatorType = Trees_Type($1); + switch (Trees_Kind(ident)) { + case TREES_VARIABLE_KIND: + case TREES_VALUE_PARAM_KIND: + case TREES_VAR_PARAM_KIND: + if (Writable($1)) { + ValidateAssignment(exp, designatorType, ASSIGNMENT_CONTEXT, 0); + if (Types_IsChar(designatorType) && IsString(exp)) { + exp = Trees_NewChar(Trees_String(exp)[0]); + } + } else { + Oberon_PrintError("error: assignment to read-only variable"); + YYABORT; + } + break; + default: + Oberon_PrintError("error: assignment to non-variable"); + YYABORT; + } + $$ = Trees_NewNode(BECOMES, designator, exp); + break; + case TREES_PROCEDURE_CALL: + Oberon_PrintError("error: unexpected procedure call in assignment target"); + YYABORT; + break; + default: + assert(0); + } + } + ; + +ProcedureCall: + /*NOTE: actual parameters are parsed by rule `designator'*/ + designator + { + const int isFunctionCall = 0; + Trees_Node designator, actualParameters; + + if (Trees_Symbol($1) == TREES_PROCEDURE_CALL) { + designator = Trees_Left($1); + actualParameters = Trees_Right($1); + } else { + designator = $1; + actualParameters = NULL; + } + HandleProcedureCall(designator, actualParameters, isFunctionCall, &$$); + assert($$ != NULL); + } + ; + +StatementSequence: + StatementSequenceReversed + { + Trees_ReverseList(&$1); /*correct order*/ + $$ = $1; + } + ; + +StatementSequenceReversed: + statement + { + if ($1 == NULL) { + $$ = NULL; + } else { + $$ = Trees_NewNode(TREES_STATEMENT_SEQUENCE, $1, NULL); + } + } + | StatementSequenceReversed ';' statement + { + if ($3 != NULL) { + $$ = Trees_NewNode(TREES_STATEMENT_SEQUENCE, $3, $1); + } else { + $$ = $1; + } + } + ; + +IfStatement: + IF guard THEN StatementSequence ElseIfThenOptRep ElseOpt END + { + Trees_Node currElsif, currExp, currThen, currStmt; + + if ($5 == NULL) { + $$ = Trees_NewNode(IF, $2, Trees_NewNode(THEN, $4, $6)); + } else { + /*correct order of elsif nodes*/ + $$ = $6; + currElsif = $5; + do { + currExp = Trees_Left(currElsif); + currThen = Trees_Right(currElsif); + currStmt = Trees_Left(currThen); + $$ = Trees_NewNode(ELSIF, currExp, Trees_NewNode(THEN, currStmt, $$)); + currElsif = Trees_Right(currThen); + } while (currElsif != NULL); + $$ = Trees_NewNode(IF, $2, Trees_NewNode(THEN, $4, $$)); + } + } + ; + +guard: + expression + { + CheckIsValueExpression($1); + if (Types_IsBoolean(Trees_Type($1))) { + $$ = $1; + } else { + Oberon_PrintError("error: boolean expression expected"); + YYABORT; + } + } + ; + +ElseIfThenOptRep: + ElseIfThenOptRep ELSIF guard THEN StatementSequence + { + $$ = Trees_NewNode(ELSIF, $3, Trees_NewNode(THEN, $5, $1)); + } + | /*empty*/ + { + $$ = NULL; + } + ; + +ElseOpt: + ELSE StatementSequence + { + $$ = Trees_NewNode(ELSE, $2, NULL); + } + | /*empty*/ + { + $$ = NULL; + } + ; + +CaseStatement: + CASE CaseExpression OF CaseRep END + { + Trees_Node expType, caseVariable; + + if ($4 != NULL) { + Trees_ReverseList(&$4); /*correct order*/ + } + assert(caseLabelsStack != NULL); + caseLabelsStack = Trees_Right(caseLabelsStack); + expType = Trees_Type($2); + if (Types_IsRecord(expType) || Types_IsPointer(expType)) { + /*reset original type*/ + caseVariable = Trees_Left($2); + Trees_SetType(Trees_Type($2), caseVariable); + caseExpressionStack = Trees_Right(caseExpressionStack); + } + $$ = Trees_NewNode(CASE, $2, $4); + } + ; + +CaseExpression: + expression + { + Trees_Node typeStruct, caseVariable; + + CheckIsValueExpression($1); + typeStruct = Types_Structure(Trees_Type($1)); + switch (Trees_Symbol(typeStruct)) { + case RECORD: + /*fall through*/ + case POINTER: + if (IsDesignator($1) && (FirstSelector($1) == NULL)) { + caseVariable = BaseIdent($1); + if (! Types_IsRecord(typeStruct) || (Trees_Kind(caseVariable) == TREES_VAR_PARAM_KIND)) { + $$ = $1; + } else { + Oberon_PrintError("error: record CASE expression must be a variable parameter"); + YYABORT; + } + } else { + Oberon_PrintError("error: non-integral CASE expression must be a variable"); + YYABORT; + } + /*fall through*/ + case TREES_INTEGER_TYPE: + /*fall through*/ + case TREES_CHAR_TYPE: + caseExpressionStack = Trees_NewNode(TREES_NOSYM, $1, caseExpressionStack); + caseLabelsStack = Trees_NewNode(TREES_NOSYM, NULL, caseLabelsStack); + $$ = $1; + break; + default: + Oberon_PrintError("error: invalid type of CASE expression"); + YYABORT; + } + } + ; + +CaseRep: + case + { + if ($1 != NULL) { + $$ = Trees_NewNode(TREES_CASE_REP, $1, NULL); + } else { + $$ = NULL; + } + } + | CaseRep '|' case + { + if ($3 != NULL) { + if ($1 != NULL) { + $$ = Trees_NewNode(TREES_CASE_REP, $3, $1); + } else { + $$ = Trees_NewNode(TREES_CASE_REP, $3, NULL); + } + } else { + $$ = NULL; + } + } + ; + +case: + CaseLabelList ':' StatementSequence + { + Trees_ReverseList(&$1); /*correct order*/ + $$ = Trees_NewNode(TREES_CASE, $1, $3); + } + | /*empty*/ + { + $$ = NULL; + } + ; + +CaseLabelList: + LabelRange + { + $$ = Trees_NewNode(TREES_CASE_LABEL_LIST, $1, NULL); + } + | CaseLabelList ',' LabelRange + { + switch (Trees_Symbol($3)) { + case INTEGER: + case TREES_CHAR_CONSTANT: + case DOTDOT: + $$ = Trees_NewNode(TREES_CASE_LABEL_LIST, $3, $1); + break; + default: + Oberon_PrintError("error: unexpected list of type name case labels"); + YYABORT; + } + } + ; + +LabelRange: + label + { + $$ = $1; + CheckCaseLabelUniqueness($1); + assert(caseLabelsStack != NULL); + caseLabelsStack = Trees_NewNode(TREES_NOSYM, + Trees_NewNode(TREES_NOSYM, $1, Trees_Left(caseLabelsStack)), + Trees_Right(caseLabelsStack)); + } + | label DOTDOT label + { + const int rangeLenMax = 255; + int leftSym, rightSym; + OBNC_INTEGER rangeMin, rangeMax; + + leftSym = Trees_Symbol($1); + rightSym = Trees_Symbol($3); + if (leftSym == rightSym) { + switch (leftSym) { + case INTEGER: + rangeMin = Trees_Integer($1); + rangeMax = Trees_Integer($3); + if (rangeMin <= rangeMax) { + if (rangeMax - rangeMin > rangeLenMax) { + Oberon_PrintError("warning: maximum range length of %d exceeded", rangeLenMax); + YYABORT; + } + } else { + Oberon_PrintError("error: left integer must be less than right integer in case range"); + YYABORT; + } + break; + case TREES_CHAR_CONSTANT: + if (Trees_Char($1) >= Trees_Char($3)) { + Oberon_PrintError("error: left string must be less than right string in case range"); + YYABORT; + } + break; + default: + Oberon_PrintError("error: case label ranges must contain integers or single-character strings"); + YYABORT; + } + } else { + Oberon_PrintError("error: case labels in a range must have the same type"); + YYABORT; + } + $$ = Trees_NewNode(DOTDOT, $1, $3); + CheckCaseLabelUniqueness($$); + assert(caseLabelsStack != NULL); + caseLabelsStack = Trees_NewNode(TREES_NOSYM, + Trees_NewNode(TREES_NOSYM, $$, Trees_Left(caseLabelsStack)), + Trees_Right(caseLabelsStack)); + } + ; + +label: + INTEGER + { + if (Types_IsInteger(Trees_Type(Trees_Left(caseExpressionStack)))) { + $$ = Trees_NewInteger($1); + } else { + Oberon_PrintError("error: unexpected integer case label"); + YYABORT; + } + } + | STRING + { + if (Types_IsChar(Trees_Type(Trees_Left(caseExpressionStack)))) { + if (strlen($1) <= 1) { + $$ = Trees_NewChar($1[0]); + } else { + Oberon_PrintError("error: single-character string expected: \"%s\"", $1); + YYABORT; + } + } else { + Oberon_PrintError("error: unexpected string case label: \"%s\"", $1); + YYABORT; + } + } + | qualident + { + Trees_Node caseExp, constValue, caseVariable; + + $$ = Table_At(Trees_Name($1)); + if ($$ != NULL) { + caseExp = Trees_Left(caseExpressionStack); + switch (Trees_Symbol(Types_Structure(Trees_Type(caseExp)))) { + case TREES_INTEGER_TYPE: + if (Trees_Kind($$) == TREES_CONSTANT_KIND) { + constValue = Trees_Value($$); + if (Trees_Symbol(constValue) == INTEGER) { + if (Trees_Integer(constValue) >= 0) { + $$ = constValue; + } else { + Oberon_PrintError("error: non-negative case label expected: %" OBNC_INT_MOD "d", Trees_Integer(constValue)); + YYABORT; + } + } else { + Oberon_PrintError("error: integer case label expected"); + YYABORT; + } + } else { + Oberon_PrintError("error: constant identifier expected: %s", Trees_Name($$)); + YYABORT; + } + break; + case TREES_CHAR_TYPE: + if (Trees_Kind($$) == TREES_CONSTANT_KIND) { + constValue = Trees_Value($$); + if (Trees_Symbol(constValue) == STRING) { + if (Types_StringLength(Trees_Type(constValue)) <= 1) { + $$ = Trees_NewChar(Trees_String(constValue)[0]); + } else { + Oberon_PrintError("error: single-character string expected: %s", Trees_String(constValue)); + YYABORT; + } + } else { + Oberon_PrintError("error: character case label expected"); + YYABORT; + } + } else { + Oberon_PrintError("error: constant identifier expected: %s", Trees_Name($$)); + YYABORT; + } + break; + case RECORD: + if (Types_IsType($$) && Types_IsRecord($$)) { + if (Types_Extends(Trees_Type(caseExp), $$)) { + caseVariable = Trees_Left(caseExp); + Trees_SetType($$, caseVariable); + } else { + Oberon_PrintError("error: case label is not an extension of %s: %s", Trees_Name(Trees_Type(caseExp)), Trees_Name($$)); + YYABORT; + } + } else { + Oberon_PrintError("error: record type case label expected"); + YYABORT; + } + break; + case POINTER: + if (Types_IsType($$) && Types_IsPointer($$)) { + if (Types_Extends(Trees_Type(caseExp), $$)) { + caseVariable = Trees_Left(caseExp); + Trees_SetType($$, caseVariable); + } else { + Oberon_PrintError("error: case label is not an extension of %s: %s", Trees_Name(Trees_Type(caseExp)), Trees_Name($$)); + YYABORT; + } + } else { + Oberon_PrintError("error: pointer type case label expected"); + YYABORT; + } + break; + default: + assert(0); + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name($1)); + YYABORT; + } + } + ; + +WhileStatement: + WHILE guard DO StatementSequence ElseIfDoOptRep END + { + $$ = Trees_NewNode(WHILE, $2, Trees_NewNode(DO, $4, $5)); + } + ; + +ElseIfDoOptRep: + ElseIfDoOptRep ELSIF guard DO StatementSequence + { + $$ = Trees_NewNode(ELSIF, $3, Trees_NewNode(THEN, $5, $1)); + } + | /*empty*/ + { + $$ = NULL; + } + ; + +RepeatStatement: + REPEAT StatementSequence UNTIL expression + { + CheckIsValueExpression($4); + $$ = NULL; + if (Types_IsBoolean(Trees_Type($4))) { + $$ = Trees_NewNode(REPEAT, $2, $4); + } else { + Oberon_PrintError("error: boolean expression expected"); + YYABORT; + } + } + ; + + +ForStatement: + FOR ForInit TO ForLimit ByOpt DO StatementSequence END + { + Trees_Node byExp; + + if ($5 != NULL) { + byExp = $5; + } else { + byExp = Trees_NewInteger(1); + } + $$ = Trees_NewNode(FOR, + $2, + Trees_NewNode(TO, + $4, + Trees_NewNode(BY, byExp, $7))); + } + ; + +ForInit: + IDENT BECOMES expression + { + Trees_Node ctrlVar, ctrlVarType; + + CheckIsValueExpression($3); + ctrlVar = Table_At($1); + if (ctrlVar != NULL) { + ctrlVarType = Trees_Type(ctrlVar); + if (Types_IsInteger(ctrlVarType)) { + if (Types_IsInteger(Trees_Type($3))) { + $$ = Trees_NewNode(BECOMES, ctrlVar, $3); + } else { + Oberon_PrintError("error: integer expression expected as initial value"); + YYABORT; + } + } else { + Oberon_PrintError("error: integer control variable expected: %s", $1); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared control variable: %s", $1); + YYABORT; + } + } + +ForLimit: + expression + { + CheckIsValueExpression($1); + if (! Types_IsInteger(Trees_Type($1))) { + Oberon_PrintError("error: integer expression expected as upper limit"); + YYABORT; + } + } + ; + +ByOpt: + BY ConstExpression + { + if (Types_IsInteger(Trees_Type($2))) { + if (IsInteger($2)) { + if (Trees_Integer($2) == 0) { + Oberon_PrintError("warning: steps by zero leads to infinite loop"); + } + $$ = $2; + } else { + Oberon_PrintError("error: fully evaluated constant expression expected as increment"); + YYABORT; + } + } else { + Oberon_PrintError("error: integer increment expected"); + YYABORT; + } + } + | /*empty*/ + { + $$ = NULL; + } + ; + + +/*PROCEDURE DECLARATION RULES*/ + +ProcedureDeclaration: + ProcedureHeading ';' DeclarationSequence StatementSequenceOpt ReturnExpressionOpt END IDENT + { + Trees_Node procIdent, procType, resultType, procStatements, returnExp; + const char *procName; + + procIdent = $1; + procName = Trees_Name(procIdent); + procType = Trees_Type($1); + resultType = Types_ResultType(procType); + procStatements = $4; + returnExp = $5; + + if (strcmp(procName, $7) == 0) { + if (resultType == NULL) { + if (returnExp != NULL) { + Oberon_PrintError("error: unexpected return expression"); + YYABORT; + } + } else { + if (returnExp != NULL) { + CheckIsValueExpression(returnExp); + ValidateAssignment(returnExp, resultType, PROC_RESULT_CONTEXT, 0); + if ((Trees_Symbol(returnExp) == STRING) && Types_IsChar(resultType)) { + returnExp = Trees_NewChar(Trees_String(returnExp)[0]); + } + } else { + Oberon_PrintError("error: return expression expected"); + YYABORT; + } + } + if (procStatements != NULL) { + Generate_ProcedureStatements(procStatements); + } + if (returnExp != NULL) { + Generate_ReturnClause(returnExp); + } + if (procedureDeclarationStack != NULL) { + procedureDeclarationStack = Trees_Right(procedureDeclarationStack); + } + Generate_ProcedureEnd(procIdent); + CheckUnusedIdentifiers(); + Table_CloseScope(); + } else { + Oberon_PrintError("error: expected procedure name: %s", procName); + YYABORT; + } + } + ; + +ProcedureHeading: + ProcedureHeadingSansParam FormalParametersOpt + { + Trees_Node paramList, param; + + $$ = NULL; + Trees_SetType($2, $1); + + paramList = Types_Parameters($2); + while (paramList != NULL) { + param = Trees_Left(paramList); + Table_Put(param); + paramList = Trees_Right(paramList); + } + + procedureDeclarationStack = Trees_NewNode(TREES_NOSYM, $1, procedureDeclarationStack); + Generate_ProcedureHeading($1); + $$ = $1; + } + ; + +ProcedureHeadingSansParam: + PROCEDURE identdef + { + if (! (Trees_Exported($2) && Trees_Local($2))) { + Trees_SetKind(TREES_PROCEDURE_KIND, $2); + Table_Put($2); + Table_OpenScope(); + } else { + Oberon_PrintError("error: cannot export local procedure: %s", Trees_Name($2)); + YYABORT; + } + $$ = $2; + } + ; + +StatementSequenceOpt: + BEGIN_ StatementSequence + { + $$ = $2; + } + | /*empty*/ + { + $$ = NULL; + } + ; + +ReturnExpressionOpt: + RETURN expression + { + $$ = $2; + } + | /*empty*/ + { + $$ = NULL; + } + ; + +DeclarationSequence: + ConstSectionOpt TypeSectionOpt VariableSectionOpt ProcedureDeclarationOptRep + ; + +ConstSectionOpt: + CONST ConstDeclarationOptRep + | /*empty*/ + ; + +ConstDeclarationOptRep: + ConstDeclarationOptRep ConstDeclaration ';' + | /*empty*/ + ; + +TypeSectionOpt: + TypeKeyword TypeDeclarationOptRep + { + Trees_Node unresolvedPointerType, undeclaredBaseType; + + if (unresolvedPointerTypes != NULL) { + unresolvedPointerType = Trees_Left(unresolvedPointerTypes); + undeclaredBaseType = Types_PointerBaseType(unresolvedPointerType); + Oberon_PrintError("error: undeclared pointer base type: %s", Trees_Name(undeclaredBaseType)); + YYABORT; + } + } + | /*empty*/ + { + $$ = NULL; + } + ; + +TypeKeyword: + TYPE + { + unresolvedPointerTypes = NULL; + } + ; + +TypeDeclarationOptRep: + TypeDeclarationOptRep TypeDeclaration ';' + | /*empty*/ + ; + +VariableSectionOpt: + VAR VariableDeclarationOptRep + | /*empty*/ + ; + +VariableDeclarationOptRep: + VariableDeclarationOptRep VariableDeclaration ';' + | /*empty*/ + ; + +ProcedureDeclarationOptRep: + ProcedureDeclarationOptRep ProcedureDeclaration ';' + | /*empty*/ + ; + +FormalParameters: + '(' FPSectionsOpt ')' ResultTypeOpt + { + $$ = Types_NewProcedure($2, $4); + } + ; + +FPSectionsOpt: + FPSectionRep + { + Trees_ReverseList(&$1); /*correct order*/ + $$ = $1; + } + | /*empty*/ + { + $$ = NULL; + } + ; + +FPSectionRep: + FPSection + { + $$ = $1; + Trees_ReverseList(&$$); + } + | FPSectionRep ';' FPSection + { + Trees_Node p, p1; + const char *paramName, *paramName1; + + /*make sure no parameter is repeated*/ + p = $3; + while (p != NULL) { + paramName = Trees_Name(Trees_Left(p)); + p1 = $1; + while (p1 != NULL) { + paramName1 = Trees_Name(Trees_Left(p1)); + if (strcmp(paramName1, paramName) == 0) { + Oberon_PrintError("error: repeated parameter: %s", paramName); + YYABORT; + } + p1 = Trees_Right(p1); + } + p = Trees_Right(p); + } + + /*make one list of the two lists*/ + $$ = $1; + p = $3; + do { + $$ = Trees_NewNode(TREES_IDENT_LIST, Trees_Left(p), $$); + p = Trees_Right(p); + } while (p != NULL); + /*$$ in reversed order*/ + } + ; + +ResultTypeOpt: + ':' qualident + { + $$ = ResolvedType($2, 0); + if ($$ != NULL) { + if (Trees_Symbol($$) == IDENT) { + if (Trees_Kind($$) != TREES_TYPE_KIND) { + Oberon_PrintError("error: type name expected as result type: %s", Trees_Name($2)); + YYABORT; + } + if (! Types_Scalar($$)) { + Oberon_PrintError("error: scalar result type expected: %s", Trees_Name($2)); + YYABORT; + } + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name($2)); + YYABORT; + } + } + | /*empty*/ + { + $$ = NULL; + } + ; + +FPSection: + ParameterKindOpt IdentRep ':' FormalType + { + Trees_Node curr, ident; + + Trees_ReverseList(&$2); /*correct order*/ + curr = $2; + do { + ident = Trees_Left(curr); + Trees_SetKind((int) $1, ident); + Trees_SetType($4, ident); + Trees_SetLocal(ident); + curr = Trees_Right(curr); + } while (curr != NULL); + + $$ = $2; + } + ; + +ParameterKindOpt: + VAR + { + $$ = TREES_VAR_PARAM_KIND; + } + | /*empty*/ + { + $$ = TREES_VALUE_PARAM_KIND; + } + ; + +IdentRep: + IDENT + { + $$ = Trees_NewNode(TREES_IDENT_LIST, Trees_NewIdent($1), NULL); + } + | IdentRep ',' IDENT + { + Trees_Node curr; + const char *identName; + + /*make sure no name is repeated*/ + curr = $1; + while (curr != NULL) { + identName = Trees_Name(Trees_Left(curr)); + if (strcmp(identName, $3) == 0) { + Oberon_PrintError("error: repeated identifier: %s", identName); + YYABORT; + } + curr = Trees_Right(curr); + } + + $$ = Trees_NewNode(TREES_IDENT_LIST, Trees_NewIdent($3), $1); + } + ; + +FormalType: + OpenArrayOptRep qualident + { + $$ = ResolvedType($2, 0); + if ($$ != NULL) { + while ($1 != NULL) { + $$ = Types_NewArray(NULL, $$); + $1 = Trees_Right($1); + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name($2)); + exit(EXIT_FAILURE); + } + } + ; + +OpenArrayOptRep: + OpenArrayOptRep ARRAY OF + { + $$ = Trees_NewNode(ARRAY, NULL, $1); + } + | /*empty*/ + { + $$ = NULL; + } + ; + + +/*MODULE RULES*/ + +module: + ModuleHeading ';' ImportListOpt DeclarationSequence ModuleStatements END IDENT '.' + { + const char *symfilePath; + + if (strcmp($7, inputModuleName) == 0) { + CheckUnusedIdentifiers(); + Generate_ModuleEnd(); + Generate_Close(); + + symfilePath = Util_String(".obnc/%s.sym", inputModuleName); + if (parseMode == OBERON_ENTRY_POINT_MODE) { + if (Files_Exists(symfilePath)) { + Files_Remove(symfilePath); + } + } else { + ExportSymbolTable(symfilePath); + } + YYACCEPT; + } else { + Oberon_PrintError("error: expected identifier %s", inputModuleName); + YYABORT; + } + } + ; + + +ModuleHeading: + MODULE IDENT + { + if (strcmp($2, inputModuleName) == 0) { + if (parseMode != OBERON_IMPORT_LIST_MODE) { + Generate_ModuleHeading(); + } + } else { + Oberon_PrintError("error: module name does not match filename: %s", $2); + YYABORT; + } + } + ; + +ImportListOpt: + ImportList + { + if (parseMode == OBERON_IMPORT_LIST_MODE) { + YYACCEPT; + } + } + | /*empty*/ + { + if (parseMode == OBERON_IMPORT_LIST_MODE) { + YYACCEPT; + } + } + ; + +ImportList: + IMPORT ImportRep ';' + { + const char *impfilePath; + Trees_Node moduleAndDirPath, module, p; + FILE *impFile; + const char *name; + + if ($2 != NULL) { + Trees_ReverseList(&$2); /*correct order*/ + if (parseMode == OBERON_IMPORT_LIST_MODE) { + while ($2 != NULL) { + name = Trees_Name(Trees_Left($2)); + puts(name); + $2 = Trees_Right($2); + } + } else { + if (parseMode == OBERON_NORMAL_MODE) { + impfilePath = Util_String(".obnc/%s.imp", inputModuleName); + impFile = Files_Exists(impfilePath)? Files_Old(impfilePath, FILES_WRITE): Files_New(impfilePath); + p = $2; + do { + moduleAndDirPath = Trees_Left(p); + module = Trees_Left(moduleAndDirPath); + name = Trees_UnaliasedName(module); + fprintf(impFile, "%s\n", name); + p = Trees_Right(p); + } while (p != NULL); + Files_Close(&impFile); + } + Generate_ImportList($2); + } + } + } + ; + +ImportRep: + import + { + if ($1 != NULL) { + $$ = Trees_NewNode(TREES_NOSYM, $1, NULL); + } else { + $$ = NULL; + } + } + | ImportRep ',' import + { + if ($3 != NULL) { + $$ = Trees_NewNode(TREES_NOSYM, $3, $1); + } else { + $$ = $1; + } + } + ; + +import: + IDENT BecomesIdentOpt + { + static Maps_Map importedModules = NULL; + const char *module, *qualifier, *symbolFileDir, *symbolFileName, *moduleDirPath; + Trees_Node qualifierSym, moduleIdent; + + if (importedModules == NULL) { + importedModules = Maps_New(); + } + if ($2 != NULL) { + module = $2; + qualifier = $1; + } else { + module = $1; + qualifier = $1; + } + $$ = NULL; + if (strcmp(module, inputModuleName) != 0) { + if (! Maps_HasKey(module, importedModules)) { + Maps_Put(module, NULL, &importedModules); + qualifierSym = Table_At(qualifier); + if (qualifierSym == NULL) { + qualifierSym = Trees_NewIdent(qualifier); + if ($2 != NULL) { + Trees_SetUnaliasedName(module, qualifierSym); + } + Trees_SetKind(TREES_QUALIFIER_KIND, qualifierSym); + Table_Put(qualifierSym); + + if (strcmp(module, "SYSTEM") == 0) { + if (parseMode != OBERON_IMPORT_LIST_MODE) { + Table_ImportSystem(qualifier); + } + } else if (parseMode == OBERON_IMPORT_LIST_MODE) { + $$ = Trees_NewIdent(module); + } else { + moduleDirPath = ModulePaths_Directory(module, ".", 0); + if (moduleDirPath != NULL) { + /*import identifiers into the symbol table*/ + symbolFileDir = Util_String("%s/.obnc", moduleDirPath); + if (! Files_Exists(symbolFileDir)) { + symbolFileDir = Util_String("%s", moduleDirPath); + } + symbolFileName = Util_String("%s/%s.sym", symbolFileDir, module); + if (Files_Exists(symbolFileName)) { + Table_Import(symbolFileName, module, qualifier); + } else { + Oberon_PrintError("error: symbol file not found for module %s: %s", module, symbolFileName); + YYABORT; + } + + moduleIdent = Trees_NewIdent(module); + Trees_SetKind(TREES_QUALIFIER_KIND, moduleIdent); + $$ = Trees_NewNode(TREES_NOSYM, moduleIdent, Trees_NewString(moduleDirPath)); + } else { + Oberon_PrintError("error: imported module not found: %s", module); + YYABORT; + } + } + } else { + Oberon_PrintError("error: qualifier already used: %s", qualifier); + YYABORT; + } + } else { + Oberon_PrintError("error: module already imported: %s", module); + YYABORT; + } + } else { + Oberon_PrintError("error: a module cannot import itself"); + YYABORT; + } + } + ; + +BecomesIdentOpt: + BECOMES IDENT + { + $$ = $2; + } + | /*empty*/ + { + $$ = NULL; + } + ; + +ModuleStatements: + StatementSequenceOpt + { + Generate_ModuleStatements($1); + } + ; + +%% + +void Oberon_Init(void) +{ + if (! initialized) { + initialized = 1; + Error_Init(); + Files_Init(); + Generate_Init(); + ModulePaths_Init(); + Table_Init(); + } +} + + +void Oberon_Parse(const char inputFile[], int mode) +{ + const char *impFile; + FILE *fp; + int error; + + assert(initialized); + inputFilename = inputFile; + parseMode = mode; + inputModuleName = Paths_SansSuffix(Paths_Basename(inputFile)); + + yyin = fopen(inputFile, "r"); + if (yyin != NULL) { + if (mode != OBERON_IMPORT_LIST_MODE) { + Generate_Open(inputFile, mode == OBERON_ENTRY_POINT_MODE); + + impFile = Util_String(".obnc/%s.imp", inputModuleName); + if (parseMode == OBERON_NORMAL_MODE) { + if (! Files_Exists(impFile)) { + fp = Files_New(impFile); + Files_Close(&fp); + } + } else { + assert(parseMode == OBERON_ENTRY_POINT_MODE); + if (Files_Exists(impFile)) { + Files_Remove(impFile); + } + } + } + error = yyparse(); + if (error) { + exit(EXIT_FAILURE); + } + } else { + Error_Handle(Util_String("error: cannot open file: %s: %s", inputFile, strerror(errno))); + } +} + + +void Oberon_PrintError(const char format[], ...) +{ + va_list ap; + + assert(initialized); + fprintf(stderr, "obnc-compile: %s:%d: ", inputFilename, yylineno); + va_start(ap, format); + vfprintf(stderr, format, ap); + va_end(ap); + fputc('\n', stderr); +} + + +void yyerror(const char msg[]) +{ + Oberon_PrintError("%s", msg); +} + + +static void PrintError(int line, const char format[], ...) + __attribute__ ((format (printf, 2, 3))); + +static void PrintError(int line, const char format[], ...) +{ + va_list ap; + + fprintf(stderr, "obnc-compile: %s:%d: ", inputFilename, line); + va_start(ap, format); + vfprintf(stderr, format, ap); + va_end(ap); + fputc('\n', stderr); +} + + +static char *IdentKindString(int kind) +{ + char *result; + + switch (kind) { + case TREES_CONSTANT_KIND: + result = Util_String("constant"); + break; + case TREES_TYPE_KIND: + result = Util_String("type"); + break; + case TREES_VARIABLE_KIND: + result = Util_String("variable"); + break; + case TREES_PROCEDURE_KIND: + result = Util_String("procedure"); + break; + case TREES_QUALIFIER_KIND: + result = Util_String("module"); + break; + default: + result = Util_String("identifier"); + } + return result; +} + + +static void CheckUnusedIdentifiers(void) +{ + Trees_Node unusedIdents, ident; + int kind; + + unusedIdents = Table_UnusedIdentifiers(); + while (unusedIdents != NULL) { + ident = Trees_Left(unusedIdents); + kind = Trees_Kind(ident); + if (! Trees_Exported(ident) + && (kind != TREES_VALUE_PARAM_KIND) + && (kind != TREES_VAR_PARAM_KIND)) { + PrintError(Trees_LineNumber(ident), "note: unused %s: %s", IdentKindString(Trees_Kind(ident)), Trees_UnaliasedName(ident)); + } + unusedIdents = Trees_Right(unusedIdents); + } +} + + +/*constant predicate functions*/ + +static int IsBoolean(Trees_Node node) +{ + return (Trees_Symbol(node) == TRUE) || (Trees_Symbol(node) == FALSE); +} + + +static int IsChar(Trees_Node node) +{ + return Trees_Symbol(node) == TREES_CHAR_CONSTANT; +} + + +static int IsInteger(Trees_Node node) +{ + return Trees_Symbol(node) == INTEGER; +} + + +static int IsReal(Trees_Node node) +{ + return Trees_Symbol(node) == REAL; +} + + +static int IsString(Trees_Node node) +{ + return Trees_Symbol(node) == STRING; +} + + +static int IsSet(Trees_Node node) +{ + return Trees_Symbol(node) == TREES_SET_CONSTANT; +} + + +/*functions for type declaration productions*/ + +static Trees_Node ResolvedType(Trees_Node type, int isTypeDecl) +{ + Trees_Node result, identDef, typeStruct; + const char *name; + + result = NULL; + if (Trees_Symbol(type) == IDENT) { + name = Trees_Name(type); + identDef = Table_At(name); + if (identDef != NULL) { + if (Trees_Kind(identDef) == TREES_TYPE_KIND) { + typeStruct = Types_Structure(identDef); + if (typeStruct != NULL) { + if (Types_Basic(Trees_Type(identDef)) && ! isTypeDecl) { + result = Trees_Type(identDef); + } else { + result = identDef; + } + } else { + Oberon_PrintError("error: unresolved type: %s", name); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: type expected: %s", name); + exit(EXIT_FAILURE); + } + } + } else { + result = type; + } + return result; +} + + +static void ResolvePointerTypes(Trees_Node baseType) +{ + const char *baseTypeName; + Trees_Node prev, curr, currPointerType, currBaseType; + + assert(Trees_Symbol(baseType) == IDENT); + baseTypeName = Trees_Name(baseType); + + prev = NULL; + curr = unresolvedPointerTypes; + while (curr != NULL) { + currPointerType = Trees_Left(curr); + currBaseType = Types_PointerBaseType(currPointerType); + if (strcmp(Trees_Name(currBaseType), baseTypeName) == 0) { + if (Types_IsRecord(baseType)) { + Trees_SetUsed(baseType); + /*update pointer base type*/ + Types_SetPointerBaseType(baseType, currPointerType); + /*delete current node*/ + if (curr == unresolvedPointerTypes) { + unresolvedPointerTypes = Trees_Right(curr); + } else { + Trees_SetRight(Trees_Right(curr), prev); + } + } else { + Oberon_PrintError("error: record type expected in declaration of pointer base type: %s", baseTypeName); + exit(EXIT_FAILURE); + } + } + prev = curr; + curr = Trees_Right(curr); + } +} + + +static const char *TypeString(Trees_Node type) +{ + const char *result = Util_String("%s", ""); + + assert(Types_IsType(type)); + + switch (Trees_Symbol(Types_Structure(type))) { + case TREES_STRING_TYPE: + switch (Types_StringLength(type)) { + case 0: + result = Util_String("empty string"); + break; + case 1: + result = Util_String("single-char string"); + break; + default: + result = Util_String("multi-char string"); + } + break; + case TREES_BOOLEAN_TYPE: + result = Util_String("BOOLEAN"); + break; + case TREES_CHAR_TYPE: + result = Util_String("CHAR"); + break; + case TREES_INTEGER_TYPE: + result = Util_String("INTEGER"); + break; + case TREES_REAL_TYPE: + result = Util_String("REAL"); + break; + case TREES_BYTE_TYPE: + result = Util_String("BYTE"); + break; + case TREES_SET_TYPE: + result = Util_String("SET"); + break; + case ARRAY: + if (Types_IsOpenArray(type)) { + result = Util_String("open array type"); + } else { + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("array type"); + } + break; + case RECORD: + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("record type"); + break; + case POINTER: + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("pointer type"); + break; + case PROCEDURE: + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("procedure type"); + break; + case TREES_NIL_TYPE: + result = Util_String("NIL"); + break; + default: + assert(0); + } + if (Trees_Symbol(type) == IDENT) { + result = Util_String("%s (%s)", Trees_Name(type), result); + } + return result; +} + + +/*functions for expression productions*/ + +static int IsDesignator(Trees_Node exp) +{ + return Trees_Symbol(exp) == TREES_DESIGNATOR; +} + + +static int IsValueExpression(Trees_Node exp) +{ + int result = 1; + + if (IsDesignator(exp)) { + switch (Trees_Kind(BaseIdent(exp))) { + case TREES_CONSTANT_KIND: + case TREES_FIELD_KIND: + case TREES_VARIABLE_KIND: + case TREES_PROCEDURE_KIND: + case TREES_VALUE_PARAM_KIND: + case TREES_VAR_PARAM_KIND: + break; + default: + result = 0; + } + } + return result; +} + + +static void CheckIsValueExpression(Trees_Node exp) +{ + if (! IsValueExpression(exp)) { + Oberon_PrintError("error: value expected: %s", Trees_Name(BaseIdent(exp))); + exit(EXIT_FAILURE); + } +} + + +static Trees_Node Designator(const char identName[], Trees_Node selectorList) +{ + Trees_Node identSym, qualidentSym, designator, qualidentSelectorList; + const char *qualidentName; + + /*set qualident name, symbol and selector list*/ + qualidentSym = NULL; + qualidentSelectorList = NULL; + identSym = Table_At(identName); + if ((identSym == NULL) && (procedureDeclarationStack != NULL) + && (strcmp(identName, Trees_Name(Trees_Left(procedureDeclarationStack))) == 0)) { + qualidentSym = Trees_Left(procedureDeclarationStack); + qualidentSelectorList = selectorList; + } else { + if (identSym != NULL) { + if (Trees_Kind(identSym) == TREES_QUALIFIER_KIND) { + if ((selectorList != NULL) && (Trees_Symbol(selectorList) == '.')) { + qualidentName = Util_String("%s.%s", identName, Trees_Name(Trees_Left(selectorList))); + qualidentSym = Table_At(qualidentName); + qualidentSelectorList = Trees_Right(selectorList); + if (qualidentSym == NULL) { + Oberon_PrintError("error: undeclared identifier: %s", qualidentName); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: '.' expected after qualifier: %s", identName); + exit(EXIT_FAILURE); + } + } else { + qualidentSym = identSym; + qualidentSelectorList = selectorList; + } + + } else { + Oberon_PrintError("error: undeclared identifier: %s", identName); + exit(EXIT_FAILURE); + } + } + assert(qualidentSym != NULL); + + designator = Trees_NewNode(TREES_DESIGNATOR, qualidentSym, qualidentSelectorList); + + return designator; +} + + +static Trees_Node BaseIdent(Trees_Node designator) +{ + assert(Trees_Symbol(designator) == TREES_DESIGNATOR); + + return Trees_Left(designator); +} + + +static Trees_Node FirstSelector(Trees_Node designator) +{ + assert(Trees_Symbol(designator) == TREES_DESIGNATOR); + + return Trees_Right(designator); +} + + +static void SetSelectorTypes(Trees_Node identType, Trees_Node designator, int *parameterListFound) +{ + Trees_Node currType, currTypeStruct, currSelector, prevSelector, indexExp, lengthNode, pointerNode, expList, extendedType, symbol, varField, typeField, fieldBaseType; + OBNC_INTEGER length, index; + const char *fieldName; + + currType = identType; + currSelector = FirstSelector(designator); + prevSelector = designator; + *parameterListFound = 0; + while ((currSelector != NULL) && ! *parameterListFound) { + currTypeStruct = Types_Structure(currType); + switch (Trees_Symbol(currSelector)) { + case '[': + if ((currTypeStruct != NULL) && (Trees_Symbol(currTypeStruct) == ARRAY)) { + indexExp = Trees_Left(currSelector); + lengthNode = Types_ArrayLength(currTypeStruct); + if ((lengthNode != NULL) && (Trees_Symbol(indexExp) == INTEGER)) { + length = Trees_Integer(lengthNode); + index = Trees_Integer(indexExp); + if ((index < 0) || (index >= length)) { + Oberon_PrintError("error: invalid array index: %" OBNC_INT_MOD "d not between 0 and %" OBNC_INT_MOD "d", index, (OBNC_INTEGER) (length - 1)); + exit(EXIT_FAILURE); + } + } + Trees_SetType(currType, currSelector); + currType = Types_ElementType(currTypeStruct); + } else { + Oberon_PrintError("error: array variable expected in element selector"); + exit(EXIT_FAILURE); + } + break; + case '.': + if (currType != NULL) { + switch (Trees_Symbol(currTypeStruct)) { + case POINTER: + pointerNode = Trees_NewNode('^', NULL, currSelector); + Trees_SetType(currType, pointerNode); + Trees_SetRight(pointerNode, prevSelector); + currType = Types_PointerBaseType(currTypeStruct); + /*fall through*/ + case RECORD: + Trees_SetType(currType, currSelector); + varField = Trees_Left(currSelector); + fieldName = Trees_Name(varField); + Types_GetFieldIdent(fieldName, currType, Trees_Imported(BaseIdent(designator)), &typeField, &fieldBaseType); + if (typeField != NULL) { + if (Trees_Exported(typeField)) { + Trees_SetExported(varField); + } + currType = Trees_Type(typeField); + } else { + Oberon_PrintError("error: undeclared field: %s", fieldName); + exit(EXIT_FAILURE); + } + break; + default: + Oberon_PrintError("error: record variable expected in field selector"); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: record variable expected in field selector"); + exit(EXIT_FAILURE); + } + break; + case '^': + if ((currType != NULL) && (Trees_Symbol(currTypeStruct) == POINTER)) { + Trees_SetType(currType, currSelector); + currType = Types_PointerBaseType(currTypeStruct); + } else { + Oberon_PrintError("error: pointer variable expected in pointer dereference"); + exit(EXIT_FAILURE); + } + break; + case '(': + if (Types_IsProcedure(currTypeStruct)) { + *parameterListFound = 1; + } else if (Types_IsRecord(currTypeStruct) || Types_IsPointer(currTypeStruct)) { + /*type guard*/ + expList = Trees_Left(currSelector); + if (Trees_Right(expList) == NULL) { + if ((Trees_Symbol(Trees_Left(expList)) == TREES_DESIGNATOR) + && (Trees_Right(Trees_Left(expList)) == NULL)) { + extendedType = Trees_Left(Trees_Left(expList)); + symbol = Table_At(Trees_Name(extendedType)); + if (symbol != NULL) { + if (Trees_Kind(symbol) == TREES_TYPE_KIND) { + if ((Types_IsRecord(currType) && Types_IsRecord(Trees_Type(symbol)) + && (Trees_Kind(BaseIdent(designator)) == TREES_VAR_PARAM_KIND)) + || (Types_IsPointer(currType) && Types_IsPointer(Trees_Type(symbol)))) { + if (Types_Extends(currType, Trees_Type(symbol))) { + Trees_SetLeft(extendedType, currSelector); + Trees_SetType(extendedType, currSelector); + currType = extendedType; + } else { + Oberon_PrintError("error: extended type expected: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } else { + if (Types_IsRecord(currType)) { + if (Trees_Kind(BaseIdent(designator)) != TREES_VAR_PARAM_KIND) { + Oberon_PrintError("error: variable parameter expected in type guard"); + } else { + Oberon_PrintError("error: record type expected in type guard: %s", Trees_Name(extendedType)); + } + exit(EXIT_FAILURE); + } else { + Oberon_PrintError("error: pointer type expected in type guard: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } + } else { + Oberon_PrintError("error: type name expected: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: identifier expected in type guard"); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: unexpected comma in type guard"); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: unexpected parenthesis in designator which is not a record, pointer or procedure"); + exit(EXIT_FAILURE); + } + break; + default: + assert(0); + } + prevSelector = currSelector; + currSelector = Trees_Right(currSelector); + } + + if (currSelector == NULL) { + Trees_SetType(currType, designator); + } else { + Oberon_PrintError("error: unexpected selector after procedure call"); + exit(EXIT_FAILURE); + } +} + + +static void RemoveActualParameters(Trees_Node *designator, Trees_Node *actualParameters) +{ + Trees_Node currSelector; + + currSelector = FirstSelector(*designator); + assert(currSelector != NULL); + if (Trees_Right(currSelector) == NULL) { + *actualParameters = Trees_Left(currSelector); + Trees_SetRight(NULL, *designator); + } else { + while (Trees_Right(Trees_Right(currSelector)) != NULL) { + currSelector = Trees_Right(currSelector); + } + *actualParameters = Trees_Left(Trees_Right(currSelector)); + Trees_SetRight(NULL, currSelector); + } +} + + +static int IsConstExpression(Trees_Node exp) +{ + int result = 0; + + assert(exp != NULL); + switch (Trees_Symbol(exp)) { + case TRUE: + case FALSE: + case STRING: + case TREES_CHAR_CONSTANT: + case INTEGER: + case REAL: + case TREES_SET_CONSTANT: + case NIL: + case TREES_SIZE_PROC: /*type sizes cannot always be evaluated in the Oberon-to-C translation*/ + result = 1; + break; + case IDENT: + case TREES_DESIGNATOR: + case TREES_ADR_PROC: + case TREES_BIT_PROC: + result = 0; + break; + default: + result = ((Trees_Left(exp) == NULL) || IsConstExpression(Trees_Left(exp))) + && ((Trees_Right(exp) == NULL) || IsConstExpression(Trees_Right(exp))); + } + return result; +} + + +static Trees_Node ExpressionConstValue(int relation, Trees_Node expA, Trees_Node expB) +{ + Trees_Node result = NULL; + + switch (relation) { + case '=': + switch (Trees_Symbol(expA)) { + case TRUE: + case FALSE: + if (IsBoolean(expB)) { + result = Trees_NewLeaf((Trees_Symbol(expA) == Trees_Symbol(expB))? TRUE: FALSE); + } + break; + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) == Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) == Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) == Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) == Trees_Real(expB))? TRUE: FALSE); + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewLeaf((Trees_Set(expA) == Trees_Set(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] == Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) == 0)? TRUE: FALSE); + } + break; + } + break; + case '#': + switch (Trees_Symbol(expA)) { + case TRUE: + case FALSE: + if (IsBoolean(expB)) { + result = Trees_NewLeaf((Trees_Symbol(expA) != Trees_Symbol(expB))? TRUE: FALSE); + } + break; + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) != Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) != Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) != Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) != Trees_Real(expB))? TRUE: FALSE); + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewLeaf((Trees_Set(expA) != Trees_Set(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] != Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) != 0)? TRUE: FALSE); + } + break; + } + break; + case '<': + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) < Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) < Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) < Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) < Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] < Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) < 0)? TRUE: FALSE); + } + break; + } + break; + case LE: + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) <= Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) <= Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) <= Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) <= Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] <= Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) <= 0)? TRUE: FALSE); + } + break; + } + break; + case '>': + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) > Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) > Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) > Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) > Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] > Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) > 0)? TRUE: FALSE); + } + break; + } + break; + case GE: + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) >= Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) >= Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) >= Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) >= Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] >= Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) >= 0)? TRUE: FALSE); + } + break; + } + break; + case IN: + if (IsInteger(expA)) { + Range_CheckSetElement(Trees_Integer(expA)); + if (IsSet(expB)) { + result = Trees_NewLeaf(OBNC_IN(Trees_Integer(expA), Trees_Set(expB))? TRUE: FALSE); + } + } + break; + } + if (result != NULL) { + Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), result); + } + + return result; +} + + +static Trees_Node SimpleExpressionConstValue(int operator, Trees_Node expA, Trees_Node expB) +{ + Trees_Node result = NULL; + + switch (operator) { + case '+': + switch (Trees_Symbol(expA)) { + case INTEGER: + if (expB == NULL) { + result = expA; + } else if (IsInteger(expB)) { + Range_CheckIntSum(Trees_Integer(expA), Trees_Integer(expB)); + result = Trees_NewInteger(Trees_Integer(expA) + Trees_Integer(expB)); + } + break; + case REAL: + if (expB == NULL) { + result = expA; + } else if (IsReal(expB)) { + Range_CheckRealSum(Trees_Real(expA), Trees_Real(expB)); + result = Trees_NewReal(Trees_Real(expA) + Trees_Real(expB)); + } + break; + case TREES_SET_CONSTANT: + if (expB == NULL) { + result = expA; + } else if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) | Trees_Set(expB)); + } + break; + } + break; + case '-': + switch (Trees_Symbol(expA)) { + case INTEGER: + if (expB == NULL) { + Range_CheckIntDiff(0, Trees_Integer(expA)); + result = Trees_NewInteger(-Trees_Integer(expA)); + } else if (IsInteger(expB)) { + Range_CheckIntDiff(Trees_Integer(expA), Trees_Integer(expB)); + result = Trees_NewInteger(Trees_Integer(expA) - Trees_Integer(expB)); + } + break; + case REAL: + if (expB == NULL) { + Range_CheckRealDiff(0.0, Trees_Real(expA)); + result = Trees_NewReal(-Trees_Real(expA)); + } else if (IsReal(expB)) { + Range_CheckRealDiff(Trees_Real(expA), Trees_Real(expB)); + result = Trees_NewReal(Trees_Real(expA) - Trees_Real(expB)); + } + break; + case TREES_SET_CONSTANT: + if (expB == NULL) { + result = Trees_NewSet(~Trees_Set(expA)); + } else if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) & ~Trees_Set(expB)); + } + break; + } + break; + case OR: + if (IsBoolean(expA) && IsBoolean(expB)) { + result = (Trees_Symbol(expA) == TRUE)? expA: expB; + } + break; + } + + return result; +} + + +static Trees_Node TermConstValue(int operator, Trees_Node expA, Trees_Node expB) +{ + Trees_Node result = NULL; + + switch (operator) { + case '*': + switch (Trees_Symbol(expA)) { + case INTEGER: + if (IsInteger(expB)) { + Range_CheckIntProd(Trees_Integer(expA), Trees_Integer(expB)); + result = Trees_NewInteger(Trees_Integer(expA) * Trees_Integer(expB)); + } + break; + case REAL: + if (IsReal(expB)) { + Range_CheckRealProd(Trees_Real(expA), Trees_Real(expB)); + result = Trees_NewReal(Trees_Real(expA) * Trees_Real(expB)); + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) & Trees_Set(expB)); + } + break; + } + break; + case '/': + switch (Trees_Symbol(expA)) { + case REAL: + if (IsReal(expA) && IsReal(expB)) { + if (Trees_Real(expB) != 0) { + result = Trees_NewReal(Trees_Real(expA) / Trees_Real(expB)); + } else { + Oberon_PrintError("warning: division by zero"); + } + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) ^ Trees_Set(expB)); + } + break; + } + break; + case DIV: + if (IsInteger(expA) && IsInteger(expB)) { + if (Trees_Integer(expB) > 0) { + result = Trees_NewInteger(OBNC_DIV(Trees_Integer(expA), Trees_Integer(expB))); + } else { + Oberon_PrintError("error: positive divisor expected in DIV expression: %" OBNC_INT_MOD "d", Trees_Integer(expB)); + exit(EXIT_FAILURE); + } + } + break; + case MOD: + if (IsInteger(expA) && IsInteger(expB)) { + if (Trees_Integer(expB) > 0) { + result = Trees_NewInteger(OBNC_MOD(Trees_Integer(expA), Trees_Integer(expB))); + } else { + Oberon_PrintError("error: positive divisor expected in MOD expression: %" OBNC_INT_MOD "d", Trees_Integer(expB)); + exit(EXIT_FAILURE); + } + } + break; + case '&': + if (IsBoolean(expA) && IsBoolean(expB)) { + if (Trees_Symbol(expA) == TRUE) { + result = expB; + } else { + result = expA; + } + } + break; + } + + return result; +} + + +static const char *DesignatorString(Trees_Node designator) +{ + const char *baseName, *result; + + assert(IsDesignator(designator)); + + baseName = Trees_Name(BaseIdent(designator)); + if (FirstSelector(designator) != NULL) { + result = Util_String("%s...", baseName); + } else { + result = Util_String("%s", baseName); + } + return result; +} + + +static const char *OperatorString(int operator) +{ + const char *result = ""; + + switch (operator) { + case '+': + result = "+"; + break; + case '-': + result = "-"; + break; + case '*': + result = "*"; + break; + case '/': + result = "/"; + break; + case DIV: + result = "DIV"; + break; + case MOD: + result = "MOD"; + break; + case OR: + result = "OR"; + break; + case '&': + result = "&"; + break; + case '~': + result = "~"; + break; + case '=': + result = "="; + break; + case '#': + result = "#"; + break; + case '<': + result = "<"; + break; + case LE: + result = "<="; + break; + case '>': + result = ">"; + break; + case GE: + result = ">="; + break; + case IN: + result = "IN"; + break; + case IS: + result = "IS"; + break; + default: + assert(0); + } + return result; +} + + +/*functions for statement productions*/ + +static int Writable(Trees_Node designator) +{ + Trees_Node ident, type; + int kind, result; + + assert(IsDesignator(designator)); + + ident = BaseIdent(designator); + kind = Trees_Kind(ident); + type = Trees_Type(ident); + result = ((kind == TREES_VARIABLE_KIND) && ! Trees_Imported(ident)) + || (kind == TREES_VAR_PARAM_KIND) + || ((kind == TREES_VALUE_PARAM_KIND) && ! Types_IsArray(type) && ! Types_IsRecord(type)); + return result; +} + + +static const char *AssignmentErrorContext(int context, int paramPos) +{ + const char *result; + + switch (context) { + case ASSIGNMENT_CONTEXT: + result = Util_String("assignment"); + break; + case PARAM_SUBST_CONTEXT: + assert(paramPos >= 0); + result = Util_String("substitution of parameter %d", paramPos + 1); + break; + case PROC_RESULT_CONTEXT: + result = Util_String("return clause"); + break; + default: + assert(0); + } + return result; +} + + +static void ValidateAssignment(Trees_Node expression, Trees_Node targetType, int context, int paramPos) +{ + const char *errorContext; + + assert(expression != NULL); + assert(targetType != NULL); + assert(context >= 0); + assert(paramPos >= 0); + if (Types_AssignmentCompatible(expression, targetType)) { + if (Types_IsByte(targetType) && IsInteger(expression)) { + Range_CheckByte(Trees_Integer(expression)); + } + } else { + errorContext = AssignmentErrorContext(context, paramPos); + if (IsString(expression) && Types_IsCharacterArray(targetType) && !Types_IsOpenArray(targetType)) { + Oberon_PrintError("error: string too long in %s: %" OBNC_INT_MOD "d + 1 > %" OBNC_INT_MOD "d", errorContext, Types_StringLength(Trees_Type(expression)), Trees_Integer(Types_ArrayLength(targetType))); + exit(EXIT_FAILURE); + } else if (Types_IsPredeclaredProcedure(Trees_Type(expression)) + && Types_IsProcedure(targetType)) { + Oberon_PrintError("error: non-predeclared procedure expected in %s", errorContext); + exit(EXIT_FAILURE); + } else { + Oberon_PrintError("error: incompatible types in %s: %s -> %s", + errorContext, TypeString(Trees_Type(expression)), TypeString(targetType)); + exit(EXIT_FAILURE); + } + } +} + + +static void ValidateActualParameter(Trees_Node actualParam, Trees_Node formalParam, int paramPos, Trees_Node procDesignator) +{ + Trees_Node formalType, actualType; + + formalType = Trees_Type(formalParam); + actualType = Trees_Type(actualParam); + + if ((Trees_Kind(formalParam) == TREES_VALUE_PARAM_KIND) + || (IsDesignator(actualParam) && Writable(actualParam))) { + if (Types_IsOpenArray(formalType)) { + if (! Types_ArrayCompatible(actualType, formalType)) { + Oberon_PrintError("error: array incompatible types in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } else if (Trees_Kind(formalParam) == TREES_VALUE_PARAM_KIND) { + if (! Types_AssignmentCompatible(actualParam, formalType)) { + if (Types_IsString(actualType) && Types_IsCharacterArray(formalType)) { + Oberon_PrintError("error: string too long in substitution of parameter %d: %" OBNC_INT_MOD "d + 1 > %" OBNC_INT_MOD "d", paramPos + 1, Types_StringLength(actualType), Trees_Integer(Types_ArrayLength(formalType))); + } else { + Oberon_PrintError("error: assignment incompatible types in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + } + exit(EXIT_FAILURE); + } + } else if (Trees_Kind(formalParam) == TREES_VAR_PARAM_KIND) { + if (Types_IsRecord(formalType)) { + if (Types_IsRecord(actualType)) { + if (! Types_Extends(formalType, actualType)) { + Oberon_PrintError("error: incompatible record types in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: record expected in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } else { + if (! Types_Same(actualType, formalType)) { + Oberon_PrintError("error: same types expected in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } + } + } else { + Oberon_PrintError("error: writable variable expected in substitution of parameter %d in %s", + paramPos + 1, DesignatorString(procDesignator)); + exit(EXIT_FAILURE); + } +} + + +static void ValidateProcedureCall(Trees_Node expList, Trees_Node fpList, Trees_Node procDesignator) +{ + Trees_Node exp, formalParam, fpType; + int pos; + + pos = 0; + while ((expList != NULL) && (fpList != NULL)) { + exp = Trees_Left(expList); + CheckIsValueExpression(exp); + formalParam = Trees_Left(fpList); + fpType = Trees_Type(formalParam); + ValidateActualParameter(exp, formalParam, pos, procDesignator); + + if (Types_IsChar(fpType) && (Trees_Symbol(exp) == STRING)) { + Trees_SetLeft(Trees_NewChar(Trees_String(exp)[0]), expList); + } + expList = Trees_Right(expList); + fpList = Trees_Right(fpList); + pos++; + } + if ((expList == NULL) && (fpList != NULL)) { + Oberon_PrintError("error: too few actual parameters in procedure call: %s", DesignatorString(procDesignator)); + exit(EXIT_FAILURE); + } else if ((expList != NULL) && (fpList == NULL)) { + Oberon_PrintError("error: too many actual parameters in procedure call: %s", DesignatorString(procDesignator)); + exit(EXIT_FAILURE); + } +} + + +static void ValidateProcedureKind(const char procName[], int functionCallExpected, int isFunctionCall) +{ + if (isFunctionCall && ! functionCallExpected) { + Oberon_PrintError("error: function procedure expected: %s", procName); + exit(EXIT_FAILURE); + } else if (! isFunctionCall && functionCallExpected) { + Oberon_PrintError("error: proper procedure expected: %s", procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateParameterCount(const char procName[], int min, int max, int actual) +{ + assert(min >= 0); + assert(min <= max); + assert(actual >= 0); + + if ((actual < min) || (actual > max)) { + if (min == max) { + Oberon_PrintError("error: %d parameter(s) expected: %s", min, procName); + } else { + Oberon_PrintError("error: %d or %d parameters expected: %s", min, max, procName); + } + exit(EXIT_FAILURE); + } +} + + +static void ValidateTypeParameter(const char procName[], Trees_Node param, int pos) +{ + if (! (IsDesignator(param) && (Trees_Kind(BaseIdent(param)) == TREES_TYPE_KIND))) { + Oberon_PrintError("error: type identifier expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateValueParameter(const char procName[], Trees_Node param, int pos) +{ + if (! IsValueExpression(param)) { + Oberon_PrintError("error: expression expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateVariableParameter(const char procName[], Trees_Node param, int pos) +{ + if (! IsDesignator(param)) { + Oberon_PrintError("error: variable expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } else if (! Writable(param)) { + Oberon_PrintError("error: writable variable expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateScalarParameter(const char procName[], Trees_Node paramType, int pos) +{ + assert(Types_IsType(paramType)); + + if (! Types_Scalar(paramType)) { + Oberon_PrintError("error: scalar type expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateIntegerParameter(const char procName[], Trees_Node param, int pos) +{ + if (! Types_IsInteger(Trees_Type(param))) { + Oberon_PrintError("error: integer expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateRealParameter(const char procName[], Trees_Node param, int pos) +{ + if (! Types_IsReal(Trees_Type(param))) { + Oberon_PrintError("error: parameter of type REAL expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static OBNC_INTEGER TypeSize(Trees_Node type) +{ + OBNC_INTEGER result = 0; + + switch (Trees_Symbol(Types_Structure(type))) { + case TREES_BOOLEAN_TYPE: + result = sizeof (int); + break; + case TREES_CHAR_TYPE: + result = sizeof (char); + break; + case TREES_INTEGER_TYPE: + result = sizeof (OBNC_INTEGER); + break; + case TREES_REAL_TYPE: + result = sizeof (OBNC_REAL); + break; + case TREES_BYTE_TYPE: + result = sizeof (unsigned char); + break; + case TREES_SET_TYPE: + result = sizeof (unsigned OBNC_INTEGER); + break; + case ARRAY: + result = Trees_Integer(Types_ArrayLength(type)) * TypeSize(Types_ElementType(type)); + break; + case RECORD: + case POINTER: + case PROCEDURE: + /*cannot be calculated in the Oberon-to-C translation*/ + break; + default: + assert(0); + } + return result; +} + + +static Trees_Node PredeclaredProcedureAST(const char procName[], Trees_Node expList, int isFunctionCall) +{ + static const struct { const char *name; int symbol; } symbols[] = { + {"ABS", TREES_ABS_PROC}, + {"ASR", TREES_ASR_PROC}, + {"ASSERT", TREES_ASSERT_PROC}, + {"CHR", TREES_CHR_PROC}, + {"DEC", TREES_DEC_PROC}, + {"EXCL", TREES_EXCL_PROC}, + {"FLOOR", TREES_FLOOR_PROC}, + {"FLT", TREES_FLT_PROC}, + {"INC", TREES_INC_PROC}, + {"INCL", TREES_INCL_PROC}, + {"LEN", TREES_LEN_PROC}, + {"LSL", TREES_LSL_PROC}, + {"NEW", TREES_NEW_PROC}, + {"ODD", TREES_ODD_PROC}, + {"ORD", TREES_ORD_PROC}, + {"PACK", TREES_PACK_PROC}, + {"ROR", TREES_ROR_PROC}, + {"UNPK", TREES_UNPK_PROC}, + + {"ADR", TREES_ADR_PROC}, + {"SIZE", TREES_SIZE_PROC}, + {"BIT", TREES_BIT_PROC}, + {"GET", TREES_GET_PROC}, + {"PUT", TREES_PUT_PROC}, + {"COPY", TREES_COPY_PROC}, + {"VAL", TREES_VAL_PROC}}; + + int paramCount, pos, symbol; + Trees_Node curr, resultType, result; + Trees_Node param[3], paramTypes[3]; + const char *unqualProcName; + + /*set actual parameters*/ + paramCount = 0; + curr = expList; + while ((paramCount < LEN(param)) && (curr != NULL)) { + param[paramCount] = Trees_Left(curr); + paramTypes[paramCount] = Trees_Type(Trees_Left(curr)); + paramCount++; + curr = Trees_Right(curr); + } + + /*find procedure symbol*/ + unqualProcName = strchr(procName, '.'); + if (unqualProcName != NULL) { + unqualProcName++; + } else { + unqualProcName = procName; + } + pos = 0; + while ((pos < LEN(symbols)) && (strcmp(symbols[pos].name, unqualProcName) != 0)) { + pos++; + } + assert(pos < LEN(symbols)); + symbol = symbols[pos].symbol; + + /*validate parameters and build syntax tree*/ + result = NULL; + resultType = NULL; + switch (symbol) { + case TREES_ABS_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + switch (Trees_Symbol(Types_Structure(paramTypes[0]))) { + case TREES_INTEGER_TYPE: + if (IsInteger(param[0])) { + result = Trees_NewInteger(OBNC_ABS_INT(Trees_Integer(param[0]))); + } + break; + case TREES_REAL_TYPE: + if (IsReal(param[0])) { + result = Trees_NewReal(OBNC_ABS_FLT(Trees_Real(param[0]))); + } + break; + case TREES_BYTE_TYPE: + /*do nothing*/ + break; + default: + Oberon_PrintError("error: numeric parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + if (result == NULL) { + resultType = paramTypes[0]; + } + break; + case TREES_ODD_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (IsInteger(param[0])) { + result = Trees_NewBoolean(OBNC_ODD(Trees_Integer(param[0]))); + } else { + resultType = Trees_NewLeaf(TREES_BOOLEAN_TYPE); + } + break; + case TREES_LEN_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + if (Types_IsArray(paramTypes[0])) { + if (! Types_IsOpenArray(paramTypes[0])) { + result = Types_ArrayLength(paramTypes[0]); + } else { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + } else { + Oberon_PrintError("error: array parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_LSL_PROC: /*fall through*/ + case TREES_ASR_PROC: /*fall through*/ + case TREES_ROR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + if (IsInteger(param[1])) { + switch (symbol) { + case TREES_LSL_PROC: + Range_CheckLSL(Trees_Integer(param[1])); + break; + case TREES_ASR_PROC: + Range_CheckASR(Trees_Integer(param[1])); + break; + case TREES_ROR_PROC: + Range_CheckROR(Trees_Integer(param[1])); + break; + default: + assert(0); + } + } + if (IsInteger(param[0]) && IsInteger(param[1])) { + switch (symbol) { + case TREES_LSL_PROC: + result = Trees_NewInteger(OBNC_LSL(Trees_Integer(param[0]), Trees_Integer(param[1]))); + break; + case TREES_ASR_PROC: + result = Trees_NewInteger(OBNC_ASR(Trees_Integer(param[0]), Trees_Integer(param[1]))); + break; + case TREES_ROR_PROC: + result = Trees_NewInteger(OBNC_ROR(Trees_Integer(param[0]), Trees_Integer(param[1]))); + break; + default: + assert(0); + } + } + if (result == NULL) { + resultType = paramTypes[0]; + } + break; + case TREES_FLOOR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateRealParameter(procName, param[0], 0); + if (IsReal(param[0])) { + OBNC_REAL x = Trees_Real(param[0]); + Range_CheckFLOOR(x); + result = Trees_NewInteger(OBNC_FLOOR(x)); + } else { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + break; + case TREES_FLT_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (IsInteger(param[0])) { + result = Trees_NewReal(OBNC_FLT(Trees_Integer(param[0]))); + } else { + resultType = Trees_NewLeaf(TREES_REAL_TYPE); + } + break; + case TREES_ORD_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + switch (Trees_Symbol(Types_Structure(paramTypes[0]))) { + case TREES_CHAR_TYPE: + /*do nothing*/ + break; + case TREES_STRING_TYPE: + if (Types_StringLength(paramTypes[0]) <= 1) { + result = Trees_NewInteger((unsigned char) Trees_String(param[0])[0]); + } else { + Oberon_PrintError("error: single-character string parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_BOOLEAN_TYPE: + if (Trees_Symbol(param[0]) == TRUE) { + result = Trees_NewInteger(1); + } else if (Trees_Symbol(param[0]) == FALSE) { + result = Trees_NewInteger(0); + } + break; + case TREES_SET_TYPE: + if (IsSet(param[0])) { + result = Trees_NewInteger((OBNC_INTEGER) Trees_Set(param[0])); + } + break; + default: + Oberon_PrintError("error: character parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + if (result == NULL) { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + break; + case TREES_CHR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (IsInteger(param[0])) { + OBNC_INTEGER i = Trees_Integer(param[0]); + Range_CheckCHR(i); + result = Trees_NewChar(OBNC_CHR(i)); + } else { + resultType = Trees_NewLeaf(TREES_CHAR_TYPE); + } + break; + case TREES_INC_PROC: /*fall through*/ + case TREES_DEC_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (paramCount == 2) { + ValidateIntegerParameter(procName, param[1], 1); + } + break; + case TREES_INCL_PROC: /*fall through*/ + case TREES_EXCL_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + if (Types_IsSet(paramTypes[0])) { + if (IsInteger(param[1])) { + Range_CheckSetElement(Trees_Integer(param[1])); + } else { + ValidateIntegerParameter(procName, param[1], 1); + } + } else { + Oberon_PrintError("error: set expected in substitution of parameter 1: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_ASSERT_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + if (! Types_IsBoolean(paramTypes[0])) { + Oberon_PrintError("error: boolean parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_NEW_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateVariableParameter(procName, param[0], 0); + if (! Types_IsPointer(paramTypes[0])) { + Oberon_PrintError("error: pointer parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_PACK_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateRealParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + break; + case TREES_UNPK_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateRealParameter(procName, param[0], 0); + ValidateVariableParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + break; + case TREES_ADR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateVariableParameter(procName, param[0], 0); + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + break; + case TREES_SIZE_PROC: + { + OBNC_INTEGER size; + + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateTypeParameter(procName, param[0], 0); + size = TypeSize(Trees_Type(BaseIdent(param[0]))); + if (size > 0) { + result = Trees_NewInteger(size); + } else { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + } + break; + case TREES_BIT_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + if (IsInteger(param[1])) { + Range_CheckBIT(Trees_Integer(param[1])); + } + resultType = Trees_NewLeaf(TREES_BOOLEAN_TYPE); + break; + case TREES_GET_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateVariableParameter(procName, param[1], 1); + if (! Types_Basic(paramTypes[1])) { + Oberon_PrintError("error: variable of basic type expected in substitution of parameter 2: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_PUT_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + if (! Types_Basic(paramTypes[1]) && ! Types_IsSingleCharString(paramTypes[1])) { + Oberon_PrintError("error: expression of basic type expected in substitution of parameter 2: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_COPY_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 3, 3, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + ValidateValueParameter(procName, param[2], 2); + ValidateIntegerParameter(procName, param[2], 2); + if (IsInteger(param[2]) && (Trees_Integer(param[2]) < 0)) { + Oberon_PrintError("warning: non-negative count expected in %s: %" OBNC_INT_MOD "d", procName, Trees_Integer(param[2])); + } + break; + case TREES_VAL_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateTypeParameter(procName, param[0], 0); + ValidateScalarParameter(procName, paramTypes[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateScalarParameter(procName, paramTypes[1], 1); + resultType = paramTypes[0]; + if (IsConstExpression(param[1])) { + result = param[1]; + Trees_SetType(resultType, result); + } + break; + default: + assert(0); + } + + if (result == NULL) { + result = Trees_NewNode(symbol, expList, NULL); + if (isFunctionCall) { + assert(resultType != NULL); + Trees_SetType(resultType, result); + } + } + return result; +} + + +static void HandleProcedureCall(Trees_Node designator, Trees_Node expList, int isFunctionCall, Trees_Node *ast) +{ + Trees_Node ident, designatorTypeStruct, fpList, resultType; + + ident = BaseIdent(designator); + if (Types_IsPredeclaredProcedure(Trees_Type(ident))) { + *ast = PredeclaredProcedureAST(Trees_Name(ident), expList, isFunctionCall); + if (*ast == NULL) { + Oberon_PrintError("error: procedure expected"); + exit(EXIT_FAILURE); + } + } else { + /*handle non-predeclared procedure*/ + designatorTypeStruct = Types_Structure(Trees_Type(designator)); + if (Types_IsProcedure(designatorTypeStruct)) { + fpList =Types_Parameters(designatorTypeStruct); + resultType = Types_ResultType(designatorTypeStruct); + ValidateProcedureCall(expList, fpList, designator); + *ast = Trees_NewNode(TREES_PROCEDURE_CALL, designator, expList); + if (isFunctionCall) { + if (resultType != NULL) { + Trees_SetType(resultType, *ast); + } else { + Oberon_PrintError("error: function procedure expected: %s", Trees_Name(ident)); + exit(EXIT_FAILURE); + } + } else if (resultType != NULL) { + Oberon_PrintError("error: proper procedure expected: %s", Trees_Name(ident)); + exit(EXIT_FAILURE); + } + } + } + assert(*ast != NULL); +} + + +static void CheckIntegerLabelDisjointness(Trees_Node rangeA, Trees_Node rangeB) +{ + OBNC_INTEGER aMin, aMax, bMin, bMax; + + if (Trees_Symbol(rangeA) == DOTDOT) { + aMin = Trees_Integer(Trees_Left(rangeA)); + aMax = Trees_Integer(Trees_Right(rangeA)); + } else { + aMin = Trees_Integer(rangeA); + aMax = Trees_Integer(rangeA); + } + if (Trees_Symbol(rangeB) == DOTDOT) { + bMin = Trees_Integer(Trees_Left(rangeB)); + bMax = Trees_Integer(Trees_Right(rangeB)); + } else { + bMin = Trees_Integer(rangeB); + bMax = Trees_Integer(rangeB); + } + + if ((aMin >= bMin) && (aMin <= bMax)) { + Oberon_PrintError("error: case label defined twice: %" OBNC_INT_MOD "d", aMin); + exit(EXIT_FAILURE); + } else if ((bMin >= aMin) && (bMin <= aMax)) { + Oberon_PrintError("error: case label defined twice: %" OBNC_INT_MOD "d", bMin); + exit(EXIT_FAILURE); + } +} + + +static void CheckCharLabelDisjointness(Trees_Node rangeA, Trees_Node rangeB) +{ + char aMin, aMax, bMin, bMax; + int hasRepeatedLabel, repeatedLabel; + + if (Trees_Symbol(rangeA) == DOTDOT) { + aMin = Trees_Char(Trees_Left(rangeA)); + aMax = Trees_Char(Trees_Right(rangeA)); + } else { + aMin = Trees_Char(rangeA); + aMax = Trees_Char(rangeA); + } + if (Trees_Symbol(rangeB) == DOTDOT) { + bMin = Trees_Char(Trees_Left(rangeB)); + bMax = Trees_Char(Trees_Right(rangeB)); + } else { + bMin = Trees_Char(rangeB); + bMax = Trees_Char(rangeB); + } + + if ((aMin >= bMin) && (aMin <= bMax)) { + hasRepeatedLabel = 1; + repeatedLabel = aMin; + } else if ((bMin >= aMin) && (bMin <= aMax)) { + hasRepeatedLabel = 1; + repeatedLabel = bMin; + } else { + hasRepeatedLabel = 0; + } + if (hasRepeatedLabel) { + if (isprint(repeatedLabel)) { + Oberon_PrintError("error: case label defined twice: \"%c\"", repeatedLabel); + } else { + Oberon_PrintError("error: case label defined twice: 0%XX", repeatedLabel); + } + exit(EXIT_FAILURE); + } +} + + +static void CheckCaseLabelUniqueness(Trees_Node newLabelRange) +{ + int labelSymbol; + Trees_Node labelList, definedLabelRange; + + if (Trees_Symbol(newLabelRange) == DOTDOT) { + labelSymbol = Trees_Symbol(Trees_Left(newLabelRange)); + } else { + labelSymbol = Trees_Symbol(newLabelRange); + } + + labelList = Trees_Left(caseLabelsStack); + while (labelList != NULL) { + definedLabelRange = Trees_Left(labelList); + switch (labelSymbol) { + case INTEGER: + CheckIntegerLabelDisjointness(definedLabelRange, newLabelRange); + break; + case TREES_CHAR_CONSTANT: + CheckCharLabelDisjointness(definedLabelRange, newLabelRange); + break; + case IDENT: + if (Types_Same(definedLabelRange, newLabelRange)) { + Oberon_PrintError("error: type case label defined twice: %s", Trees_Name(newLabelRange)); + exit(EXIT_FAILURE); + } + break; + default: + assert(0); + } + labelList = Trees_Right(labelList); + } +} + + +/*functions for module productions*/ + +static void ExportSymbolTable(const char symfilePath[]) +{ + const char *tempSymfilePath; + + if (! Files_Exists(".obnc")) { + Files_CreateDir(".obnc"); + } + tempSymfilePath = Util_String(".obnc/%s.sym.%d", inputModuleName, getpid()); + Table_Export(tempSymfilePath); + Files_Move(tempSymfilePath, symfilePath); +} diff --git a/src/Paths.c b/src/Paths.c new file mode 100644 index 0000000..e2ce7ef --- /dev/null +++ b/src/Paths.c @@ -0,0 +1,114 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Paths.h" +#include "Util.h" +#include /*POSIX*/ +#include /*POSIX*/ +#include +#include +#include +#include +#include + +int Paths_Absolute(const char path[]) +{ + assert(path != NULL); +#ifdef _WIN32 + return (path[0] == '\\') || ((strlen(path) >= 2) && isalpha(path[0]) && (path[1] == ':')); +#else + return path[0] == '/'; +#endif +} + + +char *Paths_Dirname(const char path[]) +{ + /*NOTE: We need to copy the string twice since "The dirname() function may modify the string pointed to by path, and may return a pointer to static storage that may then be overwritten by a subsequent call to dirname()."*/ + assert(path != NULL); + + return Util_String("%s", dirname(Util_String("%s", path))); +} + + +char *Paths_Basename(const char path[]) +{ + /*NOTE: We need to copy the string twice since "The basename() function may modify the string pointed to by path, and may return a pointer to internal storage. The returned pointer might be invalidated or the storage might be overwritten by a subsequent call to basename()."*/ + assert(path != NULL); + + return Util_String("%s", basename(Util_String("%s", path))); +} + + +char *Paths_SansSuffix(const char path[]) +{ + char *baseName, *suffix; + + baseName = Paths_Basename(path); + suffix = strchr(baseName, '.'); + if (suffix != NULL) { + suffix[0] = '\0'; + } + return baseName; +} + + +const char *Paths_ShellArg(const char s[]) +{ + int i; + const char *result; + + i = 0; + while ((s[i] != '\0') && ! isspace(s[i])) { + i++; + } + if (s[i] == '\0') { + result = s; + } else { +#ifdef _WIN32 + /*cmd.com doesn't accept single quotes*/ + result = Util_String("\"%s\"", s); +#else + result = Util_String("'%s'", Util_Replace("'", "'\"'\"'", s)); +#endif + } +#ifdef _WIN32 + /*use Windows directory separator in paths*/ + result = Util_Replace("/", "\\", result); +#endif + return result; +} + + +char *Paths_CurrentDir(void) +{ + static char *result = NULL; + static char dir[PATH_MAX + 1]; + const char *p; + + if (result == NULL) { + p = getcwd(dir, sizeof dir); + if (p != NULL) { + result = Util_String("%s", dir); + } else { + fprintf(stderr, "error: cannot get current directory: %s\n", strerror(errno)); + exit(EXIT_FAILURE); + } + } + assert(result != NULL); + return result; +} diff --git a/src/Paths.h b/src/Paths.h new file mode 100644 index 0000000..61ef40b --- /dev/null +++ b/src/Paths.h @@ -0,0 +1,33 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef PATHS_H +#define PATHS_H + +int Paths_Absolute(const char path[]); + +char *Paths_Dirname(const char path[]); + +char *Paths_Basename(const char path[]); + +char *Paths_SansSuffix(const char path[]); + +const char *Paths_ShellArg(const char arg[]); + +char *Paths_CurrentDir(void); + +#endif diff --git a/src/Range.c b/src/Range.c new file mode 100644 index 0000000..aed6fdc --- /dev/null +++ b/src/Range.c @@ -0,0 +1,181 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Range.h" +#include "Oberon.h" +#include +#include +#include + +#define SHIFT_COUNT_MAX ((int) (CHAR_BIT * sizeof (OBNC_INTEGER) - 1)) +#define SET_ELEMENT_MAX ((int) (CHAR_BIT * sizeof (unsigned OBNC_INTEGER) - 1)) + +void Range_CheckIntSum(OBNC_INTEGER a, OBNC_INTEGER b) +{ + if ((b > 0) && (a > OBNC_INT_MAX - b)) { + Oberon_PrintError("warning: integer overflow: %" OBNC_INT_MOD "d + %" OBNC_INT_MOD "d > %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MAX); + } else if ((b < 0) && (a < OBNC_INT_MIN - b)) { + Oberon_PrintError("warning: integer overflow: %" OBNC_INT_MOD "d + (%" OBNC_INT_MOD "d) < %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MIN); + } +} + + +void Range_CheckIntDiff(OBNC_INTEGER a, OBNC_INTEGER b) +{ + if ((b < 0) && (a > OBNC_INT_MAX + b)) { + Oberon_PrintError("warning: integer overflow: %" OBNC_INT_MOD "d - (%" OBNC_INT_MOD "d) > %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MAX); + } else if ((b > 0) && (a < OBNC_INT_MIN + b)) { + Oberon_PrintError("warning: integer overflow: %" OBNC_INT_MOD "d - %" OBNC_INT_MOD "d < %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MIN); + } +} + + +void Range_CheckIntProd(OBNC_INTEGER a, OBNC_INTEGER b) +{ + if (b > 0) { + if ((a > 0) && (a > OBNC_INT_MAX / b)) { + Oberon_PrintError("warning: integer overflow: %" OBNC_INT_MOD "d * %" OBNC_INT_MOD "d > %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MAX); + } else if ((a < 0) && (a < OBNC_INT_MIN / b)) { + Oberon_PrintError("warning: integer overflow: (%" OBNC_INT_MOD "d) * %" OBNC_INT_MOD "d < %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MIN); + } + } else if (b < 0) { + if ((a > 0) && (a < OBNC_INT_MIN / b)) { + Oberon_PrintError("warning: integer overflow: %" OBNC_INT_MOD "d * (%" OBNC_INT_MOD "d) < %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MIN); + } else if ((a < 0) && (a < OBNC_INT_MAX / b)) { + Oberon_PrintError("warning: integer overflow: (%" OBNC_INT_MOD "d) * (%" OBNC_INT_MOD "d) > %" OBNC_INT_MOD "d", a, b, (OBNC_INTEGER) OBNC_INT_MAX); + } + } +} + + +void Range_CheckLSL(OBNC_INTEGER n) +{ + if (n < 0) { + Oberon_PrintError("warning: negative left shift count: %" OBNC_INT_MOD "d < 0", n); + } else if (n > SHIFT_COUNT_MAX ) { + Oberon_PrintError("warning: left shift count exceeds maximum: %" OBNC_INT_MOD "d > %lu", n, (long unsigned int) SHIFT_COUNT_MAX); + } +} + + +void Range_CheckASR(OBNC_INTEGER n) +{ + if (n < 0) { + Oberon_PrintError("warning: negative right shift count: %" OBNC_INT_MOD "d < 0", n); + } else if (n > SHIFT_COUNT_MAX) { + Oberon_PrintError("warning: right shift count exceeds maximum: %" OBNC_INT_MOD "d > %lu", n, (long unsigned int) SHIFT_COUNT_MAX); + } +} + + +void Range_CheckROR(OBNC_INTEGER n) +{ + if (n < 1) { + Oberon_PrintError("warning: non-positive rotation: %" OBNC_INT_MOD "d", n); + } else if (n > SHIFT_COUNT_MAX) { + Oberon_PrintError("warning: rotation exceeds maximum: %" OBNC_INT_MOD "d > %lu", n, (long unsigned int) SHIFT_COUNT_MAX); + } +} + + +void Range_CheckBIT(OBNC_INTEGER n) +{ + if (n < 0) { + Oberon_PrintError("warning: negative bit position: %" OBNC_INT_MOD "d < 0", n); + } else if (n > SHIFT_COUNT_MAX) { + Oberon_PrintError("warning: bit position exceeds maximum: %" OBNC_INT_MOD "d > %lu", n, (long unsigned int) SHIFT_COUNT_MAX); + } +} + + +void Range_CheckFLOOR(OBNC_REAL x) +{ + if (x < (OBNC_REAL) INT_MIN) { + Oberon_PrintError("warning: parameter in FLOOR too large for truncation to INTEGER: %" OBNC_REAL_MOD_W "E < %" OBNC_REAL_MOD_W "E", x, (OBNC_REAL) INT_MIN); + } else if (x >= (OBNC_REAL) INT_MAX + 1.0) { + Oberon_PrintError("warning: parameter in FLOOR too large for truncation to INTEGER: %" OBNC_REAL_MOD_W "E >= %" OBNC_REAL_MOD_W "E", x, (OBNC_REAL) INT_MAX + 1.0); + } +} + + +void Range_CheckCHR(OBNC_INTEGER n) +{ + if (n < 0) { + Oberon_PrintError("warning: negative parameter in CHR: %" OBNC_INT_MOD "d", n); + } else if (n > CHAR_MAX) { + Oberon_PrintError("warning: parameter in CHR too large for conversion: %" OBNC_INT_MOD "d > %d", n, CHAR_MAX); + } +} + + +void Range_CheckRealSum(OBNC_REAL x, OBNC_REAL y) +{ + if ((y > 0.0) && (x > OBNC_REAL_MAX - y)) { + Oberon_PrintError("warning: real number overflow: %" OBNC_REAL_MOD_W "G + %" OBNC_REAL_MOD_W "G > %" OBNC_REAL_MOD_W "G", x, y, OBNC_REAL_MAX); + } else if ((y < 0.0) && (x < -OBNC_REAL_MAX - y)) { + Oberon_PrintError("warning: real number overflow: %" OBNC_REAL_MOD_W "G + (%" OBNC_REAL_MOD_W "G) < %" OBNC_REAL_MOD_W "G", x, y, -OBNC_REAL_MAX); + } +} + + +void Range_CheckRealDiff(OBNC_REAL x, OBNC_REAL y) +{ + if ((y < 0.0) && (x > OBNC_REAL_MAX + y)) { + Oberon_PrintError("warning: real number overflow: %" OBNC_REAL_MOD_W "G - (%" OBNC_REAL_MOD_W "G) > %" OBNC_REAL_MOD_W "G", x, y, OBNC_REAL_MAX); + } else if ((y > 0.0) && (x < -OBNC_REAL_MAX + y)) { + Oberon_PrintError("warning: real number overflow: %" OBNC_REAL_MOD_W "G - %" OBNC_REAL_MOD_W "G < %" OBNC_REAL_MOD_W "G", x, y, -OBNC_REAL_MAX); + } +} + + +void Range_CheckRealProd(OBNC_REAL x, OBNC_REAL y) +{ + if (y > 0.0) { + if ((x > 0.0) && (x > OBNC_REAL_MAX / y)) { + Oberon_PrintError("warning: real number overflow: %" OBNC_REAL_MOD_W "G * %" OBNC_REAL_MOD_W "G > %" OBNC_REAL_MOD_W "G", x, y, OBNC_REAL_MAX); + } else if ((x < 0.0) && (x < -OBNC_REAL_MAX / y)) { + Oberon_PrintError("warning: real number overflow: (%" OBNC_REAL_MOD_W "G) * %" OBNC_REAL_MOD_W "G < %" OBNC_REAL_MOD_W "G", x, y, -OBNC_REAL_MAX); + } + } else if (y < 0.0) { + if ((x > 0.0) && (x < -OBNC_REAL_MAX / y)) { + Oberon_PrintError("warning: real number overflow: %" OBNC_REAL_MOD_W "G * (%" OBNC_REAL_MOD_W "G) < %" OBNC_REAL_MOD_W "G", x, y, -OBNC_REAL_MAX); + } else if ((x < 0.0) && (x < OBNC_REAL_MAX / y)) { + Oberon_PrintError("warning: real number overflow: (%" OBNC_REAL_MOD_W "G) * (%" OBNC_REAL_MOD_W "G) > %" OBNC_REAL_MOD_W "G", x, y, OBNC_REAL_MAX); + } + } +} + + +void Range_CheckByte(OBNC_INTEGER n) +{ + if (n < 0) { + Oberon_PrintError("warning: value less than BYTE minimum: %" OBNC_INT_MOD "d < 0", n); + } else if (n > UCHAR_MAX) { + Oberon_PrintError("warning: BYTE maximum exceeded: %" OBNC_INT_MOD "d > %d", n, UCHAR_MAX); + } +} + + +void Range_CheckSetElement(OBNC_INTEGER x) +{ + if (x < 0) { + Oberon_PrintError("error: negative set element: %" OBNC_INT_MOD "d", x); + exit(EXIT_FAILURE); + } else if (x > SET_ELEMENT_MAX) { + Oberon_PrintError("warning: set element exceededs maximum: %" OBNC_INT_MOD "d > %lu", x, (long unsigned int) SET_ELEMENT_MAX); + } +} diff --git a/src/Range.h b/src/Range.h new file mode 100644 index 0000000..72c8872 --- /dev/null +++ b/src/Range.h @@ -0,0 +1,51 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef RANGE_H +#define RANGE_H + +#include "../lib/obnc/OBNC.h" + +void Range_CheckIntSum(OBNC_INTEGER a, OBNC_INTEGER b); + +void Range_CheckIntDiff(OBNC_INTEGER a, OBNC_INTEGER b); + +void Range_CheckIntProd(OBNC_INTEGER a, OBNC_INTEGER b); + +void Range_CheckLSL(OBNC_INTEGER n); + +void Range_CheckASR(OBNC_INTEGER n); + +void Range_CheckROR(OBNC_INTEGER n); + +void Range_CheckBIT(OBNC_INTEGER n); + +void Range_CheckFLOOR(OBNC_REAL x); + +void Range_CheckCHR(OBNC_INTEGER n); + +void Range_CheckRealSum(OBNC_REAL x, OBNC_REAL y); + +void Range_CheckRealDiff(OBNC_REAL x, OBNC_REAL y); + +void Range_CheckRealProd(OBNC_REAL x, OBNC_REAL y); + +void Range_CheckByte(OBNC_INTEGER n); + +void Range_CheckSetElement(OBNC_INTEGER x); + +#endif diff --git a/src/StackTrace.c b/src/StackTrace.c new file mode 100644 index 0000000..4e45555 --- /dev/null +++ b/src/StackTrace.c @@ -0,0 +1,28 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "StackTrace.h" + +#ifdef __linux__ + #include "StackTraceLinux.c" +#else + +void StackTrace_Init(StackTrace_ContextPrinter f) +{ +} + +#endif diff --git a/src/StackTrace.h b/src/StackTrace.h new file mode 100644 index 0000000..f3afeca --- /dev/null +++ b/src/StackTrace.h @@ -0,0 +1,27 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef STACKTRACE_H +#define STACKTRACE_H + +#define STACKTRACE_MAXLEN 10 + +typedef void (*StackTrace_ContextPrinter)(void); + +void StackTrace_Init(StackTrace_ContextPrinter f); + +#endif diff --git a/src/StackTraceLinux.c b/src/StackTraceLinux.c new file mode 100644 index 0000000..fec04cf --- /dev/null +++ b/src/StackTraceLinux.c @@ -0,0 +1,125 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "StackTrace.h" +#include "Util.h" +#include /*GNU specific*/ +#include /*POSIX*/ +#include +#include +#include +#include + +static StackTrace_ContextPrinter printContext; + +static void ScanFilenameAndOffset(const char line[], char **filename, char **offset, int *done) +{ + const char *leftParenPtr, *plusPtr, *rightParenPtr; + ptrdiff_t exeFileLen, offsetLen; + + *filename = NULL; + *offset = NULL; + *done = 0; + leftParenPtr = strrchr(line, '('); + if (leftParenPtr != NULL) { + /*scan filename*/ + exeFileLen = leftParenPtr - line + 1; + assert(exeFileLen > 0); + NEW_ARRAY(*filename, exeFileLen); + memcpy(*filename, line, (size_t) exeFileLen - 1); + (*filename)[exeFileLen - 1] = '\0'; + + /*scan file offset*/ + plusPtr = strrchr(line, '+'); + if (plusPtr != NULL) { + rightParenPtr = strrchr(line, ')'); + if (rightParenPtr != 0) { + offsetLen = rightParenPtr - plusPtr - 1 + 1; + assert(offsetLen > 0); + NEW_ARRAY(*offset, offsetLen); + memcpy(*offset, plusPtr + 1, (size_t) offsetLen - 1); + (*offset)[offsetLen - 1] = '\0'; + *done = 1; + } + } + } +} + + +static void PrintSourceFilePosition(const char binFilename[], const char offset[]) +{ + const char *command; + int error; + + command = Util_String("addr2line -f -e %s %s | grep -v '^?' | sed 's|^/|\t/|' >&2", binFilename, offset); + error = system(command); + if (error) { + fprintf(stderr, "command to print stack trace failed: %s\n", command); + } +} + + +static void PrintStackTrace(int signum) +{ + void *returnAddresses[STACKTRACE_MAXLEN]; + int count, lineNum; + char **lines; + int done; + char *filename, *offset; + + (void) signum; /*prevent "unused" warning*/ + + if (printContext != NULL) { + printContext(); + fprintf(stderr, "\n"); + } + count = backtrace(returnAddresses, LEN(returnAddresses)); + lines = backtrace_symbols(returnAddresses, count); + fprintf(stderr, "Fatal signal raised, stack trace:\n"); + for (lineNum = 0; lineNum < count; lineNum++) { + ScanFilenameAndOffset(lines[lineNum], &filename, &offset, &done); + if (done) { + PrintSourceFilePosition(filename, offset); + } else { + fprintf(stderr, "warning: failed getting filename and offset from backtrace\n"); + } + } + free(lines); +} + + +void StackTrace_Init(StackTrace_ContextPrinter f) +{ + static int initialized = 0; + static const int fatalSignals[] = {SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, /*SIGKILL,*/ SIGPIPE, SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2}; + int i; + void (*prevHandler)(int signum); + + if (! initialized) { + printContext = f; + + /*register signal handler for fatal signals*/ + for (i = 0; i < LEN(fatalSignals); i++) { + prevHandler = signal(fatalSignals[i], PrintStackTrace); + if (prevHandler == SIG_ERR) { + fprintf(stderr, "warning: setting signal handler for PrintStackTrace failed: signal: %d\n", fatalSignals[i]); + } /*else if (prevHandler != NULL) { + fprintf(stderr, "replacing previous signal handler with PrintStackTrace\n"); + }*/ + } + } +} diff --git a/src/Table.c b/src/Table.c new file mode 100644 index 0000000..c41eda2 --- /dev/null +++ b/src/Table.c @@ -0,0 +1,1325 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Table.h" +#include "Config.h" +#include "Files.h" +#include "Maps.h" +#include "Trees.h" +#include "Types.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" +#include "y.tab.h" +#include +#include +#include +#include +#include +#include +#include + +/*symbol file symbols*/ +#define IDENT_SYM 1 +#define BOOLEAN_SYM 2 +#define CHAR_SYM 3 +#define INTEGER_SYM 4 +#define REAL_SYM 5 +#define STRING_SYM 6 +#define SET_SYM 7 +#define BOOLEAN_TYPE_SYM 8 +#define CHAR_TYPE_SYM 9 +#define INTEGER_TYPE_SYM 10 +#define REAL_TYPE_SYM 11 +#define BYTE_TYPE_SYM 12 +#define SET_TYPE_SYM 13 +#define ARRAY_SYM 14 +#define RECORD_SYM 15 +#define POINTER_SYM 16 +#define PROCEDURE_SYM 17 + +/*symbol file identifier kinds*/ +#define CONST_KIND 1 +#define TYPE_KIND 2 +#define VAR_KIND 3 +#define PROCEDURE_KIND 4 +#define FIELD_KIND 5 +#define VALUE_PARAM_KIND 6 +#define VAR_PARAM_KIND 7 + +typedef struct ScopeDesc *Scope; +struct ScopeDesc { + Maps_Map symbols; + Scope parent; +}; + +static int initialized = 0; + +static const char *predeclaredNames[24]; +static Trees_Node predeclaredNodes[LEN(predeclaredNames)]; + +static Scope globalScope, currentScope; +static const char *importFilename, *exportFilename; +static FILE *importFile, *exportFile; +static Maps_Map writtenSymbols; + +void Table_Init(void) +{ + static const struct { const char *name; int kind, type; } predecIdents[] = { + {"ABS", TREES_PROCEDURE_KIND, TREES_ABS_PROC}, + {"ASR", TREES_PROCEDURE_KIND, TREES_ASR_PROC}, + {"ASSERT", TREES_PROCEDURE_KIND, TREES_ASSERT_PROC}, + {"BOOLEAN", TREES_TYPE_KIND, TREES_BOOLEAN_TYPE}, + {"BYTE", TREES_TYPE_KIND, TREES_BYTE_TYPE}, + {"CHAR", TREES_TYPE_KIND, TREES_CHAR_TYPE}, + {"CHR", TREES_PROCEDURE_KIND, TREES_CHR_PROC}, + {"DEC", TREES_PROCEDURE_KIND, TREES_DEC_PROC}, + {"EXCL", TREES_PROCEDURE_KIND, TREES_EXCL_PROC}, + {"FLOOR", TREES_PROCEDURE_KIND, TREES_FLOOR_PROC}, + {"FLT", TREES_PROCEDURE_KIND, TREES_FLT_PROC}, + {"INC", TREES_PROCEDURE_KIND, TREES_INC_PROC}, + {"INCL", TREES_PROCEDURE_KIND, TREES_INCL_PROC}, + {"INTEGER", TREES_TYPE_KIND, TREES_INTEGER_TYPE}, + {"LEN", TREES_PROCEDURE_KIND, TREES_LEN_PROC}, + {"LSL", TREES_PROCEDURE_KIND, TREES_LSL_PROC}, + {"NEW", TREES_PROCEDURE_KIND, TREES_NEW_PROC}, + {"ODD", TREES_PROCEDURE_KIND, TREES_ODD_PROC}, + {"ORD", TREES_PROCEDURE_KIND, TREES_ORD_PROC}, + {"PACK", TREES_PROCEDURE_KIND, TREES_PACK_PROC}, + {"REAL", TREES_TYPE_KIND, TREES_REAL_TYPE}, + {"ROR", TREES_PROCEDURE_KIND, TREES_ROR_PROC}, + {"SET", TREES_TYPE_KIND, TREES_SET_TYPE}, + {"UNPK", TREES_PROCEDURE_KIND, TREES_UNPK_PROC}}; + + int i; + Trees_Node node; + + if (! initialized) { + initialized = 1; + + assert(LEN(predecIdents) == LEN(predeclaredNames)); + assert(LEN(predeclaredNodes) == LEN(predeclaredNames)); + + Files_Init(); + Maps_Init(); + Trees_Init(); + Util_Init(); + + for (i = 0; i < LEN(predeclaredNodes); i++) { + predeclaredNames[i] = predecIdents[i].name; + + node = Trees_NewIdent(predecIdents[i].name); + Trees_SetKind(predecIdents[i].kind, node); + Trees_SetType(Trees_NewLeaf(predecIdents[i].type), node); + predeclaredNodes[i] = node; + } + + NEW(globalScope); + globalScope->symbols = Maps_New(); + globalScope->parent = NULL; + currentScope = globalScope; + + } +} + + +int Table_LocallyDeclared(const char name[]) +{ + assert(initialized); + return Maps_HasKey(name, currentScope->symbols); +} + + +void Table_Put(Trees_Node identNode) +{ + const char *name; + + assert(initialized); + assert(identNode != NULL); + assert(Trees_Symbol(identNode) == IDENT); + assert((Trees_Local(identNode) && Table_ScopeLocal()) + || (! Trees_Local(identNode) && ! Table_ScopeLocal())); + name = Trees_Name(identNode); + assert(! Table_LocallyDeclared(name)); + + Maps_Put(name, identNode, &(currentScope->symbols)); +} + + +static char *Qualifier(const char name[]) +{ + const char *p; + char *result; + + p = strchr(name, '.'); + if (p != NULL) { + NEW_ARRAY(result, p - name + 1); + memcpy(result, name, p - name); + result[p - name] = '\0'; + } else { + result = NULL; + } + return result; +} + + +static Trees_Node ImportedIdent(const char qualifiedName[], Trees_Node qualifier) +{ + Trees_Node result, impIdents; + + impIdents = Trees_Left(qualifier); + while ((impIdents != NULL) + && (strcmp(Trees_Name(Trees_Left(impIdents)), qualifiedName) != 0)) { + impIdents = Trees_Right(impIdents); + } + if (impIdents != NULL) { + result = Trees_Left(impIdents); + } else { + result = NULL; + } + return result; +} + + +static int Cmp(const void *name, const void *namePtr) +{ + return strcmp((char *) name, * (char **) namePtr); +} + + +static Trees_Node PredeclaredIdent(const char name[]) +{ + const char **namePtr; + ptrdiff_t pos; + Trees_Node result; + + namePtr = bsearch(name, predeclaredNames, LEN(predeclaredNames), sizeof predeclaredNames[0], Cmp); + if (namePtr != NULL) { + pos = namePtr - predeclaredNames; + assert(pos >= 0); + assert(pos < LEN(predeclaredNodes)); + result = predeclaredNodes[pos]; + } else { + result = NULL; + } + return result; +} + + +Trees_Node Table_At(const char name[]) +{ + void *result, *qualifier; + const char *qualifierName; + + assert(initialized); + assert(name != NULL); + + result = NULL; + qualifierName = Qualifier(name); + if (qualifierName != NULL) { + qualifier = Maps_At(qualifierName, globalScope->symbols); + if (qualifier != NULL) { + Trees_SetUsed(qualifier); + result = ImportedIdent(name, qualifier); + } + } else { + result = Maps_At(name, currentScope->symbols); + if ((result == NULL) && (currentScope != globalScope)) { + result = Maps_At(name, globalScope->symbols); + } + if ((result != NULL) && (Trees_Kind(result) != TREES_QUALIFIER_KIND)) { + Trees_SetUsed(result); + } + if (result == NULL) { + result = PredeclaredIdent(name); + } + } + + assert((result == NULL) || Trees_Symbol(result) == IDENT); + + return result; +} + + +void Table_OpenScope(void) +{ + Scope newScope; + + assert(initialized); + + NEW(newScope); + newScope->symbols = Maps_New(); + newScope->parent = currentScope; + currentScope = newScope; + + assert(currentScope != globalScope); +} + + +void Table_CloseScope(void) +{ + assert(initialized); + assert(currentScope != globalScope); + + currentScope = currentScope->parent; +} + + +int Table_ScopeLocal(void) +{ + assert(initialized); + return currentScope != globalScope; +} + + +static void AddUnusedIdent(const char identName[], void *identNode, void *unusedIdentsNodePtr) +{ + Trees_Node ident; + Trees_Node *unusedIdentsPtr; + + (void) identName; /*prevent "unused" warning*/ + ident = identNode; + unusedIdentsPtr = (Trees_Node *) unusedIdentsNodePtr; + if (! Trees_Used(ident)) { + *unusedIdentsPtr = Trees_NewNode(TREES_NOSYM, ident, *unusedIdentsPtr); + } +} + + +Trees_Node Table_UnusedIdentifiers(void) +{ + Trees_Node result; + + assert(initialized); + result = NULL; + Maps_Apply(AddUnusedIdent, currentScope->symbols, &result); + Trees_ReverseList(&result); + return result; +} + + +static void GetFilePosition(FILE *file, long int *line, long int *col) +{ + long int savedPos, pos; + int ch; + + *line = 1; + *col = 0; + savedPos = ftell(file); + if (savedPos >= 0) { + rewind(file); + pos = savedPos; + ch = fgetc(file); + while ((pos > 0) && (ch != EOF)) { + if (ch == '\n') { + ++*line; + *col = 0; + } else { + ++*col; + } + pos--; + ch = fgetc(file); + } + fseek(file, savedPos, SEEK_SET); + } + if (ferror(file)) { + fprintf(stderr, "failed getting file position from %s: %s", importFilename, strerror(errno)); + exit(EXIT_FAILURE); + } +} + + +static void PrintImportErrorPrefix(void) +{ + long int line, col; + + assert(importFile != NULL); + GetFilePosition(importFile, &line, &col); + fprintf(stderr, "%s:%ld:%ld: ", importFilename, line, col); +} + + +static int StringLength(FILE *file) +{ + long int savedPos; + int ch, n; + + savedPos = ftell(file); + fscanf(file, " "); + n = -1; + ch = fgetc(file); + if (ch == '"') { + do { + ch = fgetc(file); + n++; + } while ((ch != EOF) && (ch != '\n') && (ch != '"')); + if (ch != '"') { + n = -1; + } + } + fseek(file, savedPos, SEEK_SET); + return n; +} + + +static int IsLeadingIdentChar(int ch) +{ + return ((ch >= 'A') && (ch <= 'Z')) || ((ch >= 'a') && (ch <= 'z')); +} + + +static int IsIdentChar(int ch) +{ + return IsLeadingIdentChar(ch) || ((ch >= '0') && (ch <= '9')) || (ch == '_'); +} + + +static int IdentLength(FILE *file) +{ + long int savedPos; + int ch, n; + + savedPos = ftell(file); + fscanf(file, " "); + n = 0; + ch = fgetc(file); + if (IsLeadingIdentChar(ch)) { + do { + n++; + ch = fgetc(file); + } while (IsIdentChar(ch)); + if (ch == '.') { + n++; + ch = fgetc(file); + if (IsLeadingIdentChar(ch)) { + do { + n++; + ch = fgetc(file); + } while (IsIdentChar(ch)); + } + } + } + fseek(file, savedPos, SEEK_SET); + return n; +} + + +static void ReadSExp(int isRoot, FILE *file, Trees_Node *resultPtr); + +static void ReadIdent(int isRoot, FILE *file, Trees_Node *resultPtr) +{ + char *name; + int len, sfKind, kind, n, exported; + + fscanf(file, " "); + len = IdentLength(file); + NEW_ARRAY(name, len + 1); + fgets(name, len + 1, file); + + *resultPtr = Trees_NewIdent(name); + + /*kind*/ + n = fscanf(file, "%d", &sfKind); + if (n == 1) { + switch (sfKind) { + case CONST_KIND: + kind = TREES_CONSTANT_KIND; + break; + case TYPE_KIND: + kind = TREES_TYPE_KIND; + break; + case VAR_KIND: + kind = TREES_VARIABLE_KIND; + break; + case PROCEDURE_KIND: + kind = TREES_PROCEDURE_KIND; + break; + case FIELD_KIND: + kind = TREES_FIELD_KIND; + break; + case VALUE_PARAM_KIND: + kind = TREES_VALUE_PARAM_KIND; + break; + case VAR_PARAM_KIND: + kind = TREES_VAR_PARAM_KIND; + break; + default: + PrintImportErrorPrefix(); + fprintf(stderr, "error: invalid identifier kind: %d\n", sfKind); + exit(EXIT_FAILURE); + } + Trees_SetKind(kind, *resultPtr); + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading identifier kind failed\n"); + exit(EXIT_FAILURE); + } + + /*exported flag*/ + if ((sfKind == TYPE_KIND) && isRoot) { + n = fscanf(file, "%d", &exported); + if (n == 1) { + if (exported) { + Trees_SetImported(*resultPtr); + } + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading export status failed\n"); + exit(EXIT_FAILURE); + } + } else if (sfKind == FIELD_KIND) { + Trees_SetExported(*resultPtr); + } else if ((sfKind != VALUE_PARAM_KIND) && (sfKind != VAR_PARAM_KIND)) { + Trees_SetImported(*resultPtr); + } + + /*value or type*/ + switch (sfKind) { + case CONST_KIND: + { + Trees_Node constValue; + + ReadSExp(0, file, &constValue); + Trees_SetValue(constValue, *resultPtr); + } + break; + case TYPE_KIND: + { + Trees_Node type; + + if (isRoot) { + ReadSExp(0, file, &type); + Trees_SetType(type, *resultPtr); + } + } + break; + case VAR_KIND: + case PROCEDURE_KIND: + case FIELD_KIND: + case VALUE_PARAM_KIND: + case VAR_PARAM_KIND: + { + Trees_Node type; + + ReadSExp(0, file, &type); + Trees_SetType(type, *resultPtr); + } + break; + default: + assert(0); + } +} + + +static int AtEndOfList(FILE *file) +{ + int ch, result; + + ch = getc(file); + result = ch == ')'; + ungetc(ch, file); + return result; +} + + +static void ReadFieldList(FILE *file, Trees_Node *resultPtr) +{ + Trees_Node field; + int ch; + + assert(resultPtr != NULL); + + *resultPtr = NULL; + fscanf(file, " "); + ch = fgetc(file); + if (ch == '(') { + while (! AtEndOfList(file)) { + ReadSExp(0, file, &field); + *resultPtr = Trees_NewNode(TREES_IDENT_LIST, field, *resultPtr); + fscanf(file, " "); + } + Trees_ReverseList(resultPtr); /*correct order*/ + fscanf(file, " "); + ch = fgetc(file); + if (ch != ')') { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected end of field list s-expression\n"); + exit(EXIT_FAILURE); + } + fscanf(file, " "); + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected start of field list s-expression\n"); + exit(EXIT_FAILURE); + } +} + + +static void ReadRecord(FILE *file, Trees_Node *resultPtr) +{ + Trees_Node baseType, fieldListSeq, fieldList; + int ch; + + ReadSExp(0, file, &baseType); + + fieldListSeq = NULL; + fscanf(file, " "); + ch = fgetc(file); + if (ch == '(') { + while (! AtEndOfList(file)) { + ReadFieldList(file, &fieldList); + fieldListSeq = Trees_NewNode(TREES_FIELD_LIST_SEQUENCE, fieldList, fieldListSeq); + } + Trees_ReverseList(&fieldListSeq); /*correct order*/ + fscanf(file, " "); + ch = fgetc(file); + if (ch != ')') { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected end of field list sequence s-expression\n"); + exit(EXIT_FAILURE); + } + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected start of field list sequence s-expression\n"); + exit(EXIT_FAILURE); + } + + *resultPtr = Types_NewRecord(baseType, fieldListSeq); +} + + +static int LookingAt(char ch, FILE *f) +{ + int ch1; + + ch1 = fgetc(f); + ungetc(ch1, f); + + return ch == ch1; +} + + +static void ReadSymbol(int symbol, int isRoot, FILE *file, Trees_Node *resultPtr) +{ + assert(resultPtr != NULL); + + *resultPtr = NULL; + switch (symbol) { + case IDENT_SYM: + ReadIdent(isRoot, file, resultPtr); + break; + case BOOLEAN_SYM: + { + int b, n; + + n = fscanf(file, "%d", &b); + if (n == 1) { + *resultPtr = Trees_NewBoolean(b); + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading boolean value failed\n"); + exit(EXIT_FAILURE); + } + } + break; + case CHAR_SYM: + { + int i, n; + + n = fscanf(file, "%d", &i); + if (n == 1) { + if (i < CHAR_MIN) { + PrintImportErrorPrefix(); + fprintf(stderr, "warning: character constant out of range: %d < %d", i, CHAR_MIN); + } else if (i > CHAR_MAX) { + PrintImportErrorPrefix(); + fprintf(stderr, "warning: character constant out of range: %d > %d", i, CHAR_MAX); + } + *resultPtr = Trees_NewChar((char) i); + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading character constant failed\n"); + exit(EXIT_FAILURE); + } + } + break; + case INTEGER_SYM: + { + OBNC_INTEGER i, n; + + n = fscanf(file, "%" OBNC_INT_MOD "d", &i); + if (n == 1) { + *resultPtr = Trees_NewInteger(i); + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading integer failed\n"); + exit(EXIT_FAILURE); + } + } + break; + case REAL_SYM: + { + OBNC_REAL x; + int n; + + n = fscanf(file, "%" OBNC_REAL_MOD_R "f", &x); + if (n == 1) { + *resultPtr = Trees_NewReal(x); + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading real number failed\n"); + exit(EXIT_FAILURE); + } + } + break; + case STRING_SYM: + { + int done, len, ch, n; + char *s; + unsigned int x; + char ord[2]; + + done = 0; + fscanf(file, " "); + if (LookingAt('"', file)) { + len = StringLength(file); + NEW_ARRAY(s, len + 1); + ch = fgetc(file); + fgets(s, len + 1, file); + ch = fgetc(file); + if (ch == '"') { + *resultPtr = Trees_NewString(s); + done = 1; + } + } else { + n = fscanf(file, "%xX", &x); + if ((n == 1) && (x <= UCHAR_MAX)) { + ord[0] = (unsigned char) x; + ord[1] = '\0'; + *resultPtr = Trees_NewString(ord); + done = 1; + } + } + if (! done) { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading string failed\n"); + exit(EXIT_FAILURE); + } + } + break; + case SET_SYM: + { + unsigned OBNC_INTEGER u; + int n; + + n = fscanf(file, "%" OBNC_INT_MOD "u", &u); + if (n == 1) { + *resultPtr = Trees_NewSet(u); + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: reading set constant failed\n"); + exit(EXIT_FAILURE); + } + } + break; + case BOOLEAN_TYPE_SYM: + *resultPtr = Trees_NewNode(TREES_BOOLEAN_TYPE, NULL, NULL); + break; + case CHAR_TYPE_SYM: + *resultPtr = Trees_NewNode(TREES_CHAR_TYPE, NULL, NULL); + break; + case INTEGER_TYPE_SYM: + *resultPtr = Trees_NewNode(TREES_INTEGER_TYPE, NULL, NULL); + break; + case REAL_TYPE_SYM: + *resultPtr = Trees_NewNode(TREES_REAL_TYPE, NULL, NULL); + break; + case BYTE_TYPE_SYM: + *resultPtr = Trees_NewNode(TREES_BYTE_TYPE, NULL, NULL); + break; + case SET_TYPE_SYM: + *resultPtr = Trees_NewNode(TREES_SET_TYPE, NULL, NULL); + break; + case ARRAY_SYM: + { + Trees_Node length, elemType; + + ReadSExp(0, file, &length); + if (length != NULL) { + if (Trees_Symbol(length) == INTEGER) { + if (Trees_Integer(length) < 0) { + PrintImportErrorPrefix(); + fprintf(stderr, "error: negative array length: %" OBNC_INT_MOD "d\n", Trees_Integer(length)); + exit(EXIT_FAILURE); + } + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: non-integer array length read\n"); + exit(EXIT_FAILURE); + } + } + ReadSExp(0, file, &elemType); + *resultPtr = Types_NewArray(length, elemType); + } + break; + case RECORD_SYM: + ReadRecord(file, resultPtr); + break; + case POINTER_SYM: + { + Trees_Node ptrBaseType; + + ReadSExp(0, file, &ptrBaseType); + *resultPtr = Types_NewPointer(ptrBaseType); + } + break; + case PROCEDURE_SYM: + { + Trees_Node resultType, par, params; + int ch; + + ReadSExp(0, file, &resultType); + + params = NULL; + fscanf(file, " "); + ch = fgetc(file); + if (ch == '(') { + while (! AtEndOfList(file)) { + ReadSExp(0, file, &par); + params = Trees_NewNode(TREES_IDENT_LIST, par, params); + } + Trees_ReverseList(¶ms); /*correct order*/ + fscanf(file, " "); + ch = fgetc(file); + if (ch != ')') { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected end of parameter list s-expression\n"); + exit(EXIT_FAILURE); + } + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected start of parameter list s-expression\n"); + exit(EXIT_FAILURE); + } + *resultPtr = Types_NewProcedure(params, resultType); + } + break; + default: + assert(0); + } + + assert(*resultPtr != NULL); +} + + +static void ReadSExp(int isRoot, FILE *file, Trees_Node *resultPtr) +{ + int symbol, n, ch; + + assert(resultPtr != NULL); + + *resultPtr = NULL; + n = fscanf(file, " "); + if ((n != EOF) && ! feof(file)) { + ch = fgetc(file); + if (ch == '(') { + ch = fgetc(file); + if (ch != ')') { + ungetc(ch, file); + n = fscanf(file, "%d", &symbol); + if (n == 1) { + ReadSymbol(symbol, isRoot, file, resultPtr); + ch = fgetc(file); + if (ch != ')') { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected end of s-expression, read '%c'\n", ch); + exit(EXIT_FAILURE); + } + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: failed reading symbol\n"); + exit(EXIT_FAILURE); + } + } + } else { + PrintImportErrorPrefix(); + fprintf(stderr, "error: expected start of s-expression, read '%c'\n", ch); + exit(EXIT_FAILURE); + } + } else if (feof(file)) { + PrintImportErrorPrefix(); + fprintf(stderr, "error: unexpected end of file\n"); + exit(EXIT_FAILURE); + } else if (ferror(file)) { + PrintImportErrorPrefix(); + fprintf(stderr, "error: failed reading expression: %s\n", strerror(errno)); + exit(EXIT_FAILURE); + } +} + + +static void ResolveTypesRec(Trees_Node node, Maps_Map symfileEntries) +{ + Trees_Node type, typeDef; + + if (node != NULL) { + type = NULL; + switch (Trees_Symbol(node)) { + case IDENT: + switch (Trees_Kind(node)) { + case TREES_TYPE_KIND: + case TREES_VARIABLE_KIND: + case TREES_FIELD_KIND: + case TREES_VALUE_PARAM_KIND: + case TREES_VAR_PARAM_KIND: + type = Trees_Type(node); + break; + } + break; + case ARRAY: + type = Types_ElementType(node); + break; + case RECORD: + type = Types_RecordBaseType(node); + break; + case POINTER: + type = Types_PointerBaseType(node); + break; + case PROCEDURE: + type = Types_ResultType(node); + break; + } + + if ((type != NULL) && (Trees_Symbol(type) == IDENT)) { + typeDef = Maps_At(Trees_Name(type), symfileEntries); + if (typeDef != NULL) { + switch (Trees_Symbol(node)) { + case IDENT: + Trees_SetType(typeDef, node); + break; + case ARRAY: + Types_SetElementType(typeDef, node); + break; + case RECORD: + Types_SetRecordBaseType(typeDef, node); + ResolveTypesRec(Types_Fields(node), symfileEntries); + break; + case POINTER: + Types_SetPointerBaseType(typeDef, node); + break; + case PROCEDURE: + Types_SetResultType(typeDef, node); + ResolveTypesRec(Types_Parameters(node), symfileEntries); + break; + default: + assert(0); + } + } else { + fprintf(stderr, "missing type name in symbol file: %s\n", Trees_Name(type)); + exit(EXIT_FAILURE); + } + } else if (Trees_Symbol(node) == IDENT) { + ResolveTypesRec(Trees_Type(node), symfileEntries); + } else { + ResolveTypesRec(Trees_Left(node), symfileEntries); + ResolveTypesRec(Trees_Right(node), symfileEntries); + } + } +} + + +static void ResolveTypes(const char identName[], void *identNode, void *symbolFileEntriesMap) +{ + Trees_Node ident; + Maps_Map symbolFileEntries; + + (void) identName; /*prevent "unused" warning*/ + ident = identNode; + symbolFileEntries = symbolFileEntriesMap; + ResolveTypesRec(ident, symbolFileEntries); +} + + +static char *QualifiedName(const char qualifier[], const char name[]) +{ + size_t resultLen; + char *result; + + resultLen = strlen(qualifier) + strlen(".") + strlen(name) + strlen("\0"); + NEW_ARRAY(result, resultLen); + strcpy(result, qualifier); + strcat(result, "."); + strcat(result, name); + return result; +} + + +static const char *importModule, *importQualifier; + +static void SetQualifiers(const char identName[], void *identNode, void *data) +{ + const char *name; + int isReExportedType; + + (void) identName; /*prevent "unused" warning*/ + (void) data; /*prevent "unused" warning*/ + name = Trees_Name(identNode); + isReExportedType = strchr(name, '.') != NULL; + if (! isReExportedType) { + Trees_SetName(QualifiedName(importQualifier, name), identNode); + Trees_SetUnaliasedName(QualifiedName(importModule, name), identNode); + } +} + + +void Table_Import(const char filename[], const char module[], const char qualifier[]) +{ + int ch, n; + Maps_Map symbolFileEntries; + Trees_Node ident, importEntries, qualifierIdent; + + assert(initialized); + importFilename = filename; + importFile = Files_Old(filename, FILES_READ); + + /*skip version line*/ + do { + ch = fgetc(importFile); + } while ((ch != EOF) && (ch != '\n')); + + /*read entries*/ + symbolFileEntries = Maps_New(); + importEntries = NULL; + n = fscanf(importFile, " "); + while ((n != EOF) && ! feof(importFile)) { + ReadSExp(1, importFile, &ident); + if (ident != NULL) { + Maps_Put(Trees_Name(ident), ident, &symbolFileEntries); + if (Trees_Imported(ident)) { + importEntries = Trees_NewNode(TREES_NOSYM, ident, importEntries); + } + } else { + fprintf(stderr, "unexpected null entry in symbol file\n"); + exit(EXIT_FAILURE); + } + n = fscanf(importFile, " "); + } + + /*resolve types*/ + Maps_Apply(ResolveTypes, symbolFileEntries, symbolFileEntries); + + /*qualify identifiers*/ + importModule = module; + importQualifier = qualifier; + Maps_Apply(SetQualifiers, symbolFileEntries, NULL); + + /*import*/ + qualifierIdent = Table_At(qualifier); + assert(qualifierIdent != NULL); + Trees_SetLeft(importEntries, qualifierIdent); + + Files_Close(&importFile); + importFile = NULL; + importFilename = NULL; +} + + +void Table_ImportSystem(const char qualifier[]) +{ + static const struct { const char *name; int type; } procs[] = { + {"ADR", TREES_ADR_PROC}, + {"SIZE", TREES_SIZE_PROC}, + {"BIT", TREES_BIT_PROC}, + {"GET", TREES_GET_PROC}, + {"PUT", TREES_PUT_PROC}, + {"COPY", TREES_COPY_PROC}, + {"VAL", TREES_VAL_PROC}}; + const char *name; + int i; + Trees_Node importEntries, ident, qualifierIdent; + + assert(initialized); + importEntries = NULL; + for (i = 0; i < LEN(procs); i++) { + name = Util_String("%s.%s", qualifier, procs[i].name); + ident = Trees_NewIdent(name); + Trees_SetKind(TREES_PROCEDURE_KIND, ident); + Trees_SetType(Trees_NewLeaf(procs[i].type), ident); + importEntries = Trees_NewNode(TREES_NOSYM, ident, importEntries); + } + + qualifierIdent = Table_At(qualifier); + assert(qualifierIdent != NULL); + Trees_SetLeft(importEntries, qualifierIdent); +} + + +static int SFKind(Trees_Node ident) +{ + int result = -1; + + switch (Trees_Kind(ident)) { + case TREES_CONSTANT_KIND: + result = CONST_KIND; + break; + case TREES_TYPE_KIND: + result = TYPE_KIND; + break; + case TREES_VARIABLE_KIND: + result = VAR_KIND; + break; + case TREES_PROCEDURE_KIND: + result = PROCEDURE_KIND; + break; + case TREES_FIELD_KIND: + result = FIELD_KIND; + break; + case TREES_VALUE_PARAM_KIND: + result = VALUE_PARAM_KIND; + break; + case TREES_VAR_PARAM_KIND: + result = VAR_PARAM_KIND; + break; + default: + assert(0); + break; + } + return result; +} + + +static void Write(Trees_Node node, int isRoot, FILE *file, Maps_Map *indirectlyExportedTypes) +{ + if (node == NULL) { + fprintf(file, "()"); + } else { + switch (Trees_Symbol(node)) { + case IDENT: + fprintf(file, "(%d %s %d", IDENT_SYM, Trees_UnaliasedName(node), SFKind(node)); + if ((SFKind(node) == TYPE_KIND) && isRoot) { + fprintf(file, " %d", Trees_Exported(node)); + } + switch (SFKind(node)) { + case CONST_KIND: + fprintf(file, " "); + Write(Trees_Value(node), 0, file, indirectlyExportedTypes); + break; + case TYPE_KIND: + if (isRoot) { + fprintf(file, " "); + Write(Trees_Type(node), 0, file, indirectlyExportedTypes); + } else if (! Trees_Exported(node)) { + Maps_Put(Trees_Name(node), node, indirectlyExportedTypes); + } + break; + case VAR_KIND: + case PROCEDURE_KIND: + case FIELD_KIND: + case VALUE_PARAM_KIND: + case VAR_PARAM_KIND: + fprintf(file, " "); + Write(Trees_Type(node), 0, file, indirectlyExportedTypes); + break; + default: + assert(0); + } + fprintf(file, ")"); + break; + case FALSE: + fprintf(file, "(%d 0)", BOOLEAN_SYM); + break; + case TRUE: + fprintf(file, "(%d 1)", BOOLEAN_SYM); + break; + case TREES_CHAR_CONSTANT: + fprintf(file, "(%d %d)", CHAR_SYM, Trees_Char(node)); + break; + case INTEGER: + fprintf(file, "(%d %" OBNC_INT_MOD "d)", INTEGER_SYM, Trees_Integer(node)); + break; + case REAL: + fprintf(file, "(%d %.*" OBNC_REAL_MOD_W "G)", REAL_SYM, DBL_DIG, Trees_Real(node)); + break; + case STRING: + if (strlen(Trees_String(node)) <= 1) { + fprintf(file, "(%d 0%XX)", STRING_SYM, (unsigned char) Trees_String(node)[0]); + } else { + fprintf(file, "(%d \"%s\")", STRING_SYM, Trees_String(node)); + } + break; + case TREES_SET_CONSTANT: + fprintf(file, "(%d %" OBNC_INT_MOD "u)", SET_SYM, Trees_Set(node)); + break; + case TREES_BOOLEAN_TYPE: + fprintf(file, "(%d)", BOOLEAN_TYPE_SYM); + break; + case TREES_CHAR_TYPE: + fprintf(file, "(%d)", CHAR_TYPE_SYM); + break; + case TREES_INTEGER_TYPE: + fprintf(file, "(%d)", INTEGER_TYPE_SYM); + break; + case TREES_REAL_TYPE: + fprintf(file, "(%d)", REAL_TYPE_SYM); + break; + case TREES_BYTE_TYPE: + fprintf(file, "(%d)", BYTE_TYPE_SYM); + break; + case TREES_SET_TYPE: + fprintf(file, "(%d)", SET_TYPE_SYM); + break; + case ARRAY: + fprintf(file, "(%d ", ARRAY_SYM); + Write(Types_ArrayLength(node), 0, file, indirectlyExportedTypes); + fprintf(file, " "); + Write(Types_ElementType(node), 0, file, indirectlyExportedTypes); + fprintf(file, ")"); + break; + case RECORD: + { + Trees_Node fieldListSeq, fieldList, field; + int fieldListSeqEmpty, fieldListEmpty; + + fprintf(file, "(%d ", RECORD_SYM); + Write(Types_RecordBaseType(node), 0, file, indirectlyExportedTypes); + fieldListSeq = Types_Fields(node); + fprintf(file, " ("); + fieldListSeqEmpty = 1; + while (fieldListSeq != NULL) { + assert(Trees_Symbol(fieldListSeq) == TREES_FIELD_LIST_SEQUENCE); + fieldList = Trees_Left(fieldListSeq); + fieldListEmpty = 1; + while (fieldList != NULL) { + assert(Trees_Symbol(fieldList) == TREES_IDENT_LIST); + field = Trees_Left(fieldList); + if (Trees_Exported(field)) { + if (fieldListEmpty) { + if (! fieldListSeqEmpty) { + fprintf(file, " "); + } + fprintf(file, "("); + } else { + fprintf(file, " "); + } + Write(field, 0, file, indirectlyExportedTypes); + fieldListSeqEmpty = 0; + fieldListEmpty = 0; + } + fieldList = Trees_Right(fieldList); + } + if (! fieldListEmpty) { + fprintf(file, ")"); + } + fieldListSeq = Trees_Right(fieldListSeq); + } + fprintf(file, "))"); + } + break; + case POINTER: + fprintf(file, "(%d ", POINTER_SYM); + Write(Types_PointerBaseType(node), 0, file, indirectlyExportedTypes); + fprintf(file, ")"); + break; + case PROCEDURE: + { + Trees_Node params = Types_Parameters(node); + + fprintf(file, "(%d ", PROCEDURE_SYM); + Write(Types_ResultType(node), 0, file, indirectlyExportedTypes); + fprintf(file, " ("); + while (params != NULL) { + Write(Trees_Left(params), 0, file, indirectlyExportedTypes); + if (Trees_Right(params) != NULL) { + fprintf(file, " "); + } + params = Trees_Right(params); + } + fprintf(file, "))"); + } + break; + default: + assert(0); + } + } +} + + +static void WriteExportedSymbol(const char identName[], void *identNode, void *indirectlyExportedTypesMapPtr) +{ + Trees_Node ident = identNode; + Maps_Map *indirectlyExportedTypes = indirectlyExportedTypesMapPtr; + + (void) identName; /*prevent "unused" warning*/ + assert(Trees_Symbol(ident) == IDENT); + if (Trees_Exported(ident)) { + assert(indirectlyExportedTypesMapPtr != NULL); + Write(ident, 1, exportFile, indirectlyExportedTypes); + Maps_Put(Trees_Name(ident), NULL, &writtenSymbols); + fputc('\n', exportFile); + } +} + + +static void WriteSymbol(const char identName[], void *identNode, void *indirectlyExportedTypesMapPtr) +{ + Trees_Node ident = identNode; + Maps_Map *indirectlyExportedTypes = indirectlyExportedTypesMapPtr; + + (void) identName; /*prevent "unused" warning*/ + assert(Trees_Symbol(ident) == IDENT); + if (! Maps_HasKey(Trees_Name(ident), writtenSymbols)) { + Write(ident, 1, exportFile, indirectlyExportedTypes); + Maps_Put(Trees_Name(ident), NULL, &writtenSymbols); + fputc('\n', exportFile); + } +} + + +void Table_Export(const char filename[]) +{ + Maps_Map indirectlyExportedTypes, nextIndirectlyExportedTypes; + int i; + + assert(initialized); + assert(filename != NULL); + + exportFilename = filename; + exportFile = Files_New(filename); + if (strcmp(CONFIG_VERSION, "") != 0) { + fprintf(exportFile, "%s", CONFIG_VERSION); + } + fputc('\n', exportFile); + + writtenSymbols = Maps_New(); + + indirectlyExportedTypes = Maps_New(); + Maps_Apply(WriteExportedSymbol, globalScope->symbols, &indirectlyExportedTypes); + i = 0; + while (! Maps_IsEmpty(indirectlyExportedTypes) && (i < 10)) { + nextIndirectlyExportedTypes = Maps_New(); + Maps_Apply(WriteSymbol, indirectlyExportedTypes, &nextIndirectlyExportedTypes); + indirectlyExportedTypes = nextIndirectlyExportedTypes; + i++; + } + if (i < 10) { + Files_Close(&exportFile); + exportFile = NULL; + exportFilename = NULL; + } else { + fprintf(stderr, "too many levels of indirectly exported types when exporting symbols to %s\n", exportFilename); + exit(EXIT_FAILURE); + } +} diff --git a/src/Table.h b/src/Table.h new file mode 100644 index 0000000..3cc0c14 --- /dev/null +++ b/src/Table.h @@ -0,0 +1,46 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef TABLE_H +#define TABLE_H + +#include "Trees.h" +#include + +void Table_Init(void); + +void Table_Put(Trees_Node identNode); + +Trees_Node Table_At(const char name[]); + +int Table_LocallyDeclared(const char name[]); + +void Table_OpenScope(void); + +void Table_CloseScope(void); + +int Table_ScopeLocal(void); + +Trees_Node Table_UnusedIdentifiers(void); + +void Table_Import(const char filename[], const char module[], const char qualifier[]); + +void Table_ImportSystem(const char qualifier[]); + +void Table_Export(const char filename[]); + +#endif diff --git a/src/TableTest.c b/src/TableTest.c new file mode 100644 index 0000000..9bf4c88 --- /dev/null +++ b/src/TableTest.c @@ -0,0 +1,151 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Files.h" +#include "StackTrace.h" +#include "Table.h" +#include "Trees.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" /*needed by YYSTYPE in y.tab.h*/ +#include "y.tab.h" +#include /*POSIX*/ +#include +#include +#include +#include + +static const char *symfilename; + +static void DeleteSymbolFile(void) +{ + int error; + + if (strcmp(symfilename, "") != 0) { + error = remove(symfilename); + if (error) { + perror("error: remove failed: "); + exit(EXIT_FAILURE); + } + } +} + + +static void Test(void) +{ + Trees_Node symbol, value, result; + + Table_Init(); + assert(! Table_ScopeLocal()); + + symbol = Trees_NewIdent("a"); + Trees_SetKind(TREES_CONSTANT_KIND, symbol); + Trees_SetValue(Trees_NewInteger(37), symbol); + Trees_SetExported(symbol); + Table_Put(symbol); + + symbol = Trees_NewIdent("X"); + Trees_SetKind(TREES_PROCEDURE_KIND, symbol); + Trees_SetExported(symbol); + Table_Put(symbol); + + Table_OpenScope(); + assert(Table_ScopeLocal()); + Table_CloseScope(); + + symbol = Trees_NewIdent("Y"); + Trees_SetKind(TREES_PROCEDURE_KIND, symbol); + Table_Put(symbol); + assert(Table_LocallyDeclared("Y")); + + Table_OpenScope(); + assert(! Table_LocallyDeclared("Y")); + + symbol = Trees_NewIdent("X"); + Trees_SetKind(TREES_VARIABLE_KIND, symbol); + Trees_SetLocal(symbol); + Table_Put(symbol); + + result = Table_At("X"); + assert(result != NULL); + assert(Trees_Kind(result) == TREES_VARIABLE_KIND); + assert(! Trees_Exported(result)); + + Table_OpenScope(); + result = Table_At("X"); /*shall return global object*/ + assert(result != NULL); + assert(Trees_Kind(result) == TREES_PROCEDURE_KIND); + assert(Trees_Exported(result)); + Table_CloseScope(); + Table_CloseScope(); + + result = Table_At("X"); + assert(result != NULL); + assert(Trees_Kind(result) == TREES_PROCEDURE_KIND); + assert(Trees_Exported(result)); + + result = Table_At("foo"); + assert(result == NULL); + + /*export symbols*/ + Table_Export(symfilename); + + /*clear table*/ + Table_Init(); + + /*import symbols*/ + symbol = Trees_NewIdent("Test"); + Trees_SetKind(TREES_QUALIFIER_KIND, symbol); + Table_Put(symbol); + Table_Import(symfilename, "Test", "Test"); + + result = Table_At("Test.a"); + assert(result != NULL); + assert(Trees_Kind(result) == TREES_CONSTANT_KIND); + value = Trees_Value(result); + assert(Trees_Symbol(value) == INTEGER); + assert(Trees_Integer(value) == 37); + + result = Table_At("Test.X"); + assert(result != NULL); + assert(Trees_Kind(result) == TREES_PROCEDURE_KIND); +} + + +int main(void) +{ + int error; + const char *tmpdir; + + Files_Init(); + Util_Init(); + StackTrace_Init(NULL); + + tmpdir = getenv("TMPDIR"); + if (tmpdir == NULL) { + tmpdir = "/tmp"; + } + symfilename = Util_String("%s/TableTest.%d", tmpdir, getpid()); + + error = atexit(DeleteSymbolFile); + if (error) { + fprintf(stderr, "error: atexit failed with error: %d\n", error); + exit(EXIT_FAILURE); + } + + Test(); + return 0; +} diff --git a/src/Time.c b/src/Time.c new file mode 100644 index 0000000..2677655 --- /dev/null +++ b/src/Time.c @@ -0,0 +1,69 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Time.h" +#include "Error.h" +#include "Util.h" +#ifdef _WIN32 + #include +#else + #include /*POSIX*/ +#endif +#include +#include +#include + +#ifdef _WIN32 + +int Time(void) +{ + return GetTickCount(); +} + +#else /*POSIX*/ + +#ifndef CLOCK_MONOTONIC +#define CLOCK_MONOTONIC 1 + +static int clock_gettime(int clock_id, struct timespec *result) +{ + struct timeval t; + + gettimeofday(&t, NULL); + result->tv_sec = t.tv_sec; + result->tv_nsec = t.tv_usec * 1000; + return 0; +} + +#endif + +int Time(void) +{ + struct timespec now; + int error; + int result = -1; + + error = clock_gettime(CLOCK_MONOTONIC, &now); + if (! error) { + result = now.tv_sec * 1000 + now.tv_nsec / 1000000; + } else { + Error_Handle(Util_String("Time failed: clock_gettime: %s\n", strerror(errno))); + } + return result; +} + +#endif diff --git a/src/Time.h b/src/Time.h new file mode 100644 index 0000000..04e2754 --- /dev/null +++ b/src/Time.h @@ -0,0 +1,23 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef TIME_H +#define TIME_H + +int Time(void); /*returns time elapsed since system startup in milliseconds*/ + +#endif diff --git a/src/Trees.c b/src/Trees.c new file mode 100644 index 0000000..98dc943 --- /dev/null +++ b/src/Trees.c @@ -0,0 +1,830 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Trees.h" +#include "lex.yy.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" +#include "y.tab.h" +#include +#include +#include +#include +#include +#include + +/*value types*/ +enum { + NO_VALUE, + IDENT_VALUE, + INTEGER_VALUE, + REAL_VALUE, + STRING_VALUE, + CHAR_VALUE, + SET_VALUE, + VALUE_TYPE_COUNT +}; + +struct Trees_NodeDesc { + int valueType; + int symbol; + int lineNumber; + int marked; + union { + struct { + const char *name, *unaliasedName; + int kind; + unsigned int local:1, imported:1, exported:1, internal:1, used:1; + Trees_Node value; + } ident; + OBNC_INTEGER integer; + OBNC_REAL real; + char *string; + char ch; + unsigned OBNC_INTEGER set; + } value; + Trees_Node type; + Trees_Node left, right; +}; + +static int initialized = 0; + +void Trees_Init(void) +{ + if (! initialized) { + initialized = 1; + Util_Init(); + } +} + + +Trees_Node Trees_NewNode(int symbol, Trees_Node left, Trees_Node right) +{ + Trees_Node result; + + assert(initialized); + NEW(result); + result->valueType = NO_VALUE; + result->symbol = symbol; + result->lineNumber = yylineno; + result->marked = 0; + result->type = NULL; + result->left = left; + result->right = right; + return result; +} + + +Trees_Node Trees_NewLeaf(int symbol) +{ + return Trees_NewNode(symbol, NULL, NULL); +} + + +int Trees_IsLeaf(Trees_Node node) +{ + assert(node != NULL); + + return (node->left == NULL) && (node->right == NULL); +} + + +void Trees_SetType(Trees_Node type, Trees_Node node) +{ + assert(node != NULL); + + node->type = type; +} + + +Trees_Node Trees_Type(Trees_Node node) +{ + assert(node != NULL); + + return node->type; +} + + +int Trees_Symbol(Trees_Node node) +{ + assert(node != NULL); + + return node->symbol; +} + + +int Trees_LineNumber(Trees_Node node) +{ + assert(node != NULL); + + return node->lineNumber; +} + + +void Trees_SetLeft(Trees_Node newLeft, Trees_Node tree) +{ + assert(tree != NULL); + tree->left = newLeft; +} + + +void Trees_SetRight(Trees_Node newRight, Trees_Node tree) +{ + assert(tree != NULL); + tree->right = newRight; +} + + +Trees_Node Trees_Left(Trees_Node tree) +{ + assert(tree != NULL); + + return tree->left; +} + + +Trees_Node Trees_Right(Trees_Node tree) +{ + assert(tree != NULL); + + return tree->right; +} + + +void Trees_ReverseList(Trees_Node *list) +{ + Trees_Node current, previous, next; + + current = *list; + previous = NULL; + while (current != NULL) { + next = current->right; /*save next node*/ + current->right = previous; /*reverse pointer*/ + previous = current; /*save current node*/ + current = next; /*advance current*/ + } + *list = previous; +} + + +static void PrintLabel(int symbol) +{ + if (symbol < 128) { + putchar(symbol); + } else { + switch (symbol) { + case ARRAY: + printf("array"); + break; + case BECOMES: + printf(":="); + break; + case BY: + printf("BY"); + break; + case CASE: + printf("CASE"); + break; + case DO: + printf("DO"); + break; + case DOTDOT: + printf(".."); + break; + case DIV: + printf("DIV"); + break; + case FALSE: + printf("FALSE"); + break; + case FOR: + printf("FOR"); + break; + case GE: + printf(">="); + break; + case ELSE: + printf("ELSE"); + break; + case ELSIF: + printf("ELSIF"); + break; + case IN: + printf("IN"); + break; + case IF: + printf("IF"); + break; + case IS: + printf("IS"); + break; + case LE: + printf("<="); + break; + case MOD: + printf("MOD"); + break; + case MODULE: + printf("MODULE"); + break; + case NIL: + printf("NIL"); + break; + case OR: + printf("OR"); + break; + case POINTER: + printf("POINTER"); + break; + case RECORD: + printf("RECORD"); + break; + case REPEAT: + printf("REPEAT"); + break; + case THEN: + printf("THEN"); + break; + case TO: + printf("TO"); + break; + case TREES_NOSYM: + printf("(none)"); + break; + case TREES_ABS_PROC: + printf("ABS"); + break; + case TREES_ADR_PROC: + printf("SYSTEM.ADR"); + break; + case TREES_ASR_PROC: + printf("ASR"); + break; + case TREES_ASSERT_PROC: + printf("ASSERT"); + break; + case TREES_BIT_PROC: + printf("SYSTEM.BIT"); + break; + case TREES_BOOLEAN_TYPE: + printf("BooleanType"); + break; + case TREES_BYTE_TYPE: + printf("ByteType"); + break; + case TREES_CASE: + printf("case"); + break; + case TREES_CASE_LABEL_LIST: + printf("CaseLabelList"); + break; + case TREES_CASE_REP: + printf("CaseRep"); + break; + case TREES_CHAR_TYPE: + printf("CharType"); + break; + case TREES_CHR_PROC: + printf("CHR"); + break; + case TREES_COPY_PROC: + printf("SYSTEM.COPY"); + break; + case TREES_DEC_PROC: + printf("DEC"); + break; + case TREES_DESIGNATOR: + printf("designator"); + break; + case TREES_EXCL_PROC: + printf("EXCL"); + break; + case TREES_EXP_LIST: + printf("ExpList"); + break; + case TREES_FIELD_LIST_SEQUENCE: + printf("FieldListSequence"); + break; + case TREES_FILE_POSITION: + printf("FilePosition"); + break; + case TREES_FLOOR_PROC: + printf("FLOOR"); + break; + case TREES_FLT_PROC: + printf("FLT"); + break; + case TREES_GET_PROC: + printf("SYSTEM.GET"); + break; + case TREES_IDENT_LIST: + printf("IdentList"); + break; + case TREES_INC_PROC: + printf("INC"); + break; + case TREES_INCL_PROC: + printf("INCL"); + break; + case TREES_INTEGER_TYPE: + printf("IntegerType"); + break; + case TREES_LEN_PROC: + printf("LEN"); + break; + case TREES_LSL_PROC: + printf("LSL"); + break; + case TREES_NEW_PROC: + printf("NEW"); + break; + case TREES_NIL_TYPE: + printf("NilType"); + break; + case TREES_ODD_PROC: + printf("ODD"); + break; + case TREES_ORD_PROC: + printf("ORD"); + break; + case TREES_PACK_PROC: + printf("PACK"); + break; + case TREES_PROCEDURE_CALL: + printf("ProcedureCall"); + break; + case TREES_PUT_PROC: + printf("SYSTEM.PUT"); + break; + case PROCEDURE: + printf("Procedure"); + break; + case TREES_RANGE_SET: + printf("RangeSet"); + break; + case TREES_REAL_TYPE: + printf("RealType"); + break; + case TREES_ROR_PROC: + printf("ROR"); + break; + case TREES_SET_TYPE: + printf("SetType"); + break; + case TREES_SINGLE_ELEMENT_SET: + printf("SingleElementSet"); + break; + case TREES_SIZE_PROC: + printf("SYSTEM.SIZE"); + break; + case TREES_STATEMENT_SEQUENCE: + printf("StatementSequence"); + break; + case TREES_STRING_TYPE: + printf("StringType"); + break; + case TREES_UNPK_PROC: + printf("UNPK"); + break; + case TREES_VAL_PROC: + printf("SYSTEM.VAL"); + break; + case TRUE: + printf("TRUE"); + break; + case WHILE: + printf("WHILE"); + break; + default: + fprintf(stderr, "error: no label for symbol: %d\n", symbol); + assert(0); + } + } +} + + +static void Indent(int level) +{ + int i; + + for (i = 0; i < level; i++) { + putchar('\t'); + } +} + +static void PrintRec(Trees_Node tree, int height) +{ + if (tree == NULL) { + puts("(nil)"); + } else { + Indent(height); + switch (tree->valueType) { + case NO_VALUE: + PrintLabel(tree->symbol); + putchar('\n'); + break; + case IDENT_VALUE: + printf("ident %s", tree->value.ident.name); + if (tree->value.ident.unaliasedName != NULL + && (strcmp(tree->value.ident.unaliasedName, tree->value.ident.name) != 0)) { + printf(" (%s)", tree->value.ident.unaliasedName); + } + /*printf(" (exp: %d, imp: %d)\n", tree->value.ident.exported, tree->value.ident.imported);*/ + putchar('\n'); + break; + case INTEGER_VALUE: + printf("%" OBNC_INT_MOD "d\n", tree->value.integer); + break; + case REAL_VALUE: + printf("%.*" OBNC_REAL_MOD_W "g\n", DBL_DIG, tree->value.real); + break; + case STRING_VALUE: + printf("\"%s\"\n", tree->value.string); + break; + case CHAR_VALUE: + printf("'%c'\n", tree->value.ch); + break; + case SET_VALUE: + printf("0x%" OBNC_INT_MOD "xu\n", tree->value.set); + break; + default: + assert(0); + } + if ((tree->left != NULL) && (tree->right != NULL)) { + PrintRec(tree->left, height + 1); + PrintRec(tree->right, height + 1); + } else if ((tree->left != NULL) && (tree->right == NULL)) { + PrintRec(tree->left, height + 1); + Indent(height + 1); + puts("(nil)"); + } else if ((tree->left == NULL) && (tree->right != NULL)) { + Indent(height + 1); + puts("(nil)"); + PrintRec(tree->right, height + 1); + } + } +} + + +void Trees_Print(Trees_Node tree) +{ + PrintRec(tree, 0); +} + + +/*Identifiers*/ + +Trees_Node Trees_NewIdent(const char name[]) +{ + Trees_Node result; + + assert(name != NULL); + + result = Trees_NewLeaf(IDENT); + result->valueType = IDENT_VALUE; + result->value.ident.name = name; + result->value.ident.unaliasedName = name; + result->value.ident.kind = TREES_UNSPECIFIED_KIND; + result->value.ident.local = 0; + result->value.ident.imported = 0; + result->value.ident.exported = 0; + result->value.ident.internal = 0; + result->value.ident.used = 0; + result->value.ident.value = NULL; + return result; +} + + +const char *Trees_Name(Trees_Node node) +{ + assert(node != NULL); + assert(node->valueType == IDENT_VALUE); + + return node->value.ident.name; +} + + +void Trees_SetName(const char name[], Trees_Node identNode) +{ + assert(name != NULL); + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + identNode->value.ident.name = name; +} + + +const char *Trees_UnaliasedName(Trees_Node node) +{ + assert(node != NULL); + assert(node->valueType == IDENT_VALUE); + + return node->value.ident.unaliasedName; +} + + +void Trees_SetUnaliasedName(const char name[], Trees_Node identNode) +{ + assert(name != NULL); + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + identNode->value.ident.unaliasedName = name; +} + + +int Trees_Kind(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + return identNode->value.ident.kind; +} + + +void Trees_SetKind(int kind, Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + assert(kind >= 0); + assert(kind < TREES_KIND_COUNT); + + identNode->value.ident.kind = kind; +} + + +int Trees_Local(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + return identNode->value.ident.local; +} + + +void Trees_SetLocal(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + identNode->value.ident.local = 1; +} + + +int Trees_Imported(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + return identNode->value.ident.imported; +} + + +void Trees_SetImported(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + identNode->value.ident.imported = 1; +} + + +int Trees_Exported(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + return identNode->value.ident.exported; +} + + +void Trees_SetExported(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + identNode->value.ident.exported = 1; +} + + +int Trees_Internal(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + return identNode->value.ident.internal; +} + + +void Trees_SetInternal(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + identNode->value.ident.internal = 1; +} + + +int Trees_Used(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + return identNode->value.ident.used; +} + + +void Trees_SetUsed(Trees_Node identNode) +{ + assert(identNode != NULL); + assert(identNode->valueType == IDENT_VALUE); + + identNode->value.ident.used = 1; +} + + +Trees_Node Trees_Value(Trees_Node node) +{ + Trees_Node value; + + assert(node != NULL); + assert(node->valueType == IDENT_VALUE); + assert(node->value.ident.kind == TREES_CONSTANT_KIND); + + value = node->value.ident.value; + if (Trees_Symbol(value) == STRING) { + /*string constants are sometimes put in char context so we cannot reuse the same node*/ + value = Trees_NewString(Trees_String(value)); + } + return value; +} + + +void Trees_SetValue(Trees_Node valueNode, Trees_Node constNode) +{ + assert(valueNode != NULL); + assert(constNode != NULL); + assert(constNode->valueType == IDENT_VALUE); + assert(constNode->value.ident.kind == TREES_CONSTANT_KIND); + + constNode->value.ident.value = valueNode; +} + + +/*Booleans*/ + +Trees_Node Trees_NewBoolean(int b) +{ + Trees_Node result; + + if (b) { + result = Trees_NewLeaf(TRUE); + } else { + result = Trees_NewLeaf(FALSE); + } + result->valueType = NO_VALUE; + result->type = Trees_NewLeaf(TREES_BOOLEAN_TYPE); + return result; +} + + +int Trees_Boolean(Trees_Node boolNode) +{ + assert(boolNode != NULL); + assert(boolNode->valueType == NO_VALUE); + assert((boolNode->symbol == TRUE) || (boolNode->symbol == FALSE)); + + return boolNode->symbol == TRUE; +} + + +/*Integers*/ + +Trees_Node Trees_NewInteger(OBNC_INTEGER value) +{ + Trees_Node result; + + result = Trees_NewLeaf(INTEGER); + result->valueType = INTEGER_VALUE; + result->value.integer = value; + result->type = Trees_NewLeaf(TREES_INTEGER_TYPE); + return result; +} + + +OBNC_INTEGER Trees_Integer(Trees_Node integerNode) +{ + assert(integerNode != NULL); + assert(integerNode->valueType == INTEGER_VALUE); + + return integerNode->value.integer; +} + + +/*Real numbers*/ + +Trees_Node Trees_NewReal(OBNC_REAL value) +{ + Trees_Node result; + + result = Trees_NewLeaf(REAL); + result->valueType = REAL_VALUE; + result->value.real = value; + result->type = Trees_NewLeaf(TREES_REAL_TYPE); + return result; +} + + +OBNC_REAL Trees_Real(Trees_Node realNode) +{ + assert(realNode != NULL); + assert(realNode->valueType == REAL_VALUE); + + return realNode->value.real; +} + + +/*Strings*/ + +Trees_Node Trees_NewString(const char string[]) +{ + Trees_Node result; + + assert(string != NULL); + + result = Trees_NewLeaf(STRING); + result->valueType = STRING_VALUE; + NEW_ARRAY(result->value.string, strlen(string) + 1); + strcpy(result->value.string, string); + result->type = Trees_NewNode(TREES_STRING_TYPE, Trees_NewInteger((int) strlen(string)), NULL); + return result; +} + + +const char *Trees_String(Trees_Node stringNode) +{ + assert(stringNode != NULL); + assert(stringNode->valueType == STRING_VALUE); + assert(stringNode->value.string != NULL); + return stringNode->value.string; +} + + +/*Characters*/ + +Trees_Node Trees_NewChar(char value) +{ + Trees_Node result; + + result = Trees_NewLeaf(TREES_CHAR_CONSTANT); + result->valueType = CHAR_VALUE; + result->value.ch = value; + result->type = Trees_NewLeaf(TREES_CHAR_TYPE); + return result; +} + + +char Trees_Char(Trees_Node charNode) +{ + assert(charNode != NULL); + assert(charNode->valueType == CHAR_VALUE); + + return charNode->value.ch; +} + + +/*Set constants*/ + +Trees_Node Trees_NewSet(unsigned OBNC_INTEGER value) +{ + Trees_Node result; + + result = Trees_NewLeaf(TREES_SET_CONSTANT); + result->valueType = SET_VALUE; + result->value.set = value; + result->type = Trees_NewLeaf(TREES_SET_TYPE); + return result; +} + + +unsigned OBNC_INTEGER Trees_Set(Trees_Node setNode) +{ + assert(setNode != NULL); + assert(setNode->valueType == SET_VALUE); + + return setNode->value.set; +} diff --git a/src/Trees.h b/src/Trees.h new file mode 100644 index 0000000..912e1e7 --- /dev/null +++ b/src/Trees.h @@ -0,0 +1,201 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef TREES_H +#define TREES_H + +#include "../lib/obnc/OBNC.h" +#include + +/*node symbols*/ +enum { + TREES_NOSYM = 1000, /*larger than largest terminal symbol*/ + + TREES_CHAR_CONSTANT, + TREES_SET_CONSTANT, + + TREES_BOOLEAN_TYPE, + TREES_CHAR_TYPE, + TREES_STRING_TYPE, + TREES_INTEGER_TYPE, + TREES_REAL_TYPE, + TREES_SET_TYPE, + TREES_BYTE_TYPE, + TREES_NIL_TYPE, + + TREES_ABS_PROC, + TREES_ASR_PROC, + TREES_ASSERT_PROC, + TREES_CHR_PROC, + TREES_DEC_PROC, + TREES_EXCL_PROC, + TREES_FLOOR_PROC, + TREES_FLT_PROC, + TREES_INC_PROC, + TREES_INCL_PROC, + TREES_LEN_PROC, + TREES_LSL_PROC, + TREES_NEW_PROC, + TREES_ODD_PROC, + TREES_ORD_PROC, + TREES_PACK_PROC, + TREES_ROR_PROC, + TREES_UNPK_PROC, + + TREES_CASE, + TREES_CASE_LABEL_LIST, + TREES_CASE_REP, + TREES_DESIGNATOR, + TREES_EXP_LIST, + TREES_FIELD_LIST_SEQUENCE, + TREES_IDENT_LIST, + TREES_PROCEDURE_CALL, + TREES_RANGE_SET, + TREES_SINGLE_ELEMENT_SET, + TREES_STATEMENT_SEQUENCE, + TREES_FILE_POSITION, + + TREES_ADR_PROC, + TREES_SIZE_PROC, + TREES_BIT_PROC, + TREES_GET_PROC, + TREES_PUT_PROC, + TREES_COPY_PROC, + TREES_VAL_PROC, + + TREES_SYMBOL_END +}; + +/*identifier kinds*/ +enum { + TREES_UNSPECIFIED_KIND, + TREES_QUALIFIER_KIND, + TREES_CONSTANT_KIND, + TREES_TYPE_KIND, + TREES_FIELD_KIND, + TREES_VARIABLE_KIND, + TREES_PROCEDURE_KIND, + TREES_VALUE_PARAM_KIND, + TREES_VAR_PARAM_KIND, + TREES_KIND_COUNT +}; + +typedef struct Trees_NodeDesc *Trees_Node; + +void Trees_Init(void); + +Trees_Node Trees_NewNode(int symbol, Trees_Node left, Trees_Node right); + +Trees_Node Trees_NewLeaf(int symbol); + +int Trees_IsLeaf(Trees_Node node); + +void Trees_SetType(Trees_Node type, Trees_Node ident); + +Trees_Node Trees_Type(Trees_Node node); + +int Trees_Symbol(Trees_Node node); + +int Trees_LineNumber(Trees_Node node); + +void Trees_SetLeft(Trees_Node newLeft, Trees_Node tree); + +void Trees_SetRight(Trees_Node newRight, Trees_Node tree); + +Trees_Node Trees_Left(Trees_Node tree); + +Trees_Node Trees_Right(Trees_Node tree); + +void Trees_ReverseList(Trees_Node *list); + +void Trees_Print(Trees_Node tree); + + +/*Identifiers*/ + +Trees_Node Trees_NewIdent(const char name[]); + +const char *Trees_Name(Trees_Node ident); +void Trees_SetName(const char name[], Trees_Node ident); + +const char *Trees_UnaliasedName(Trees_Node ident); +void Trees_SetUnaliasedName(const char name[], Trees_Node ident); + +int Trees_Kind(Trees_Node ident); +void Trees_SetKind(int kind, Trees_Node ident); + +int Trees_Local(Trees_Node ident); +void Trees_SetLocal(Trees_Node ident); + +int Trees_Imported(Trees_Node ident); +void Trees_SetImported(Trees_Node ident); + +int Trees_Exported(Trees_Node ident); +void Trees_SetExported(Trees_Node ident); + +int Trees_Internal(Trees_Node ident); +void Trees_SetInternal(Trees_Node ident); + +int Trees_Used(Trees_Node ident); +void Trees_SetUsed(Trees_Node ident); + +Trees_Node Trees_Value(Trees_Node constIdent); +void Trees_SetValue(Trees_Node value, Trees_Node constIdent); + + +/*Boolean*/ + +Trees_Node Trees_NewBoolean(int b); + +int Trees_Boolean(Trees_Node boolNode); + + +/*Characters*/ + +Trees_Node Trees_NewChar(char ch); + +char Trees_Char(Trees_Node charNode); + + +/*Strings*/ + +Trees_Node Trees_NewString(const char string[]); + +const char *Trees_String(Trees_Node stringNode); + + +/*Integers*/ + +Trees_Node Trees_NewInteger(OBNC_INTEGER value); + +OBNC_INTEGER Trees_Integer(Trees_Node integerNode); + + +/*Real numbers*/ + +Trees_Node Trees_NewReal(OBNC_REAL value); + +OBNC_REAL Trees_Real(Trees_Node realNode); + + +/*Set constants*/ + +Trees_Node Trees_NewSet(unsigned OBNC_INTEGER value); + +unsigned OBNC_INTEGER Trees_Set(Trees_Node setNode); + +#endif diff --git a/src/Types.c b/src/Types.c new file mode 100644 index 0000000..df56290 --- /dev/null +++ b/src/Types.c @@ -0,0 +1,811 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Types.h" +#include "Oberon.h" +#include "../lib/obnc/OBNC.h" +#include "y.tab.h" +#include +#include + +int Types_IsType(Trees_Node node) +{ + int result; + + assert(node != NULL); + + result = 0; + switch (Trees_Symbol(node)) { + case TREES_BOOLEAN_TYPE: + case TREES_CHAR_TYPE: + case TREES_INTEGER_TYPE: + case TREES_REAL_TYPE: + case TREES_BYTE_TYPE: + case TREES_SET_TYPE: + case TREES_STRING_TYPE: + case TREES_ABS_PROC: + case TREES_ASR_PROC: + case TREES_ASSERT_PROC: + case TREES_CHR_PROC: + case TREES_DEC_PROC: + case TREES_EXCL_PROC: + case TREES_FLOOR_PROC: + case TREES_FLT_PROC: + case TREES_INC_PROC: + case TREES_INCL_PROC: + case TREES_LEN_PROC: + case TREES_LSL_PROC: + case TREES_NEW_PROC: + case TREES_NIL_TYPE: + case TREES_ODD_PROC: + case TREES_ORD_PROC: + case TREES_PACK_PROC: + case TREES_ROR_PROC: + case TREES_UNPK_PROC: + + case TREES_ADR_PROC: + case TREES_SIZE_PROC: + case TREES_BIT_PROC: + case TREES_GET_PROC: + case TREES_PUT_PROC: + case TREES_COPY_PROC: + case TREES_VAL_PROC: + + case ARRAY: + case RECORD: + case POINTER: + case PROCEDURE: + result = 1; + break; + case IDENT: + result = Trees_Kind(node) == TREES_TYPE_KIND; + break; + } + return result; +} + + +int Types_IsBoolean(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Trees_Symbol(Types_Structure(type)) == TREES_BOOLEAN_TYPE; +} + + +int Types_IsChar(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Trees_Symbol(Types_Structure(type)) == TREES_CHAR_TYPE; +} + + +int Types_IsInteger(Trees_Node type) +{ + int sym; + + assert(Types_IsType(type)); + sym = Trees_Symbol(Types_Structure(type)); + return (sym == TREES_INTEGER_TYPE) || (sym == TREES_BYTE_TYPE); +} + + +int Types_IsReal(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Trees_Symbol(Types_Structure(type)) == TREES_REAL_TYPE; +} + + +int Types_IsByte(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Trees_Symbol(Types_Structure(type)) == TREES_BYTE_TYPE; +} + + +int Types_IsSet(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Trees_Symbol(Types_Structure(type)) == TREES_SET_TYPE; +} + + +int Types_IsString(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Trees_Symbol(type) == TREES_STRING_TYPE; +} + + +OBNC_INTEGER Types_StringLength(Trees_Node stringType) +{ + assert(Types_IsString(stringType)); + + return Trees_Integer(Trees_Left(stringType)); +} + + +int Types_IsSingleCharString(Trees_Node type) +{ + return Types_IsString(type) && (Types_StringLength(type) <= 1); +} + + +int Types_Basic(Trees_Node type) +{ + int basic; + + assert(Types_IsType(type)); + + basic = 0; + switch (Trees_Symbol(type)) { + case TREES_BOOLEAN_TYPE: + case TREES_CHAR_TYPE: + case TREES_INTEGER_TYPE: + case TREES_REAL_TYPE: + case TREES_BYTE_TYPE: + case TREES_SET_TYPE: + basic = 1; + break; + } + + return basic; +} + + +int Types_Scalar(Trees_Node type) +{ + assert(Types_IsType(type)); + + return ! Types_IsArray(type) && ! Types_IsRecord(type); +} + + +Trees_Node Types_Structure(Trees_Node type) +{ + Trees_Node result; + + assert(type != NULL); + assert(Types_IsType(type)); + + /*NOTE: the type of an unresolved type identifier may be NULL*/ + result = type; + while ((result != NULL) && (Trees_Symbol(result) == IDENT)) { + result = Trees_Type(result); + } + return result; +} + + +Trees_Node Types_UnaliasedIdent(Trees_Node type) +{ + Trees_Node result, refType; + + assert(type != NULL); + assert(Trees_Symbol(type) == IDENT); + + result = type; + refType = Trees_Type(type); + while ((refType != NULL) && (Trees_Symbol(refType) == IDENT)) { + result = refType; + refType = Trees_Type(refType); + + } + return result; +} + + +int Types_IsArray(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Trees_Symbol(Types_Structure(type)) == ARRAY; +} + + +Trees_Node Types_NewArray(Trees_Node length, Trees_Node elemType) +{ + assert((length == NULL) || Types_IsInteger(Trees_Type(length))); + assert(Types_IsType(elemType)); + + return Trees_NewNode(ARRAY, length, elemType); +} + + +int Types_IsOpenArray(Trees_Node type) +{ + assert(Types_IsType(type)); + + return (Trees_Symbol(type) == ARRAY) && (Types_ArrayLength(type) == NULL); +} + + +int Types_IsCharacterArray(Trees_Node type) +{ + assert(Types_IsType(type)); + + return Types_IsArray(type) && Types_IsChar(Types_ElementType(type)); +} + + +Trees_Node Types_ArrayLength(Trees_Node arrayType) +{ + assert(Types_IsArray(arrayType)); + + return Trees_Left(Types_Structure(arrayType)); +} + + +Trees_Node Types_ElementType(Trees_Node arrayType) +{ + assert(Types_IsArray(arrayType)); + + return Trees_Right(Types_Structure(arrayType)); +} + + +void Types_SetElementType(Trees_Node elemType, Trees_Node arrayType) +{ + assert(Types_IsType(elemType)); + assert(Types_IsArray(arrayType)); + + Trees_SetRight(elemType, Types_Structure(arrayType)); +} + + +Trees_Node Types_NewRecord(Trees_Node recBaseType, Trees_Node fields) +{ + assert((recBaseType == NULL) || (Trees_Type(recBaseType) == NULL) + || Types_IsRecord(recBaseType) || Types_IsPointer(recBaseType)); + assert((fields == NULL) || (Trees_Symbol(fields) == TREES_FIELD_LIST_SEQUENCE)); + + return Trees_NewNode(RECORD, recBaseType, fields); +} + + +int Types_IsRecord(Trees_Node type) +{ + return Trees_Symbol(Types_Structure(type)) == RECORD; +} + + +Trees_Node Types_RecordBaseType(Trees_Node type) +{ + Trees_Node typeStruct, result, record; + + typeStruct = Types_Structure(type); + result = NULL; + switch (Trees_Symbol(typeStruct)) { + case RECORD: + result = Trees_Left(typeStruct); + break; + case POINTER: + record = Types_PointerBaseType(typeStruct); + result = Trees_Left(Types_Structure(record)); + break; + default: + assert(0); + } + return result; +} + + +void Types_SetRecordBaseType(Trees_Node recBaseType, Trees_Node recordType) +{ + assert(Types_Extensible(recBaseType)); + assert(Types_IsRecord(recordType)); + + Trees_SetLeft(recBaseType, Types_Structure(recordType)); +} + + +Trees_Node Types_Fields(Trees_Node record) +{ + Trees_Node typeStruct; + + typeStruct = Types_Structure(record); + assert(Trees_Symbol(typeStruct) == RECORD); + return Trees_Right(typeStruct); +} + + +int Types_Extensible(Trees_Node type) +{ + int sym; + + sym = Trees_Symbol(Types_Structure(type)); + return (sym == RECORD) || (sym == POINTER); +} + + +static Trees_Node NamedDescriptor(Trees_Node extensibleType) +{ + Trees_Node desc, result; + + desc = Types_Descriptor(extensibleType); + if (Trees_Symbol(desc) == IDENT) { + result = desc; + } else { + result = extensibleType; /*pointer to anonymous record*/ + } + return result; +} + + +int Types_Extends(Trees_Node baseType, Trees_Node extendedType) +{ + int result; + Trees_Node baseName, intermediateType; + + assert(baseType != NULL); + assert(extendedType != NULL); + + if (Types_Same(Types_Descriptor(baseType), Types_Descriptor(extendedType))) { + result = 1; + } else { + baseName = NamedDescriptor(baseType); + intermediateType = Types_RecordBaseType(extendedType); + while ((intermediateType != NULL) + && ! Types_Same(NamedDescriptor(intermediateType), baseName)) { + intermediateType = Types_RecordBaseType(intermediateType); + } + result = intermediateType != NULL; + } + return result; +} + + +int Types_ExtensionLevel(Trees_Node type) +{ + int n = -1; + + do { + n++; + type = Types_RecordBaseType(type); + } while (type != NULL); + return n; +} + + +Trees_Node Types_Descriptor(Trees_Node type) +{ + Trees_Node result, typeStruct; + + assert(type != NULL); + + result = NULL; + typeStruct = Types_Structure(type); + switch (Trees_Symbol(typeStruct)) { + case RECORD: + result = type; + break; + case POINTER: + result = Types_PointerBaseType(typeStruct); + break; + default: + assert(0); + } + assert(result != NULL); + return result; +} + + +void Types_GetFieldIdent(const char fieldName[], Trees_Node type, int varImported, Trees_Node *fieldIdent, Trees_Node *fieldBaseType) +{ + Trees_Node baseType, baseTypeDesc, fieldListSeq, identList, ident; + int imported; + + assert(Types_IsRecord(type) || Types_IsPointer(type)); + + *fieldIdent = NULL; + *fieldBaseType = NULL; + baseType = type; + imported = varImported; + do { + if (! imported && (Trees_Symbol(baseType) == IDENT) && Trees_Imported(baseType)) { + imported = 1; + } + baseTypeDesc = Types_Descriptor(baseType); + /*search current base type for field name*/ + fieldListSeq = Types_Fields(baseTypeDesc); + while ((fieldListSeq != NULL) && (*fieldIdent == NULL)) { + identList = Trees_Left(fieldListSeq); + do { + ident = Trees_Left(identList); + if ((! imported || Trees_Exported(ident)) && (strcmp(Trees_Name(ident), fieldName) == 0)) { + *fieldIdent = ident; + *fieldBaseType = baseType; + } + identList = Trees_Right(identList); + } while (identList != NULL); + fieldListSeq = Trees_Right(fieldListSeq); + } + + baseType = Types_RecordBaseType(baseTypeDesc); + } while ((baseType != NULL) && (*fieldIdent == NULL)); + + assert((*fieldIdent == NULL) || (*fieldBaseType != NULL)); +} + + +Trees_Node Types_NewPointer(Trees_Node ptrBaseType) +{ + assert((ptrBaseType == NULL) || (Trees_Type(ptrBaseType) == NULL) || Types_IsRecord(ptrBaseType)); + + return Trees_NewNode(POINTER, ptrBaseType, NULL); +} + + +int Types_IsPointer(Trees_Node type) +{ + return Trees_Symbol(Types_Structure(type)) == POINTER; +} + + +Trees_Node Types_PointerBaseType(Trees_Node ptrType) +{ + assert(Types_IsPointer(ptrType)); + + return Trees_Left(Types_Structure(ptrType)); +} + + +void Types_SetPointerBaseType(Trees_Node ptrBaseType, Trees_Node ptrType) +{ + assert(Types_IsRecord(ptrBaseType)); + assert(Types_IsPointer(ptrType)); + + Trees_SetLeft(ptrBaseType, Types_Structure(ptrType)); +} + + +Trees_Node Types_NewProcedure(Trees_Node fields, Trees_Node resultType) +{ + assert((fields == NULL) || (Trees_Symbol(fields) == TREES_IDENT_LIST)); + assert((resultType == NULL) || Types_IsType(resultType)); + + return Trees_NewNode(PROCEDURE, fields, resultType); +} + + +int Types_IsProcedure(Trees_Node type) +{ + Trees_Node typeStruct; + + assert(Types_IsType(type)); + + typeStruct = Types_Structure(type); + return (Trees_Symbol(typeStruct) == PROCEDURE) || Types_IsPredeclaredProcedure(typeStruct); +} + + +int Types_IsPredeclaredProcedure(Trees_Node type) +{ + int predeclared; + + assert(Types_IsType(type)); + + predeclared = 0; + switch (Trees_Symbol(Types_Structure(type))) { + case TREES_ABS_PROC: + case TREES_ASR_PROC: + case TREES_ASSERT_PROC: + case TREES_CHR_PROC: + case TREES_DEC_PROC: + case TREES_EXCL_PROC: + case TREES_FLOOR_PROC: + case TREES_FLT_PROC: + case TREES_INC_PROC: + case TREES_INCL_PROC: + case TREES_LEN_PROC: + case TREES_LSL_PROC: + case TREES_NEW_PROC: + case TREES_ODD_PROC: + case TREES_ORD_PROC: + case TREES_PACK_PROC: + case TREES_ROR_PROC: + case TREES_UNPK_PROC: + /*SYSTEM*/ + case TREES_ADR_PROC: + case TREES_SIZE_PROC: + case TREES_BIT_PROC: + case TREES_GET_PROC: + case TREES_PUT_PROC: + case TREES_COPY_PROC: + case TREES_VAL_PROC: + predeclared = 1; + break; + } + return predeclared; +} + + +Trees_Node Types_Parameters(Trees_Node procType) +{ + assert(Types_IsProcedure(procType)); + + return Trees_Left(Types_Structure(procType)); +} + + +Trees_Node Types_ResultType(Trees_Node procType) +{ + assert(Types_IsProcedure(procType)); + + return Trees_Right(Types_Structure(procType)); +} + + +void Types_SetResultType(Trees_Node resultType, Trees_Node procType) +{ + assert((resultType == NULL) || Types_IsType(resultType)); + assert(Types_IsProcedure(procType)); + + Trees_SetRight(resultType, Types_Structure(procType)); +} + + +int Types_Same(Trees_Node typeA, Trees_Node typeB) +{ + assert(Types_IsType(typeA)); + assert(Types_IsType(typeB)); + + return (Types_Structure(typeA) == Types_Structure(typeB)) + || (Types_Basic(typeA) && Types_Basic(typeB) && (Trees_Symbol(typeA) == Trees_Symbol(typeB))) + || ((Trees_Symbol(typeA) == IDENT) && (Trees_Symbol(typeB) == IDENT) + && (strcmp( + Trees_UnaliasedName(Types_UnaliasedIdent(typeA)), + Trees_UnaliasedName(Types_UnaliasedIdent(typeB))) == 0)); +} + + +static int FormalParametersMatch(Trees_Node procTypeA, Trees_Node procTypeB); + +static int TypesEqual(Trees_Node typeA, Trees_Node typeB) +{ + return Types_Same(typeA, typeB) + || (Types_IsOpenArray(typeA) && Types_IsOpenArray(typeB) + && TypesEqual(Types_ElementType(typeA), Types_ElementType(typeB))) + || (Types_IsProcedure(typeA) && Types_IsProcedure(typeB) + && FormalParametersMatch(typeA, typeB)); +} + + +int Types_AssignmentCompatible(Trees_Node sourceExp, Trees_Node targetType) +{ + int result; + Trees_Node sourceType; + + assert(sourceExp != NULL); + assert(Types_IsType(targetType)); + + result = 0; + sourceType = Trees_Type(sourceExp); + if ((sourceType != NULL) && (Types_Same(sourceType, targetType))) { + result = ! Types_IsString(targetType); + } else { + switch (Trees_Symbol(Types_Structure(targetType))) { + case TREES_CHAR_TYPE: + result = Types_IsString(sourceType) && (Types_StringLength(sourceType) <= 1); + break; + case TREES_INTEGER_TYPE: + case TREES_BYTE_TYPE: + result = Types_IsInteger(sourceType); + break; + case ARRAY: + if (Types_IsString(sourceType)) { + result = Types_IsCharacterArray(targetType) + && (Types_IsOpenArray(targetType) + || (Types_StringLength(sourceType) < Trees_Integer(Types_ArrayLength(targetType)))); + } else if (Types_IsOpenArray(sourceType)) { + result = ! Types_IsOpenArray(targetType) + && TypesEqual(Types_ElementType(sourceType), Types_ElementType(targetType)); + } + break; + case RECORD: + result = Types_IsRecord(sourceType) && Types_Extends(targetType, sourceType); + break; + case POINTER: + result = (Trees_Symbol(sourceExp) == NIL) + || (Types_IsPointer(sourceType) && Types_Extends(targetType, sourceType)); + break; + case PROCEDURE: + result = (Trees_Symbol(sourceExp) == NIL) + || ((Trees_Symbol(sourceExp) == TREES_DESIGNATOR) + && (Trees_Kind(Trees_Left(sourceExp)) == TREES_PROCEDURE_KIND) + && ! Types_IsPredeclaredProcedure(sourceType) + && FormalParametersMatch(sourceType, targetType)); + break; + } + } + return result; +} + + +int Types_ArrayCompatible(Trees_Node actualType, Trees_Node formalType) +{ + return Types_Same(formalType, actualType) + || (Types_IsOpenArray(formalType) && Types_IsArray(actualType) + && Types_ArrayCompatible(Types_ElementType(actualType), Types_ElementType(formalType))) + || (Types_IsCharacterArray(formalType) && Types_IsString(actualType)); +} + + +int Types_ExpressionCompatible(int operator, Trees_Node firstType, Trees_Node secondType) +{ + int firstTypeSym, result; + + firstTypeSym = Trees_Symbol(Types_Structure(firstType)); + result = 0; + switch (operator) { + case '+': + case '-': + switch (firstTypeSym) { + case TREES_INTEGER_TYPE: + case TREES_BYTE_TYPE: + result = (secondType == NULL) || Types_IsInteger(secondType); + break; + case TREES_REAL_TYPE: + case TREES_SET_TYPE: + result = (secondType == NULL) || Types_Same(firstType, secondType); + break; + } + break; + case '*': + switch (firstTypeSym) { + case TREES_INTEGER_TYPE: + case TREES_BYTE_TYPE: + result = Types_IsInteger(secondType); + break; + case TREES_REAL_TYPE: + case TREES_SET_TYPE: + result = Types_Same(firstType, secondType); + break; + } + break; + case '/': + switch (firstTypeSym) { + case TREES_REAL_TYPE: + case TREES_SET_TYPE: + result = Types_Same(firstType, secondType); + break; + } + break; + case DIV: + case MOD: + result = Types_IsInteger(firstType) && Types_IsInteger(secondType); + break; + case OR: + case '&': + result = (firstTypeSym == TREES_BOOLEAN_TYPE) && Types_Same(firstType, secondType); + break; + case '~': + result = firstTypeSym == TREES_BOOLEAN_TYPE; + break; + case '=': + case '#': + switch (firstTypeSym) { + case TREES_BOOLEAN_TYPE: + case TREES_REAL_TYPE: + case TREES_SET_TYPE: + result = Types_Same(firstType, secondType); + break; + case TREES_INTEGER_TYPE: + case TREES_BYTE_TYPE: + result = Types_IsInteger(secondType); + break; + case TREES_CHAR_TYPE: + result = Types_IsChar(secondType) + || (Types_IsString(secondType) && (Types_StringLength(secondType) <= 1)); + break; + case ARRAY: + result = Types_IsCharacterArray(firstType) + && (Types_IsCharacterArray(secondType) || Types_IsString(secondType)); + break; + case TREES_STRING_TYPE: + result = Types_IsCharacterArray(secondType) || Types_IsString(secondType) + || (Types_IsChar(secondType) && (Types_StringLength(firstType) <= 1)); + break; + case POINTER: + result = (Trees_Symbol(secondType) == TREES_NIL_TYPE) + || (Types_IsPointer(secondType) + && (Types_Extends(firstType, secondType) || Types_Extends(secondType, firstType))); + break; + case PROCEDURE: + result = (Trees_Symbol(secondType) == TREES_NIL_TYPE) + || Types_Same(firstType, secondType); + break; + case TREES_NIL_TYPE: + result = Types_IsPointer(secondType) || Types_IsProcedure(secondType); + break; + } + break; + case '<': + case LE: + case '>': + case GE: + switch (firstTypeSym) { + case TREES_INTEGER_TYPE: + case TREES_BYTE_TYPE: + result = Types_IsInteger(secondType); + break; + case TREES_CHAR_TYPE: + result = Types_IsChar(secondType) + || (Types_IsString(secondType) && (Types_StringLength(secondType) <= 1)); + break; + case TREES_REAL_TYPE: + result = Types_Same(firstType, secondType); + break; + case ARRAY: + result = Types_IsCharacterArray(firstType) + && (Types_IsCharacterArray(secondType) || Types_IsString(secondType)); + break; + case TREES_STRING_TYPE: + result = Types_IsCharacterArray(secondType) || Types_IsString(secondType) + || (Types_IsChar(secondType) && (Types_StringLength(firstType) <= 1)); + break; + } + break; + case IN: + result = Types_IsInteger(firstType) && Types_IsSet(secondType); + break; + case IS: + result = (Types_IsRecord(firstType) || Types_IsPointer(firstType)) + && (Types_IsRecord(secondType) || Types_IsPointer(secondType)) + && Types_Extends(firstType, secondType); + break; + } + return result; +} + + +static int FormalParametersMatch(Trees_Node procTypeA, Trees_Node procTypeB) +{ + Trees_Node resultTypeA, resultTypeB, paramListA, paramListB, paramA, paramB; + int match; + + assert(Types_IsProcedure(procTypeA)); + assert(Types_IsProcedure(procTypeB)); + + resultTypeA = Types_ResultType(procTypeA); + resultTypeB = Types_ResultType(procTypeB); + + match = 0; + if (((resultTypeA == NULL) && (resultTypeB == NULL)) + || ((resultTypeA != NULL) && (resultTypeB != NULL) + && Types_Same(resultTypeA, resultTypeB))) { + match = 1; + paramListA = Types_Parameters(procTypeA); + paramListB = Types_Parameters(procTypeB); + while (match && (paramListA != NULL) && (paramListB != NULL)) { + paramA = Trees_Left(paramListA); + paramB = Trees_Left(paramListB); + match = match && TypesEqual(Trees_Type(paramA), Trees_Type(paramB)) + && (Trees_Kind(paramA) == Trees_Kind(paramB)); + paramListA = Trees_Right(paramListA); + paramListB = Trees_Right(paramListB); + } + match = match && (paramListA == NULL) && (paramListB == NULL); + } + return match; +} diff --git a/src/Types.h b/src/Types.h new file mode 100644 index 0000000..63afb78 --- /dev/null +++ b/src/Types.h @@ -0,0 +1,124 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef TYPES_H +#define TYPES_H + +#include "Trees.h" +#include "../lib/obnc/OBNC.h" + +int Types_IsType(Trees_Node node); + +int Types_IsBoolean(Trees_Node type); + +int Types_IsChar(Trees_Node type); + +int Types_IsInteger(Trees_Node type); + +int Types_IsReal(Trees_Node type); + +int Types_IsByte(Trees_Node type); + +int Types_IsSet(Trees_Node type); + +int Types_IsString(Trees_Node type); + +OBNC_INTEGER Types_StringLength(Trees_Node stringType); + +int Types_IsSingleCharString(Trees_Node type); + +int Types_Basic(Trees_Node type); + +int Types_Scalar(Trees_Node type); + +Trees_Node Types_Structure(Trees_Node type); + +Trees_Node Types_UnaliasedIdent(Trees_Node type); + +/*arrays*/ + +Trees_Node Types_NewArray(Trees_Node length, Trees_Node elemType); + +int Types_IsArray(Trees_Node type); + +int Types_IsOpenArray(Trees_Node type); + +int Types_IsCharacterArray(Trees_Node type); + +Trees_Node Types_ArrayLength(Trees_Node arrayType); + +Trees_Node Types_ElementType(Trees_Node arrayType); + +void Types_SetElementType(Trees_Node elemType, Trees_Node arrayType); + +/*records*/ + +Trees_Node Types_NewRecord(Trees_Node recBaseType, Trees_Node fields); + +int Types_IsRecord(Trees_Node type); + +Trees_Node Types_RecordBaseType(Trees_Node type); + +void Types_SetRecordBaseType(Trees_Node recBaseType, Trees_Node recordType); + +Trees_Node Types_Fields(Trees_Node record); + +Trees_Node Types_Descriptor(Trees_Node recordOrPointerType); + +int Types_Extensible(Trees_Node type); + +int Types_Extends(Trees_Node baseType, Trees_Node extendedType); + +int Types_ExtensionLevel(Trees_Node type); + +void Types_GetFieldIdent(const char fieldName[], Trees_Node type, int varImported, Trees_Node *ident, Trees_Node *baseType); + +/*pointers*/ + +Trees_Node Types_NewPointer(Trees_Node ptrBaseType); + +int Types_IsPointer(Trees_Node type); + +Trees_Node Types_PointerBaseType(Trees_Node ptrType); + +void Types_SetPointerBaseType(Trees_Node ptrBaseType, Trees_Node ptrType); + +/*procedures*/ + +Trees_Node Types_NewProcedure(Trees_Node fields, Trees_Node resultType); + +int Types_IsProcedure(Trees_Node type); + +int Types_IsPredeclaredProcedure(Trees_Node type); + +Trees_Node Types_Parameters(Trees_Node procType); + +Trees_Node Types_ResultType(Trees_Node procType); + +void Types_SetResultType(Trees_Node resultType, Trees_Node procType); + +/*type compatibility*/ + +int Types_Same(Trees_Node typeA, Trees_Node typeB); + +int Types_AssignmentCompatible(Trees_Node sourceExp, Trees_Node targetType); + +int Types_ArrayCompatible(Trees_Node actualType, Trees_Node formalType); + +int Types_ExpressionCompatible(int operator, Trees_Node typeA, Trees_Node typeB); + +#endif diff --git a/src/Util.c b/src/Util.c new file mode 100644 index 0000000..4c54bf1 --- /dev/null +++ b/src/Util.c @@ -0,0 +1,128 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Util.h" +#include +#include +#include +#include +#include + +int Util_initialized = 0; + +void Util_Init(void) +{ + if (! Util_initialized) { + Util_initialized = 1; + GC_INIT(); + } +} + + +char *Util_String(const char format[], ...) +{ + va_list args; + int resultLen, i; + const char *strArg; + char *result; + + assert(Util_initialized); + + resultLen = strlen(format) + 1; + va_start(args, format); + i = 0; + while (format[i] != '\0') { + if (format[i] == '%') { + switch (format[i + 1]) { + case 's': + strArg = va_arg(args, char *); + if (strArg != NULL) { + resultLen += strlen(strArg); + } + break; + case 'l': + if (format[i + 2] == 'd') { + resultLen += CHAR_BIT * sizeof (long int) / 3 + 3; + i++; + } else { + fprintf(stderr, "error: non-supported format specifier: %c\n", format[i + 1]); + exit(EXIT_FAILURE); + } + break; + case 'd': + resultLen += CHAR_BIT * sizeof (int) / 3 + 3; + break; + case '%': + break; + default: + fprintf(stderr, "error: non-supported format specifier: %c\n", format[i + 1]); + exit(EXIT_FAILURE); + } + } + i++; + } + va_end(args); + + result = GC_MALLOC_ATOMIC(resultLen); + if (result != NULL) { + va_start(args, format); + vsprintf(result, format, args); + va_end(args); + } else { + fprintf(stderr, "memory exausted\n"); + exit(EXIT_FAILURE); + } + return result; +} + + +const char *Util_Replace(const char old[], const char new[], const char s[]) +{ + char *t; + int newLength, count, i, j, tLen; + const char *p, *result; + + assert(Util_initialized); + + result = s; + count = 0; + p = strstr(s, old); + if (p != NULL) { + do { + count++; + p = strstr(p + 1, old); + } while (p != NULL); + newLength = strlen(new); + tLen = strlen(s) + count * newLength + 1; + NEW_ARRAY(t, tLen); + i = 0; + j = 0; + while (s[i] != '\0') { + if (strstr(s + i, old) == s + i) { + strcpy(t + j, new); + j += newLength; + } else { + t[j] = s[i]; + j++; + } + i++; + } + t[j] = '\0'; + result = t; + } + return result; +} diff --git a/src/Util.env b/src/Util.env new file mode 100644 index 0000000..6f6deba --- /dev/null +++ b/src/Util.env @@ -0,0 +1 @@ +LDLIBS=-lgc diff --git a/src/Util.h b/src/Util.h new file mode 100644 index 0000000..fb0af6c --- /dev/null +++ b/src/Util.h @@ -0,0 +1,59 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#ifndef UTIL_H +#define UTIL_H + +#include +#include +#include +#include + +#define LEN(arr) ((int) (sizeof (arr) / sizeof (arr)[0])) + +#define NEW_ARRAY(ptr, n) \ + { \ + assert(Util_initialized); \ + (ptr) = GC_MALLOC((size_t) (n) * sizeof (ptr)[0]); \ + if ((ptr) == NULL) { \ + fputs("error: Memory exhausted\n", stderr); \ + exit(EXIT_FAILURE); \ + } \ + } + +#define RENEW_ARRAY(ptr, n) \ + { \ + assert(Util_initialized); \ + (ptr) = GC_REALLOC((ptr), (size_t) (n) * sizeof (ptr)[0]); \ + if ((ptr) == NULL) { \ + fputs("error: Memory exhausted\n", stderr); \ + exit(EXIT_FAILURE); \ + } \ + } + +#define NEW(ptr) NEW_ARRAY((ptr), 1) + +extern int Util_initialized; /*don't use*/ + +void Util_Init(void); + +char *Util_String(const char format[], ...) + __attribute__ ((format (printf, 1, 2))); + +const char *Util_Replace(const char old[], const char new[], const char s[]); + +#endif diff --git a/src/UtilTest.c b/src/UtilTest.c new file mode 100644 index 0000000..74bc5e5 --- /dev/null +++ b/src/UtilTest.c @@ -0,0 +1,37 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Util.h" +#include +#include + +static void TestNewArray(void) +{ + int *a; + + NEW_ARRAY(a, 10); + a[9] = 37; + assert(a[9] == 37); +} + + +int main(void) +{ + Util_Init(); + TestNewArray(); + return 0; +} diff --git a/src/lex.yy.c b/src/lex.yy.c new file mode 100644 index 0000000..a4c9c5e --- /dev/null +++ b/src/lex.yy.c @@ -0,0 +1,2027 @@ + +#line 3 "lex.yy.c" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 6 +#define YY_FLEX_SUBMINOR_VERSION 4 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include +#include +#include +#include + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have . Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#ifndef SIZE_MAX +#define SIZE_MAX (~(size_t)0) +#endif + +#endif /* ! C99 */ + +#endif /* ! FLEXINT_H */ + +/* begin standard C++ headers. */ + +/* TODO: this is always defined, so inline it */ +#define yyconst const + +#if defined(__GNUC__) && __GNUC__ >= 3 +#define yynoreturn __attribute__((__noreturn__)) +#else +#define yynoreturn +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an + * integer in range [0..255] for use as an array index. + */ +#define YY_SC_TO_UI(c) ((YY_CHAR) (c)) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN (yy_start) = 1 + 2 * +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START (((yy_start) - 1) / 2) +#define YYSTATE YY_START +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart( yyin ) +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#ifdef __ia64__ +/* On IA-64, the buffer size is 16k, not 8k. + * Moreover, YY_BUF_SIZE is 2*YY_READ_BUF_SIZE in the general case. + * Ditto for the __ia64__ case accordingly. + */ +#define YY_BUF_SIZE 32768 +#else +#define YY_BUF_SIZE 16384 +#endif /* __ia64__ */ +#endif + +/* The state buf must be large enough to hold one state per character in the main buffer. + */ +#define YY_STATE_BUF_SIZE ((YY_BUF_SIZE + 2) * sizeof(yy_state_type)) + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +extern int yyleng; + +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + + #define YY_LESS_LINENO(n) + #define YY_LINENO_REWIND_TO(ptr) + +/* Return all but the first "n" matched characters back to the input stream. */ +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + *yy_cp = (yy_hold_char); \ + YY_RESTORE_YY_MORE_OFFSET \ + (yy_c_buf_p) = yy_cp = yy_bp + yyless_macro_arg - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) +#define unput(c) yyunput( c, (yytext_ptr) ) + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + int yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +/* Stack of input buffers. */ +static size_t yy_buffer_stack_top = 0; /**< index of top of stack. */ +static size_t yy_buffer_stack_max = 0; /**< capacity of stack. */ +static YY_BUFFER_STATE * yy_buffer_stack = NULL; /**< Stack as an array. */ + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + * + * Returns the top of the stack, or NULL. + */ +#define YY_CURRENT_BUFFER ( (yy_buffer_stack) \ + ? (yy_buffer_stack)[(yy_buffer_stack_top)] \ + : NULL) +/* Same as previous macro, but useful when we know that the buffer stack is not + * NULL or when we need an lvalue. For internal use only. + */ +#define YY_CURRENT_BUFFER_LVALUE (yy_buffer_stack)[(yy_buffer_stack_top)] + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; +static int yy_n_chars; /* number of characters read into yy_ch_buf */ +int yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = NULL; +static int yy_init = 0; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart ( FILE *input_file ); +void yy_switch_to_buffer ( YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE yy_create_buffer ( FILE *file, int size ); +void yy_delete_buffer ( YY_BUFFER_STATE b ); +void yy_flush_buffer ( YY_BUFFER_STATE b ); +void yypush_buffer_state ( YY_BUFFER_STATE new_buffer ); +void yypop_buffer_state ( void ); + +static void yyensure_buffer_stack ( void ); +static void yy_load_buffer_state ( void ); +static void yy_init_buffer ( YY_BUFFER_STATE b, FILE *file ); +#define YY_FLUSH_BUFFER yy_flush_buffer( YY_CURRENT_BUFFER ) + +YY_BUFFER_STATE yy_scan_buffer ( char *base, yy_size_t size ); +YY_BUFFER_STATE yy_scan_string ( const char *yy_str ); +YY_BUFFER_STATE yy_scan_bytes ( const char *bytes, int len ); + +void *yyalloc ( yy_size_t ); +void *yyrealloc ( void *, yy_size_t ); +void yyfree ( void * ); + +#define yy_new_buffer yy_create_buffer +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! YY_CURRENT_BUFFER ){ \ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer( yyin, YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_is_interactive = is_interactive; \ + } +#define yy_set_bol(at_bol) \ + { \ + if ( ! YY_CURRENT_BUFFER ){\ + yyensure_buffer_stack (); \ + YY_CURRENT_BUFFER_LVALUE = \ + yy_create_buffer( yyin, YY_BUF_SIZE ); \ + } \ + YY_CURRENT_BUFFER_LVALUE->yy_at_bol = at_bol; \ + } +#define YY_AT_BOL() (YY_CURRENT_BUFFER_LVALUE->yy_at_bol) + +/* Begin user sect3 */ +typedef flex_uint8_t YY_CHAR; + +FILE *yyin = NULL, *yyout = NULL; + +typedef int yy_state_type; + +extern int yylineno; +int yylineno = 1; + +extern char *yytext; +#ifdef yytext_ptr +#undef yytext_ptr +#endif +#define yytext_ptr yytext + +static yy_state_type yy_get_previous_state ( void ); +static yy_state_type yy_try_NUL_trans ( yy_state_type current_state ); +static int yy_get_next_buffer ( void ); +static void yynoreturn yy_fatal_error ( const char* msg ); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + (yytext_ptr) = yy_bp; \ + yyleng = (int) (yy_cp - yy_bp); \ + (yy_hold_char) = *yy_cp; \ + *yy_cp = '\0'; \ + (yy_c_buf_p) = yy_cp; +#define YY_NUM_RULES 15 +#define YY_END_OF_BUFFER 16 +/* This struct is not used in this scanner, + but its presence is necessary. */ +struct yy_trans_info + { + flex_int32_t yy_verify; + flex_int32_t yy_nxt; + }; +static const flex_int16_t yy_acclist[53] = + { 0, + 16, 14, 15, 1, 14, 15, 2, 15, 14, 15, + 7, 14, 15, 7, 14, 15, 7, 14, 15, 8201, + 14, 15,16393, 7, 14, 15, 7, 14, 15, 7, + 14, 15, 8, 14, 15, 1, 11, 13, 4, 10, + 8201,16393, 8201,16393, 12, 3, 5, 6, 8, 8201, + 10, 10 + } ; + +static const flex_int16_t yy_accept[39] = + { 0, + 1, 1, 1, 2, 4, 7, 9, 11, 14, 17, + 20, 24, 27, 30, 33, 36, 37, 37, 38, 39, + 40, 41, 43, 43, 45, 46, 47, 48, 49, 50, + 50, 51, 52, 52, 52, 52, 53, 53 + } ; + +static const YY_CHAR yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 1, 4, 5, 1, 1, 5, 1, 6, + 5, 7, 8, 5, 8, 9, 5, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 11, 5, 12, + 13, 14, 1, 1, 15, 15, 15, 15, 16, 15, + 17, 18, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 19, 17, 17, + 5, 1, 5, 5, 20, 1, 17, 17, 17, 17, + + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 5, 5, 5, 5, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static const YY_CHAR yy_meta[21] = + { 0, + 1, 1, 2, 1, 1, 1, 1, 1, 1, 3, + 1, 1, 1, 1, 3, 3, 3, 3, 3, 3 + } ; + +static const flex_int16_t yy_base[40] = + { 0, + 0, 0, 55, 56, 52, 56, 49, 56, 45, 42, + 12, 37, 36, 35, 27, 44, 41, 56, 56, 56, + 16, 0, 14, 35, 56, 56, 56, 56, 23, 22, + 56, 19, 26, 32, 30, 28, 56, 36, 30 + } ; + +static const flex_int16_t yy_def[40] = + { 0, + 37, 1, 37, 37, 37, 37, 38, 37, 37, 37, + 37, 37, 37, 37, 39, 37, 38, 37, 37, 37, + 37, 11, 11, 37, 37, 37, 37, 37, 39, 39, + 37, 37, 37, 37, 37, 37, 0, 37, 37 + } ; + +static const flex_int16_t yy_nxt[77] = + { 0, + 4, 5, 6, 7, 8, 9, 8, 8, 10, 11, + 12, 13, 8, 14, 15, 15, 15, 15, 15, 4, + 21, 22, 37, 23, 31, 32, 23, 23, 32, 24, + 25, 33, 29, 35, 33, 36, 17, 36, 17, 36, + 31, 37, 30, 34, 18, 16, 30, 28, 27, 26, + 20, 19, 18, 16, 37, 3, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37 + } ; + +static const flex_int16_t yy_chk[77] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 11, 11, 23, 23, 21, 21, 11, 11, 32, 11, + 11, 21, 39, 33, 32, 33, 38, 36, 38, 35, + 34, 30, 29, 24, 17, 16, 15, 14, 13, 12, + 10, 9, 7, 5, 3, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37 + } ; + +extern int yy_flex_debug; +int yy_flex_debug = 0; + +static yy_state_type *yy_state_buf=0, *yy_state_ptr=0; +static char *yy_full_match; +static int yy_lp; +static int yy_looking_for_trail_begin = 0; +static int yy_full_lp; +static int *yy_full_state; +#define YY_TRAILING_MASK 0x2000 +#define YY_TRAILING_HEAD_MASK 0x4000 +#define REJECT \ +{ \ +*yy_cp = (yy_hold_char); /* undo effects of setting up yytext */ \ +yy_cp = (yy_full_match); /* restore poss. backed-over text */ \ +(yy_lp) = (yy_full_lp); /* restore orig. accepting pos. */ \ +(yy_state_ptr) = (yy_full_state); /* restore orig. state */ \ +yy_current_state = *(yy_state_ptr); /* restore curr. state */ \ +++(yy_lp); \ +goto find_rule; \ +} + +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *yytext; +#line 1 "Oberon.l" +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ +#line 21 "Oberon.l" +#include "Oberon.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" +#include "Trees.h" /*needed by YYSTYPE in y.tab.h*/ +#include "y.tab.h" +#include +#include +#include +#include +#include +#include +#include +#include + +static int KeywordToken(const char word[]); + +#line 520 "lex.yy.c" +#line 521 "lex.yy.c" + +#define INITIAL 0 + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +static int yy_init_globals ( void ); + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int yylex_destroy ( void ); + +int yyget_debug ( void ); + +void yyset_debug ( int debug_flag ); + +YY_EXTRA_TYPE yyget_extra ( void ); + +void yyset_extra ( YY_EXTRA_TYPE user_defined ); + +FILE *yyget_in ( void ); + +void yyset_in ( FILE * _in_str ); + +FILE *yyget_out ( void ); + +void yyset_out ( FILE * _out_str ); + + int yyget_leng ( void ); + +char *yyget_text ( void ); + +int yyget_lineno ( void ); + +void yyset_lineno ( int _line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap ( void ); +#else +extern int yywrap ( void ); +#endif +#endif + +#ifndef YY_NO_UNPUT + + static void yyunput ( int c, char *buf_ptr ); + +#endif + +#ifndef yytext_ptr +static void yy_flex_strncpy ( char *, const char *, int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen ( const char * ); +#endif + +#ifndef YY_NO_INPUT +#ifdef __cplusplus +static int yyinput ( void ); +#else +static int input ( void ); +#endif + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#ifdef __ia64__ +/* On IA-64, the buffer size is 16k, not 8k */ +#define YY_READ_BUF_SIZE 16384 +#else +#define YY_READ_BUF_SIZE 8192 +#endif /* __ia64__ */ +#endif + +/* Copy whatever the last rule matched to the standard output. */ +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO do { if (fwrite( yytext, (size_t) yyleng, 1, yyout )) {} } while (0) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( YY_CURRENT_BUFFER_LVALUE->yy_is_interactive ) \ + { \ + int c = '*'; \ + int n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else \ + { \ + errno=0; \ + while ( (result = (int) fread(buf, 1, (yy_size_t) max_size, yyin)) == 0 && ferror(yyin)) \ + { \ + if( errno != EINTR) \ + { \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + break; \ + } \ + errno=0; \ + clearerr(yyin); \ + } \ + }\ +\ + +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* end tables serialization structures and prototypes */ + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int yylex (void); + +#define YY_DECL int yylex (void) +#endif /* !YY_DECL */ + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK /*LINTED*/break; +#endif + +#define YY_RULE_SETUP \ + YY_USER_ACTION + +/** The main scanner function which does all the work. + */ +YY_DECL +{ + yy_state_type yy_current_state; + char *yy_cp, *yy_bp; + int yy_act; + + if ( !(yy_init) ) + { + (yy_init) = 1; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + /* Create the reject buffer large enough to save one state per allowed character. */ + if ( ! (yy_state_buf) ) + (yy_state_buf) = (yy_state_type *)yyalloc(YY_STATE_BUF_SIZE ); + if ( ! (yy_state_buf) ) + YY_FATAL_ERROR( "out of dynamic memory in yylex()" ); + + if ( ! (yy_start) ) + (yy_start) = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! YY_CURRENT_BUFFER ) { + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer( yyin, YY_BUF_SIZE ); + } + + yy_load_buffer_state( ); + } + + { +#line 49 "Oberon.l" + + +#line 747 "lex.yy.c" + + while ( /*CONSTCOND*/1 ) /* loops until end-of-file is reached */ + { + yy_cp = (yy_c_buf_p); + + /* Support of yytext. */ + *yy_cp = (yy_hold_char); + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = (yy_start); + + (yy_state_ptr) = (yy_state_buf); + *(yy_state_ptr)++ = yy_current_state; + +yy_match: + do + { + YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)] ; + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 38 ) + yy_c = yy_meta[yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + yy_c]; + *(yy_state_ptr)++ = yy_current_state; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 56 ); + +yy_find_action: + yy_current_state = *--(yy_state_ptr); + (yy_lp) = yy_accept[yy_current_state]; +find_rule: /* we branch to this label when backing up */ + for ( ; ; ) /* until we find what rule we matched */ + { + if ( (yy_lp) && (yy_lp) < yy_accept[yy_current_state + 1] ) + { + yy_act = yy_acclist[(yy_lp)]; + if ( yy_act & YY_TRAILING_HEAD_MASK || + (yy_looking_for_trail_begin) ) + { + if ( yy_act == (yy_looking_for_trail_begin) ) + { + (yy_looking_for_trail_begin) = 0; + yy_act &= ~YY_TRAILING_HEAD_MASK; + break; + } + } + else if ( yy_act & YY_TRAILING_MASK ) + { + (yy_looking_for_trail_begin) = yy_act & ~YY_TRAILING_MASK; + (yy_looking_for_trail_begin) |= YY_TRAILING_HEAD_MASK; + } + else + { + (yy_full_match) = yy_cp; + (yy_full_state) = (yy_state_ptr); + (yy_full_lp) = (yy_lp); + break; + } + ++(yy_lp); + goto find_rule; + } + --yy_cp; + yy_current_state = *--(yy_state_ptr); + (yy_lp) = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + +do_action: /* This label is used only to access EOF actions. */ + + switch ( yy_act ) + { /* beginning of action switch */ +case 1: +YY_RULE_SETUP +#line 51 "Oberon.l" + + YY_BREAK +case 2: +/* rule 2 can match eol */ +YY_RULE_SETUP +#line 53 "Oberon.l" +{ + yylineno++; +} + YY_BREAK +case 3: +YY_RULE_SETUP +#line 57 "Oberon.l" +return BECOMES; + YY_BREAK +case 4: +YY_RULE_SETUP +#line 59 "Oberon.l" +return DOTDOT; + YY_BREAK +case 5: +YY_RULE_SETUP +#line 61 "Oberon.l" +return LE; + YY_BREAK +case 6: +YY_RULE_SETUP +#line 63 "Oberon.l" +return GE; + YY_BREAK +case 7: +YY_RULE_SETUP +#line 65 "Oberon.l" +return yytext[0]; + YY_BREAK +case 8: +YY_RULE_SETUP +#line 67 "Oberon.l" +{ + int token; + char *lexeme; + + token = KeywordToken(yytext); + if (token < 0) { + token = IDENT; + NEW_ARRAY(lexeme, yyleng + 1); + strcpy(lexeme, yytext); + yylval.ident = lexeme; + } + return token; +} + YY_BREAK +case 9: +YY_RULE_SETUP +#line 81 "Oberon.l" +{ + int base; + unsigned long int max, lexeme; + + base = (yytext[yyleng - 1] == 'H')? 16: 10; + max = (yytext[yyleng - 1] == 'H')? OBNC_UINT_MAX: OBNC_INT_MAX; + errno = 0; + lexeme = strtoul(yytext, NULL, base); + if ((errno != 0) || (lexeme > max)) { + if (base == 10) { + Oberon_PrintError("warning: %s: %s > %lu", strerror(ERANGE), yytext, max); + } else { + Oberon_PrintError("warning: %s: %s > 0%lXH", strerror(ERANGE), yytext, max); + } + } + yylval.integer = (OBNC_INTEGER) lexeme; + return INTEGER; +} + YY_BREAK +case 10: +YY_RULE_SETUP +#line 100 "Oberon.l" +{ + int n = sscanf(yytext, "%" OBNC_REAL_MOD_R "f", &yylval.real); + if (n != 1) { + Oberon_PrintError("warning: %s: %s > %" OBNC_REAL_MOD_W "G", strerror(ERANGE), yytext, OBNC_REAL_MAX); + } + return REAL; +} + YY_BREAK +case 11: +YY_RULE_SETUP +#line 108 "Oberon.l" +{ + int lexemeLen; + char *lexeme; + + lexemeLen = yyleng - 1; + NEW_ARRAY(lexeme, lexemeLen); + memcpy(lexeme, yytext + 1, (size_t) (lexemeLen - 1)); + lexeme[lexemeLen - 1] = '\0'; + yylval.string = lexeme; + return STRING; +} + YY_BREAK +case 12: +YY_RULE_SETUP +#line 120 "Oberon.l" +{ + long ordinalNumber; + char *lexeme; + + if (strcmp(yytext, "0X") == 0) { + ordinalNumber = 0; + } else { + errno = 0; + ordinalNumber = strtol(yytext, NULL, 16); + if ((errno != 0) || (ordinalNumber > UCHAR_MAX)) { + Oberon_PrintError("warning: %s: %s > 0%XX", strerror(ERANGE), yytext, UCHAR_MAX); + } + } + NEW_ARRAY(lexeme, 2); + lexeme[0] = (char) ordinalNumber; + lexeme[1] = '\0'; + yylval.string = lexeme; + return STRING; +} + YY_BREAK +case 13: +YY_RULE_SETUP +#line 140 "Oberon.l" +{ + int linenoStart, level, ch; + + linenoStart = yylineno; + level = 1; + do { + ch = input(); + switch (ch) { + case '(': + ch = input(); + if (ch == '*') { + level++; + } else { + unput(ch); + } + break; + case '*': + ch = input(); + if (ch == ')') { + level--; + } else { + unput(ch); + } + break; + case '\n': + yylineno++; + break; + } + } while ((level > 0) && (ch > 0)); + assert((ch >= 0) || (ch == EOF)); + + /*Note: In Flex 2.6.0 and earlier, input returns EOF (-1) instead of 0 when end-of-file is reached.*/ + + if (level > 0) { + Oberon_PrintError("error: unterminated comment starting at line %d", linenoStart); + exit(EXIT_FAILURE); + } +} + YY_BREAK +case 14: +YY_RULE_SETUP +#line 179 "Oberon.l" +{ + if (isprint(yytext[0])) { + Oberon_PrintError("error: unexpected character: %c", yytext[0]); + } else { + Oberon_PrintError("error: unexpected character: %02X (hex)", yytext[0]); + } + exit(EXIT_FAILURE); +} + YY_BREAK +case 15: +YY_RULE_SETUP +#line 188 "Oberon.l" +ECHO; + YY_BREAK +#line 1012 "lex.yy.c" + case YY_STATE_EOF(INITIAL): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - (yytext_ptr)) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = (yy_hold_char); + YY_RESTORE_YY_MORE_OFFSET + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between YY_CURRENT_BUFFER and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + YY_CURRENT_BUFFER_LVALUE->yy_input_file = yyin; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( (yy_c_buf_p) <= &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + (yy_c_buf_p) = (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++(yy_c_buf_p); + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = (yy_c_buf_p); + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_END_OF_FILE: + { + (yy_did_buffer_switch_on_eof) = 0; + + if ( yywrap( ) ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + (yy_c_buf_p) = (yytext_ptr) + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = + (yytext_ptr) + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + (yy_c_buf_p) = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)]; + + yy_current_state = yy_get_previous_state( ); + + yy_cp = (yy_c_buf_p); + yy_bp = (yytext_ptr) + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ + } /* end of user's declarations */ +} /* end of yylex */ + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ +static int yy_get_next_buffer (void) +{ + char *dest = YY_CURRENT_BUFFER_LVALUE->yy_ch_buf; + char *source = (yytext_ptr); + int number_to_move, i; + int ret_val; + + if ( (yy_c_buf_p) > &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( (yy_c_buf_p) - (yytext_ptr) - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) ((yy_c_buf_p) - (yytext_ptr) - 1); + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( YY_CURRENT_BUFFER_LVALUE->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars) = 0; + + else + { + int num_to_read = + YY_CURRENT_BUFFER_LVALUE->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ + + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); + + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]), + (yy_n_chars), num_to_read ); + + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + if ( (yy_n_chars) == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart( yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + YY_CURRENT_BUFFER_LVALUE->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + if (((yy_n_chars) + number_to_move) > YY_CURRENT_BUFFER_LVALUE->yy_buf_size) { + /* Extend the array by 50%, plus the number we really need. */ + int new_size = (yy_n_chars) + number_to_move + ((yy_n_chars) >> 1); + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf = (char *) yyrealloc( + (void *) YY_CURRENT_BUFFER_LVALUE->yy_ch_buf, (yy_size_t) new_size ); + if ( ! YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_get_next_buffer()" ); + /* "- 2" to take care of EOB's */ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size = (int) (new_size - 2); + } + + (yy_n_chars) += number_to_move; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] = YY_END_OF_BUFFER_CHAR; + YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars) + 1] = YY_END_OF_BUFFER_CHAR; + + (yytext_ptr) = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[0]; + + return ret_val; +} + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + + static yy_state_type yy_get_previous_state (void) +{ + yy_state_type yy_current_state; + char *yy_cp; + + yy_current_state = (yy_start); + + (yy_state_ptr) = (yy_state_buf); + *(yy_state_ptr)++ = yy_current_state; + + for ( yy_cp = (yytext_ptr) + YY_MORE_ADJ; yy_cp < (yy_c_buf_p); ++yy_cp ) + { + YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 38 ) + yy_c = yy_meta[yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + yy_c]; + *(yy_state_ptr)++ = yy_current_state; + } + + return yy_current_state; +} + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + static yy_state_type yy_try_NUL_trans (yy_state_type yy_current_state ) +{ + int yy_is_jam; + + YY_CHAR yy_c = 1; + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 38 ) + yy_c = yy_meta[yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + yy_c]; + yy_is_jam = (yy_current_state == 37); + if ( ! yy_is_jam ) + *(yy_state_ptr)++ = yy_current_state; + + return yy_is_jam ? 0 : yy_current_state; +} + +#ifndef YY_NO_UNPUT + + static void yyunput (int c, char * yy_bp ) +{ + char *yy_cp; + + yy_cp = (yy_c_buf_p); + + /* undo effects of setting up yytext */ + *yy_cp = (yy_hold_char); + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + int number_to_move = (yy_n_chars) + 2; + char *dest = &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[ + YY_CURRENT_BUFFER_LVALUE->yy_buf_size + 2]; + char *source = + &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[number_to_move]; + + while ( source > YY_CURRENT_BUFFER_LVALUE->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = + (yy_n_chars) = (int) YY_CURRENT_BUFFER_LVALUE->yy_buf_size; + + if ( yy_cp < YY_CURRENT_BUFFER_LVALUE->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + (yytext_ptr) = yy_bp; + (yy_hold_char) = *yy_cp; + (yy_c_buf_p) = yy_cp; +} + +#endif + +#ifndef YY_NO_INPUT +#ifdef __cplusplus + static int yyinput (void) +#else + static int input (void) +#endif + +{ + int c; + + *(yy_c_buf_p) = (yy_hold_char); + + if ( *(yy_c_buf_p) == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( (yy_c_buf_p) < &YY_CURRENT_BUFFER_LVALUE->yy_ch_buf[(yy_n_chars)] ) + /* This was really a NUL. */ + *(yy_c_buf_p) = '\0'; + + else + { /* need more input */ + int offset = (int) ((yy_c_buf_p) - (yytext_ptr)); + ++(yy_c_buf_p); + + switch ( yy_get_next_buffer( ) ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart( yyin ); + + /*FALLTHROUGH*/ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap( ) ) + return 0; + + if ( ! (yy_did_buffer_switch_on_eof) ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + (yy_c_buf_p) = (yytext_ptr) + offset; + break; + } + } + } + + c = *(unsigned char *) (yy_c_buf_p); /* cast for 8-bit char's */ + *(yy_c_buf_p) = '\0'; /* preserve yytext */ + (yy_hold_char) = *++(yy_c_buf_p); + + return c; +} +#endif /* ifndef YY_NO_INPUT */ + +/** Immediately switch to a different input stream. + * @param input_file A readable stream. + * + * @note This function does not reset the start condition to @c INITIAL . + */ + void yyrestart (FILE * input_file ) +{ + + if ( ! YY_CURRENT_BUFFER ){ + yyensure_buffer_stack (); + YY_CURRENT_BUFFER_LVALUE = + yy_create_buffer( yyin, YY_BUF_SIZE ); + } + + yy_init_buffer( YY_CURRENT_BUFFER, input_file ); + yy_load_buffer_state( ); +} + +/** Switch to a different input buffer. + * @param new_buffer The new input buffer. + * + */ + void yy_switch_to_buffer (YY_BUFFER_STATE new_buffer ) +{ + + /* TODO. We should be able to replace this entire function body + * with + * yypop_buffer_state(); + * yypush_buffer_state(new_buffer); + */ + yyensure_buffer_stack (); + if ( YY_CURRENT_BUFFER == new_buffer ) + return; + + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + YY_CURRENT_BUFFER_LVALUE = new_buffer; + yy_load_buffer_state( ); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + (yy_did_buffer_switch_on_eof) = 1; +} + +static void yy_load_buffer_state (void) +{ + (yy_n_chars) = YY_CURRENT_BUFFER_LVALUE->yy_n_chars; + (yytext_ptr) = (yy_c_buf_p) = YY_CURRENT_BUFFER_LVALUE->yy_buf_pos; + yyin = YY_CURRENT_BUFFER_LVALUE->yy_input_file; + (yy_hold_char) = *(yy_c_buf_p); +} + +/** Allocate and initialize an input buffer state. + * @param file A readable stream. + * @param size The character buffer size in bytes. When in doubt, use @c YY_BUF_SIZE. + * + * @return the allocated buffer state. + */ + YY_BUFFER_STATE yy_create_buffer (FILE * file, int size ) +{ + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yyalloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yyalloc( (yy_size_t) (b->yy_buf_size + 2) ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer( b, file ); + + return b; +} + +/** Destroy the buffer. + * @param b a buffer created with yy_create_buffer() + * + */ + void yy_delete_buffer (YY_BUFFER_STATE b ) +{ + + if ( ! b ) + return; + + if ( b == YY_CURRENT_BUFFER ) /* Not sure if we should pop here. */ + YY_CURRENT_BUFFER_LVALUE = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yyfree( (void *) b->yy_ch_buf ); + + yyfree( (void *) b ); +} + +/* Initializes or reinitializes a buffer. + * This function is sometimes called more than once on the same buffer, + * such as during a yyrestart() or at EOF. + */ + static void yy_init_buffer (YY_BUFFER_STATE b, FILE * file ) + +{ + int oerrno = errno; + + yy_flush_buffer( b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + + /* If b is the current buffer, then yy_init_buffer was _probably_ + * called from yyrestart() or through yy_get_next_buffer. + * In that case, we don't want to reset the lineno or column. + */ + if (b != YY_CURRENT_BUFFER){ + b->yy_bs_lineno = 1; + b->yy_bs_column = 0; + } + + b->yy_is_interactive = 1; + + errno = oerrno; +} + +/** Discard all buffered characters. On the next scan, YY_INPUT will be called. + * @param b the buffer state to be flushed, usually @c YY_CURRENT_BUFFER. + * + */ + void yy_flush_buffer (YY_BUFFER_STATE b ) +{ + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == YY_CURRENT_BUFFER ) + yy_load_buffer_state( ); +} + +/** Pushes the new state onto the stack. The new state becomes + * the current state. This function will allocate the stack + * if necessary. + * @param new_buffer The new state. + * + */ +void yypush_buffer_state (YY_BUFFER_STATE new_buffer ) +{ + if (new_buffer == NULL) + return; + + yyensure_buffer_stack(); + + /* This block is copied from yy_switch_to_buffer. */ + if ( YY_CURRENT_BUFFER ) + { + /* Flush out information for old buffer. */ + *(yy_c_buf_p) = (yy_hold_char); + YY_CURRENT_BUFFER_LVALUE->yy_buf_pos = (yy_c_buf_p); + YY_CURRENT_BUFFER_LVALUE->yy_n_chars = (yy_n_chars); + } + + /* Only push if top exists. Otherwise, replace top. */ + if (YY_CURRENT_BUFFER) + (yy_buffer_stack_top)++; + YY_CURRENT_BUFFER_LVALUE = new_buffer; + + /* copied from yy_switch_to_buffer. */ + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; +} + +/** Removes and deletes the top of the stack, if present. + * The next element becomes the new top. + * + */ +void yypop_buffer_state (void) +{ + if (!YY_CURRENT_BUFFER) + return; + + yy_delete_buffer(YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + if ((yy_buffer_stack_top) > 0) + --(yy_buffer_stack_top); + + if (YY_CURRENT_BUFFER) { + yy_load_buffer_state( ); + (yy_did_buffer_switch_on_eof) = 1; + } +} + +/* Allocates the stack if it does not exist. + * Guarantees space for at least one push. + */ +static void yyensure_buffer_stack (void) +{ + yy_size_t num_to_alloc; + + if (!(yy_buffer_stack)) { + + /* First allocation is just for 2 elements, since we don't know if this + * scanner will even need a stack. We use 2 instead of 1 to avoid an + * immediate realloc on the next call. + */ + num_to_alloc = 1; /* After all that talk, this was set to 1 anyways... */ + (yy_buffer_stack) = (struct yy_buffer_state**)yyalloc + (num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + memset((yy_buffer_stack), 0, num_to_alloc * sizeof(struct yy_buffer_state*)); + + (yy_buffer_stack_max) = num_to_alloc; + (yy_buffer_stack_top) = 0; + return; + } + + if ((yy_buffer_stack_top) >= ((yy_buffer_stack_max)) - 1){ + + /* Increase the buffer to prepare for a possible push. */ + yy_size_t grow_size = 8 /* arbitrary grow size */; + + num_to_alloc = (yy_buffer_stack_max) + grow_size; + (yy_buffer_stack) = (struct yy_buffer_state**)yyrealloc + ((yy_buffer_stack), + num_to_alloc * sizeof(struct yy_buffer_state*) + ); + if ( ! (yy_buffer_stack) ) + YY_FATAL_ERROR( "out of dynamic memory in yyensure_buffer_stack()" ); + + /* zero only the new slots.*/ + memset((yy_buffer_stack) + (yy_buffer_stack_max), 0, grow_size * sizeof(struct yy_buffer_state*)); + (yy_buffer_stack_max) = num_to_alloc; + } +} + +/** Setup the input buffer state to scan directly from a user-specified character buffer. + * @param base the character buffer + * @param size the size in bytes of the character buffer + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_buffer (char * base, yy_size_t size ) +{ + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return NULL; + + b = (YY_BUFFER_STATE) yyalloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = (int) (size - 2); /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = NULL; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer( b ); + + return b; +} + +/** Setup the input buffer state to scan a string. The next call to yylex() will + * scan from a @e copy of @a str. + * @param yystr a NUL-terminated string to scan + * + * @return the newly allocated buffer state object. + * @note If you want to scan bytes that may contain NUL values, then use + * yy_scan_bytes() instead. + */ +YY_BUFFER_STATE yy_scan_string (const char * yystr ) +{ + + return yy_scan_bytes( yystr, (int) strlen(yystr) ); +} + +/** Setup the input buffer state to scan the given bytes. The next call to yylex() will + * scan from a @e copy of @a bytes. + * @param yybytes the byte buffer to scan + * @param _yybytes_len the number of bytes in the buffer pointed to by @a bytes. + * + * @return the newly allocated buffer state object. + */ +YY_BUFFER_STATE yy_scan_bytes (const char * yybytes, int _yybytes_len ) +{ + YY_BUFFER_STATE b; + char *buf; + yy_size_t n; + int i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = (yy_size_t) (_yybytes_len + 2); + buf = (char *) yyalloc( n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < _yybytes_len; ++i ) + buf[i] = yybytes[i]; + + buf[_yybytes_len] = buf[_yybytes_len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer( buf, n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; +} + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +static void yynoreturn yy_fatal_error (const char* msg ) +{ + fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); +} + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + int yyless_macro_arg = (n); \ + YY_LESS_LINENO(yyless_macro_arg);\ + yytext[yyleng] = (yy_hold_char); \ + (yy_c_buf_p) = yytext + yyless_macro_arg; \ + (yy_hold_char) = *(yy_c_buf_p); \ + *(yy_c_buf_p) = '\0'; \ + yyleng = yyless_macro_arg; \ + } \ + while ( 0 ) + +/* Accessor methods (get/set functions) to struct members. */ + +/** Get the current line number. + * + */ +int yyget_lineno (void) +{ + + return yylineno; +} + +/** Get the input stream. + * + */ +FILE *yyget_in (void) +{ + return yyin; +} + +/** Get the output stream. + * + */ +FILE *yyget_out (void) +{ + return yyout; +} + +/** Get the length of the current token. + * + */ +int yyget_leng (void) +{ + return yyleng; +} + +/** Get the current token. + * + */ + +char *yyget_text (void) +{ + return yytext; +} + +/** Set the current line number. + * @param _line_number line number + * + */ +void yyset_lineno (int _line_number ) +{ + + yylineno = _line_number; +} + +/** Set the input stream. This does not discard the current + * input buffer. + * @param _in_str A readable stream. + * + * @see yy_switch_to_buffer + */ +void yyset_in (FILE * _in_str ) +{ + yyin = _in_str ; +} + +void yyset_out (FILE * _out_str ) +{ + yyout = _out_str ; +} + +int yyget_debug (void) +{ + return yy_flex_debug; +} + +void yyset_debug (int _bdebug ) +{ + yy_flex_debug = _bdebug ; +} + +static int yy_init_globals (void) +{ + /* Initialization is the same as for the non-reentrant scanner. + * This function is called from yylex_destroy(), so don't allocate here. + */ + + (yy_buffer_stack) = NULL; + (yy_buffer_stack_top) = 0; + (yy_buffer_stack_max) = 0; + (yy_c_buf_p) = NULL; + (yy_init) = 0; + (yy_start) = 0; + + (yy_state_buf) = 0; + (yy_state_ptr) = 0; + (yy_full_match) = 0; + (yy_lp) = 0; + +/* Defined in main.c */ +#ifdef YY_STDINIT + yyin = stdin; + yyout = stdout; +#else + yyin = NULL; + yyout = NULL; +#endif + + /* For future reference: Set errno on error, since we are called by + * yylex_init() + */ + return 0; +} + +/* yylex_destroy is for both reentrant and non-reentrant scanners. */ +int yylex_destroy (void) +{ + + /* Pop the buffer stack, destroying each element. */ + while(YY_CURRENT_BUFFER){ + yy_delete_buffer( YY_CURRENT_BUFFER ); + YY_CURRENT_BUFFER_LVALUE = NULL; + yypop_buffer_state(); + } + + /* Destroy the stack itself. */ + yyfree((yy_buffer_stack) ); + (yy_buffer_stack) = NULL; + + yyfree ( (yy_state_buf) ); + (yy_state_buf) = NULL; + + /* Reset the globals. This is important in a non-reentrant scanner so the next time + * yylex() is called, initialization will occur. */ + yy_init_globals( ); + + return 0; +} + +/* + * Internal utility routines. + */ + +#ifndef yytext_ptr +static void yy_flex_strncpy (char* s1, const char * s2, int n ) +{ + + int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; +} +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen (const char * s ) +{ + int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; +} +#endif + +void *yyalloc (yy_size_t size ) +{ + return malloc(size); +} + +void *yyrealloc (void * ptr, yy_size_t size ) +{ + + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return realloc(ptr, size); +} + +void yyfree (void * ptr ) +{ + free( (char *) ptr ); /* see yyrealloc() for (char *) cast */ +} + +#define YYTABLES_NAME "yytables" + +#line 188 "Oberon.l" + + +static int Cmp(const void *word, const void *keywordPtr) +{ + return strcmp((char *) word, * (char **) keywordPtr); +} + + +static int KeywordToken(const char word[]) +{ + static const char *keywords[] = {"ARRAY", "BEGIN", "BY", "CASE", "CONST", "DIV", "DO", "ELSE", "ELSIF", "END", "FALSE", "FOR", "IF", "IMPORT", "IN", "IS", "MOD", "MODULE", "NIL", "OF", "OR", "POINTER", "PROCEDURE", "RECORD", "REPEAT", "RETURN", "THEN", "TO", "TRUE", "TYPE", "UNTIL", "VAR", "WHILE"}; + + static const int keywordTokens[] = {ARRAY, BEGIN_, BY, CASE, CONST, DIV, DO, ELSE, ELSIF, END, FALSE, FOR, IF, IMPORT, IN, IS, MOD, MODULE, NIL, OF, OR, POINTER, PROCEDURE, RECORD, REPEAT, RETURN, THEN, TO, TRUE, TYPE, UNTIL, VAR, WHILE}; + + const char **keywordPtr; + ptrdiff_t pos; + int token; + + keywordPtr = bsearch(word, keywords, LEN(keywords), sizeof keywords[0], Cmp); + if (keywordPtr != NULL) { + pos = keywordPtr - keywords; + assert(pos >= 0); + assert(pos < LEN(keywordTokens)); + token = keywordTokens[pos]; + } else { + token = -1; + } + return token; +} + + +int yywrap(void) +{ + const int done = 1; + + return done; +} + diff --git a/src/lex.yy.h b/src/lex.yy.h new file mode 100644 index 0000000..1188833 --- /dev/null +++ b/src/lex.yy.h @@ -0,0 +1,472 @@ +#ifndef yyHEADER_H +#define yyHEADER_H 1 +#define yyIN_HEADER 1 + +#line 6 "lex.yy.h" + +#define YY_INT_ALIGNED short int + +/* A lexical scanner generated by flex */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 6 +#define YY_FLEX_SUBMINOR_VERSION 4 +#if YY_FLEX_SUBMINOR_VERSION > 0 +#define FLEX_BETA +#endif + +/* First, we deal with platform-specific or compiler-specific issues. */ + +/* begin standard C headers. */ +#include +#include +#include +#include + +/* end standard C headers. */ + +/* flex integer type definitions */ + +#ifndef FLEXINT_H +#define FLEXINT_H + +/* C99 systems have . Non-C99 systems may or may not. */ + +#if defined (__STDC_VERSION__) && __STDC_VERSION__ >= 199901L + +/* C99 says to define __STDC_LIMIT_MACROS before including stdint.h, + * if you want the limit (max/min) macros for int types. + */ +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS 1 +#endif + +#include +typedef int8_t flex_int8_t; +typedef uint8_t flex_uint8_t; +typedef int16_t flex_int16_t; +typedef uint16_t flex_uint16_t; +typedef int32_t flex_int32_t; +typedef uint32_t flex_uint32_t; +#else +typedef signed char flex_int8_t; +typedef short int flex_int16_t; +typedef int flex_int32_t; +typedef unsigned char flex_uint8_t; +typedef unsigned short int flex_uint16_t; +typedef unsigned int flex_uint32_t; + +/* Limits of integral types. */ +#ifndef INT8_MIN +#define INT8_MIN (-128) +#endif +#ifndef INT16_MIN +#define INT16_MIN (-32767-1) +#endif +#ifndef INT32_MIN +#define INT32_MIN (-2147483647-1) +#endif +#ifndef INT8_MAX +#define INT8_MAX (127) +#endif +#ifndef INT16_MAX +#define INT16_MAX (32767) +#endif +#ifndef INT32_MAX +#define INT32_MAX (2147483647) +#endif +#ifndef UINT8_MAX +#define UINT8_MAX (255U) +#endif +#ifndef UINT16_MAX +#define UINT16_MAX (65535U) +#endif +#ifndef UINT32_MAX +#define UINT32_MAX (4294967295U) +#endif + +#ifndef SIZE_MAX +#define SIZE_MAX (~(size_t)0) +#endif + +#endif /* ! C99 */ + +#endif /* ! FLEXINT_H */ + +/* begin standard C++ headers. */ + +/* TODO: this is always defined, so inline it */ +#define yyconst const + +#if defined(__GNUC__) && __GNUC__ >= 3 +#define yynoreturn __attribute__((__noreturn__)) +#else +#define yynoreturn +#endif + +/* Size of default input buffer. */ +#ifndef YY_BUF_SIZE +#ifdef __ia64__ +/* On IA-64, the buffer size is 16k, not 8k. + * Moreover, YY_BUF_SIZE is 2*YY_READ_BUF_SIZE in the general case. + * Ditto for the __ia64__ case accordingly. + */ +#define YY_BUF_SIZE 32768 +#else +#define YY_BUF_SIZE 16384 +#endif /* __ia64__ */ +#endif + +#ifndef YY_TYPEDEF_YY_BUFFER_STATE +#define YY_TYPEDEF_YY_BUFFER_STATE +typedef struct yy_buffer_state *YY_BUFFER_STATE; +#endif + +#ifndef YY_TYPEDEF_YY_SIZE_T +#define YY_TYPEDEF_YY_SIZE_T +typedef size_t yy_size_t; +#endif + +extern int yyleng; + +extern FILE *yyin, *yyout; + +#ifndef YY_STRUCT_YY_BUFFER_STATE +#define YY_STRUCT_YY_BUFFER_STATE +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + int yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + int yy_bs_lineno; /**< The line count. */ + int yy_bs_column; /**< The column count. */ + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; + + }; +#endif /* !YY_STRUCT_YY_BUFFER_STATE */ + +void yyrestart ( FILE *input_file ); +void yy_switch_to_buffer ( YY_BUFFER_STATE new_buffer ); +YY_BUFFER_STATE yy_create_buffer ( FILE *file, int size ); +void yy_delete_buffer ( YY_BUFFER_STATE b ); +void yy_flush_buffer ( YY_BUFFER_STATE b ); +void yypush_buffer_state ( YY_BUFFER_STATE new_buffer ); +void yypop_buffer_state ( void ); + +YY_BUFFER_STATE yy_scan_buffer ( char *base, yy_size_t size ); +YY_BUFFER_STATE yy_scan_string ( const char *yy_str ); +YY_BUFFER_STATE yy_scan_bytes ( const char *bytes, int len ); + +void *yyalloc ( yy_size_t ); +void *yyrealloc ( void *, yy_size_t ); +void yyfree ( void * ); + +/* Begin user sect3 */ + +extern int yylineno; + +extern char *yytext; +#ifdef yytext_ptr +#undef yytext_ptr +#endif +#define yytext_ptr yytext + +#ifdef YY_HEADER_EXPORT_START_CONDITIONS +#define INITIAL 0 + +#endif + +#ifndef YY_NO_UNISTD_H +/* Special case for "unistd.h", since it is non-ANSI. We include it way + * down here because we want the user's section 1 to have been scanned first. + * The user has a chance to override it with an option. + */ +#include +#endif + +#ifndef YY_EXTRA_TYPE +#define YY_EXTRA_TYPE void * +#endif + +/* Accessor methods to globals. + These are made visible to non-reentrant scanners for convenience. */ + +int yylex_destroy ( void ); + +int yyget_debug ( void ); + +void yyset_debug ( int debug_flag ); + +YY_EXTRA_TYPE yyget_extra ( void ); + +void yyset_extra ( YY_EXTRA_TYPE user_defined ); + +FILE *yyget_in ( void ); + +void yyset_in ( FILE * _in_str ); + +FILE *yyget_out ( void ); + +void yyset_out ( FILE * _out_str ); + + int yyget_leng ( void ); + +char *yyget_text ( void ); + +int yyget_lineno ( void ); + +void yyset_lineno ( int _line_number ); + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap ( void ); +#else +extern int yywrap ( void ); +#endif +#endif + +#ifndef yytext_ptr +static void yy_flex_strncpy ( char *, const char *, int ); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen ( const char * ); +#endif + +#ifndef YY_NO_INPUT + +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#ifdef __ia64__ +/* On IA-64, the buffer size is 16k, not 8k */ +#define YY_READ_BUF_SIZE 16384 +#else +#define YY_READ_BUF_SIZE 8192 +#endif /* __ia64__ */ +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL_IS_OURS 1 + +extern int yylex (void); + +#define YY_DECL int yylex (void) +#endif /* !YY_DECL */ + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + +#undef YY_NEW_FILE +#undef YY_FLUSH_BUFFER +#undef yy_set_bol +#undef yy_new_buffer +#undef yy_set_interactive +#undef YY_DO_BEFORE_ACTION + +#ifdef YY_DECL_IS_OURS +#undef YY_DECL_IS_OURS +#undef YY_DECL +#endif + +#ifndef yy_create_buffer_ALREADY_DEFINED +#undef yy_create_buffer +#endif +#ifndef yy_delete_buffer_ALREADY_DEFINED +#undef yy_delete_buffer +#endif +#ifndef yy_scan_buffer_ALREADY_DEFINED +#undef yy_scan_buffer +#endif +#ifndef yy_scan_string_ALREADY_DEFINED +#undef yy_scan_string +#endif +#ifndef yy_scan_bytes_ALREADY_DEFINED +#undef yy_scan_bytes +#endif +#ifndef yy_init_buffer_ALREADY_DEFINED +#undef yy_init_buffer +#endif +#ifndef yy_flush_buffer_ALREADY_DEFINED +#undef yy_flush_buffer +#endif +#ifndef yy_load_buffer_state_ALREADY_DEFINED +#undef yy_load_buffer_state +#endif +#ifndef yy_switch_to_buffer_ALREADY_DEFINED +#undef yy_switch_to_buffer +#endif +#ifndef yypush_buffer_state_ALREADY_DEFINED +#undef yypush_buffer_state +#endif +#ifndef yypop_buffer_state_ALREADY_DEFINED +#undef yypop_buffer_state +#endif +#ifndef yyensure_buffer_stack_ALREADY_DEFINED +#undef yyensure_buffer_stack +#endif +#ifndef yylex_ALREADY_DEFINED +#undef yylex +#endif +#ifndef yyrestart_ALREADY_DEFINED +#undef yyrestart +#endif +#ifndef yylex_init_ALREADY_DEFINED +#undef yylex_init +#endif +#ifndef yylex_init_extra_ALREADY_DEFINED +#undef yylex_init_extra +#endif +#ifndef yylex_destroy_ALREADY_DEFINED +#undef yylex_destroy +#endif +#ifndef yyget_debug_ALREADY_DEFINED +#undef yyget_debug +#endif +#ifndef yyset_debug_ALREADY_DEFINED +#undef yyset_debug +#endif +#ifndef yyget_extra_ALREADY_DEFINED +#undef yyget_extra +#endif +#ifndef yyset_extra_ALREADY_DEFINED +#undef yyset_extra +#endif +#ifndef yyget_in_ALREADY_DEFINED +#undef yyget_in +#endif +#ifndef yyset_in_ALREADY_DEFINED +#undef yyset_in +#endif +#ifndef yyget_out_ALREADY_DEFINED +#undef yyget_out +#endif +#ifndef yyset_out_ALREADY_DEFINED +#undef yyset_out +#endif +#ifndef yyget_leng_ALREADY_DEFINED +#undef yyget_leng +#endif +#ifndef yyget_text_ALREADY_DEFINED +#undef yyget_text +#endif +#ifndef yyget_lineno_ALREADY_DEFINED +#undef yyget_lineno +#endif +#ifndef yyset_lineno_ALREADY_DEFINED +#undef yyset_lineno +#endif +#ifndef yyget_column_ALREADY_DEFINED +#undef yyget_column +#endif +#ifndef yyset_column_ALREADY_DEFINED +#undef yyset_column +#endif +#ifndef yywrap_ALREADY_DEFINED +#undef yywrap +#endif +#ifndef yyget_lval_ALREADY_DEFINED +#undef yyget_lval +#endif +#ifndef yyset_lval_ALREADY_DEFINED +#undef yyset_lval +#endif +#ifndef yyget_lloc_ALREADY_DEFINED +#undef yyget_lloc +#endif +#ifndef yyset_lloc_ALREADY_DEFINED +#undef yyset_lloc +#endif +#ifndef yyalloc_ALREADY_DEFINED +#undef yyalloc +#endif +#ifndef yyrealloc_ALREADY_DEFINED +#undef yyrealloc +#endif +#ifndef yyfree_ALREADY_DEFINED +#undef yyfree +#endif +#ifndef yytext_ALREADY_DEFINED +#undef yytext +#endif +#ifndef yyleng_ALREADY_DEFINED +#undef yyleng +#endif +#ifndef yyin_ALREADY_DEFINED +#undef yyin +#endif +#ifndef yyout_ALREADY_DEFINED +#undef yyout +#endif +#ifndef yy_flex_debug_ALREADY_DEFINED +#undef yy_flex_debug +#endif +#ifndef yylineno_ALREADY_DEFINED +#undef yylineno +#endif +#ifndef yytables_fload_ALREADY_DEFINED +#undef yytables_fload +#endif +#ifndef yytables_destroy_ALREADY_DEFINED +#undef yytables_destroy +#endif +#ifndef yyTABLES_NAME_ALREADY_DEFINED +#undef yyTABLES_NAME +#endif + +#line 188 "Oberon.l" + + +#line 471 "lex.yy.h" +#undef yyIN_HEADER +#endif /* yyHEADER_H */ diff --git a/src/lex.yyTest.c b/src/lex.yyTest.c new file mode 100644 index 0000000..1930dda --- /dev/null +++ b/src/lex.yyTest.c @@ -0,0 +1,179 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Files.h" +#include "lex.yy.h" +#include "Oberon.h" +#include "Trees.h" /*symbol type in y.tab.h needs tree node declaration*/ +#include "Util.h" +#include "y.tab.h" +#include +#include +#include + +static FILE *inputFile; + +static struct { int token; const char *value; } expectedOutput[] = { + {IDENT, "x"}, + {IDENT, "scan"}, + {IDENT, "Oberon"}, + {IDENT, "GetSymbol"}, + {IDENT, "firstLetter"}, + {INTEGER, "32767"}, + {INTEGER, "256"}, + {REAL, "340282346638528859811704183484516925440.0"}, + {REAL, "4.567E+6"}, + {REAL, "4.567E-6"}, + {REAL, "179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.0"}, + {INTEGER, "1"}, + {DOTDOT, ""}, + {INTEGER, "10"}, + {STRING, ""}, + {STRING, ""}, + {STRING, "*"}, + {STRING, "*"}, + {STRING, "Don't worry!"}, + {'+', ""}, + {'-', ""}, + {'*', ""}, + {'/', ""}, + {'~', ""}, + {'&', ""}, + {'.', ""}, + {',', ""}, + {';', ""}, + {'|', ""}, + {'(', ""}, + {'[', ""}, + {'{', ""}, + {BECOMES, ""}, + {'^', ""}, + {'=', ""}, + {'#', ""}, + {'<', ""}, + {'>', ""}, + {LE, ""}, + {GE, ""}, + {DOTDOT, ""}, + {':', ""}, + {')', ""}, + {']', ""}, + {'}', ""}, + {ARRAY, ""}, + {BEGIN_, ""}, + {BY, ""}, + {CASE, ""}, + {CONST, ""}, + {DIV, ""}, + {DO, ""}, + {ELSE, ""}, + {ELSIF, ""}, + {END, ""}, + {FALSE, ""}, + {FOR, ""}, + {IF, ""}, + {IMPORT, ""}, + {IN, ""}, + {IS, ""}, + {MOD, ""}, + {MODULE, ""}, + {NIL, ""}, + {OF, ""}, + {OR, ""}, + {POINTER, ""}, + {PROCEDURE, ""}, + {RECORD, ""}, + {REPEAT, ""}, + {RETURN, ""}, + {THEN, ""}, + {TO, ""}, + {TRUE, ""}, + {TYPE, ""}, + {UNTIL, ""}, + {VAR, ""}, + {WHILE, ""} +}; + +static void CompareTokens(int token, int i) +{ + int expectedToken; + const char *expectedValue; + union { + OBNC_INTEGER integer; + OBNC_REAL real; + } value; + + assert((i >= 0) && (i < LEN(expectedOutput))); + + expectedToken = expectedOutput[i].token; + expectedValue = expectedOutput[i].value; + + /*compare token IDs*/ + assert(token == expectedToken); + + /*compare semantic values*/ + switch (token) { + case IDENT: + assert(strcmp(yylval.ident, expectedValue) == 0); + break; + case INTEGER: + sscanf(expectedValue, "%" OBNC_INT_MOD "d", &value.integer); + assert(yylval.integer == value.integer); + break; + case REAL: + sscanf(expectedValue, "%" OBNC_REAL_MOD_R "f", &value.real); + assert(yylval.real == value.real); + break; + case STRING: + assert(strcmp(yylval.string, expectedValue) == 0); + break; + } +} + + +static void TestYYLex(void) +{ + int token, i; + + token = yylex(); + i = 0; + while (token > 0) { + CompareTokens(token, i); + token = yylex(); + i++; + } + assert(i == LEN(expectedOutput)); +} + + +int main(void) +{ + const char *inputFilename = "../tests/scanner/tokens.txt"; + int exitStatus; + + Files_Init(); + Oberon_Init(); + Trees_Init(); + Util_Init(); + inputFile = Files_Old(inputFilename, FILES_READ); + assert(inputFile != NULL); + yyin = inputFile; + TestYYLex(); + Files_Close(&inputFile); + exitStatus = EXIT_SUCCESS; + return exitStatus; +} diff --git a/src/obnc-compile.c b/src/obnc-compile.c new file mode 100644 index 0000000..20e5295 --- /dev/null +++ b/src/obnc-compile.c @@ -0,0 +1,140 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Config.h" +#include "Error.h" +#include "Oberon.h" +#include "StackTrace.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" /*needed by YYSTYPE in y.tab.h*/ +#include "Trees.h" /*needed by YYSTYPE in y.tab.h*/ +#include "y.tab.h" +#include +#include +#include +#include + +static void PrintHelp(void) +{ + puts("obnc-compile - compile an Oberon module to C"); + puts(""); + puts("usage:"); + puts("\tobnc-compile [-e | -l] INFILE"); + puts("\tobnc-compile (-h | -v)"); + puts(""); + puts("\t-e\tcreate entry point function (main)"); + puts("\t-h\tdisplay help and exit"); + puts("\t-l\tprint names of imported modules and exit"); + puts("\t-v\tdisplay version and exit"); + puts(""); + puts("\tINFILE is expected to end with .obn, .Mod or .mod"); +} + + +static void PrintVersion(void) +{ + if (strcmp(CONFIG_VERSION, "") != 0) { + printf("OBNC %s\n", CONFIG_VERSION); + } else { + puts("OBNC (unknown version)"); + } +} + + +static void PrintContext(void) +{ + Oberon_PrintError("%s", ""); +} + + +static void ExitInvalidCommand(const char msg[]) +{ + assert(msg != NULL); + + if (strcmp(msg, "") != 0) { + fprintf(stderr, "obnc-compile: %s\n", msg); + } + fprintf(stderr, "obnc-compile: invalid command. Try 'obnc-compile -h' for more information.\n"); + exit(EXIT_FAILURE); +} + + +static void ExitFailure(const char msg[]) +{ + assert(msg != NULL); + + if (strcmp(msg, "") != 0) { + fprintf(stderr, "obnc-compile: %s\n", msg); + } + fprintf(stderr, "obnc-compile: compilation failed\n"); + exit(EXIT_FAILURE); +} + + +int main(int argc, char *argv[]) +{ + int i; + int helpWanted = 0; + int versionWanted = 0; + int mode = OBERON_NORMAL_MODE; + const char *arg, *inputFile = NULL, *fileSuffix; + + Error_Init(); + Oberon_Init(); + Util_Init(); + StackTrace_Init(PrintContext); + + Error_SetHandler(ExitInvalidCommand); + + for (i = 1; i < argc; i++) { + arg = argv[i]; + if (strcmp(arg, "-h") == 0) { + helpWanted = 1; + } else if (strcmp(arg, "-v") == 0) { + versionWanted = 1; + } else if (strcmp(arg, "-e") == 0) { + mode = OBERON_ENTRY_POINT_MODE; + } else if (strcmp(arg, "-l") == 0) { + mode = OBERON_IMPORT_LIST_MODE; + } else if ((arg[0] != '-') && (inputFile == NULL)) { + fileSuffix = strrchr(arg, '.'); + if ((fileSuffix != NULL) + && ((strcmp(fileSuffix, ".obn") == 0) + || (strcmp(fileSuffix, ".Mod") == 0) + || (strcmp(fileSuffix, ".mod") == 0))) { + inputFile = arg; + } else { + Error_Handle(Util_String("missing or invalid filename extension: %s", arg)); + } + } else { + Error_Handle(""); + } + } + + if (helpWanted) { + PrintHelp(); + } else if (versionWanted) { + PrintVersion(); + } else if (inputFile != NULL) { + Error_SetHandler(ExitFailure); + Oberon_Parse(inputFile, mode); + } else { + Error_Handle(""); + } + + return 0; +} diff --git a/src/obnc-path.c b/src/obnc-path.c new file mode 100644 index 0000000..39cc836 --- /dev/null +++ b/src/obnc-path.c @@ -0,0 +1,128 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Config.h" +#include "Error.h" +#include "ModulePaths.h" +#include "Paths.h" +#include "Util.h" +#include +#include +#include +#include +#include + +static void PrintHelp(void) +{ + puts("obnc-path - print directory path for Oberon module"); + puts(""); + puts("usage:"); + puts("\tobnc-path [-v] MODULE"); + puts("\tobnc-path (-h | -v)"); + puts(""); + puts("\t-h\tdisplay help and exit"); + puts("\t-v\tprint each inspected directory, or display version and exit"); +} + + +static void PrintVersion(void) +{ + if (strcmp(CONFIG_VERSION, "") != 0) { + printf("OBNC %s\n", CONFIG_VERSION); + } else { + puts("OBNC (unknown version)"); + } +} + + +static void PrintPath(const char module[], int verbose) +{ + const char *dirPath; + + dirPath = ModulePaths_Directory(module, ".", verbose); + if (dirPath != NULL) { + puts(Paths_ShellArg(dirPath)); + } else { + Error_Handle(Util_String("module not found: %s", module)); + } +} + + +static void ExitInvalidCommand(const char msg[]) +{ + assert(msg != NULL); + + if (strcmp(msg, "") != 0) { + fprintf(stderr, "obnc-path: %s", msg); + } + fprintf(stderr, ". Try 'obnc-path -h' for more information.\n"); + exit(EXIT_FAILURE); +} + + +static void ExitFailure(const char msg[]) +{ + assert(msg != NULL); + + if (strcmp(msg, "") != 0) { + fprintf(stderr, "obnc-path: %s\n", msg); + } + exit(EXIT_FAILURE); +} + + +int main(int argc, char *argv[]) +{ + int i; + int helpWanted = 0; + int vSet = 0; + const char *module = NULL; + + Config_Init(); + Error_Init(); + ModulePaths_Init(); + Util_Init(); + Error_SetHandler(ExitInvalidCommand); + for (i = 1; i < argc; i++) { + if (strcmp(argv[i], "-h") == 0) { + helpWanted = 1; + } else if (strcmp(argv[i], "-v") == 0) { + vSet= 1; + } else if ((argv[i][0] != '-') && (module == NULL)) { + module = argv[i]; + } else { + Error_Handle("invalid command"); + } + } + + if (helpWanted) { + PrintHelp(); + } else if (module != NULL) { + if (strchr(module, '.') == NULL) { + Error_SetHandler(ExitFailure); + PrintPath(module, vSet); + } else { + Error_Handle("module name cannot contain '.'"); + } + } else if (vSet) { + PrintVersion(); + } else { + Error_Handle("invalid command"); + } + + return 0; +} diff --git a/src/obnc.c b/src/obnc.c new file mode 100644 index 0000000..a967499 --- /dev/null +++ b/src/obnc.c @@ -0,0 +1,916 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Config.h" +#include "Error.h" +#include "Files.h" +#include "ModulePaths.h" +#include "Paths.h" +#include "StackTrace.h" +#include "Time.h" +#include "Util.h" +#include /*POSIX*/ +#include +#include +#include +#include +#include +#include +#include + +typedef struct ModuleNode *ModuleList; + +struct ModuleNode { + char *module, *dir; + int stale; + ModuleList next; +}; + +static const char *executableFile; +static int verbosity; +static int crossCompilationEnabled; + +static int startTime; +static int obncCompileTotalTime; +static int ccCompileTotalTime; +static int ccLinkTotalTime; +static int ccTotalTime; + +static ModuleList NewModuleNode(const char module[], const char dir[], ModuleList next) +{ + ModuleList result; + + NEW(result); + NEW_ARRAY(result->module, strlen(module) + 1); + strcpy(result->module, module); + NEW_ARRAY(result->dir, strlen(dir) + 1); + strcpy(result->dir, dir); + result->stale = 0; + result->next = next; + return result; +} + + +static ModuleList MatchingModuleNode(const char module[], const char dir[], ModuleList ls) +{ + while ((ls != NULL) && ! ((strcmp(ls->module, module) == 0) && (strcmp(ls->dir, dir) == 0))) { + ls = ls->next; + } + return ls; +} + + +static const char *AsPrefix(const char dir[]) +{ + return (strcmp(dir, ".") == 0)? "": Util_String("%s/", dir); +} + + +static const char *ObncCompilerPath(void) +{ + static const char *result; + + if (result == NULL) { + result = Util_String("%s/bin/obnc-compile", Config_Prefix()); + } + return result; +} + + +static void ReadLine(FILE *fp, char **line, int *done) +{ + int resultLen, ch, i; + char *result; + + resultLen = 256; + NEW_ARRAY(result, resultLen); + ch = fgetc(fp); + i = 0; + while ((ch != EOF) && (ch != '\n')) { + if (i >= resultLen - 1) { + resultLen *= 2; + RENEW_ARRAY(result, resultLen); + } + result[i] = ch; + ch = fgetc(fp); + i++; + } + if (! ferror(fp)) { + assert(i < resultLen); + result[i] = '\0'; + *line = result; + *done = ! ((i == 0) && (ch == EOF)); + } else { + Error_Handle(Util_String("reading line failed: %s", strerror(errno))); + } +} + + +static void ReadLines(FILE *fp, char ***lines, int *linesLen) +{ + int resultLen, i, done; + char *line; + char **result; + + resultLen = 256; + NEW_ARRAY(result, resultLen); + i = 0; + ReadLine(fp, &line, &done); + while (done) { + result[i] = line; + i++; + if (i >= resultLen) { + resultLen *= 2; + RENEW_ARRAY(result, resultLen); + } + ReadLine(fp, &line, &done); + } + *lines = result; + *linesLen = i; +} + + +static void GetImportedModulesFromImpFile(const char impFile[], char ***importedModules, int *importedModulesLen) +{ + struct stat st; + int error; + FILE *fp; + + error = stat(impFile, &st); /*for empty files, stat is faster than fopen/fclose*/ + if (! error) { + if (st.st_size > 0) { + fp = Files_Old(impFile, FILES_READ); + ReadLines(fp, importedModules, importedModulesLen); + Files_Close(&fp); + } else { + *importedModules = NULL; + *importedModulesLen = 0; + } + } else { + Error_Handle(Util_String("getting file size of '%s' failed: %s", impFile, strerror(errno))); + } +} + + +static void GetImportedModulesFromSourceFile(const char oberonFile[], char ***importedModules, int *importedModulesLen) +{ + const char *dir, *file; + const char *command; + FILE *fp; + int status; + + dir = Paths_Dirname(oberonFile); + file = Paths_Basename(oberonFile); + command = Util_String("cd %s && %s -l %s", Paths_ShellArg(dir), Paths_ShellArg(ObncCompilerPath()), Paths_ShellArg(file)); + fp = popen(command, "r"); + if (fp != NULL) { + ReadLines(fp, importedModules, importedModulesLen); + status = pclose(fp); + if (status != 0) { + if (status < 0) { + Error_Handle(Util_String("closing pipe failed: %s", strerror(errno))); + } else { + Error_Handle(""); + } + } + } else { + Error_Handle(Util_String("getting imported modules failed: %s", strerror(errno))); + } +} + + +static void GetImportedFiles(const char module[], const char dir[], char ***importedFiles, int *importedFilesLen) +{ + const char *oberonFile, *impFile, *importedModule, *impDir; + char **importedModules; + int importedModulesLen, i; + + oberonFile = ModulePaths_SourceFile(module, dir); + + /*get imported modules*/ + impFile = Util_String("%s/.obnc/%s.imp", dir, module); + if (! Files_Exists(impFile)) { + impFile = Util_String("%s/%s.imp", dir, module); + } + if (Files_Exists(impFile) && (! Files_Exists(oberonFile) || (Files_Timestamp(impFile) >= Files_Timestamp(oberonFile)))) { + GetImportedModulesFromImpFile(impFile, &importedModules, &importedModulesLen); + } else if (Files_Exists(oberonFile)) { + GetImportedModulesFromSourceFile(oberonFile, &importedModules, &importedModulesLen); + } else { + importedModulesLen = 0; + } + + *importedFilesLen = importedModulesLen; + if (*importedFilesLen > 0) { + NEW_ARRAY(*importedFiles, *importedFilesLen); + for (i = 0; i < *importedFilesLen; i++) { + assert(i < importedModulesLen); + importedModule = importedModules[i]; + impDir = ModulePaths_Directory(importedModule, dir, 0); + if (impDir != NULL) { + (*importedFiles)[i] = Util_String("%s", ModulePaths_SourceFile(importedModule, impDir)); + } else { + Error_Handle(Util_String("module imported by %s not found: %s", oberonFile, importedModules[i])); + } + } + } +} + + +static void DetectImportCycle(const char importedModule[], const char moduleDir[], ModuleList nodePath) +{ + ModuleList p, q; + const char *errorMsg; + + p = MatchingModuleNode(importedModule, moduleDir, nodePath); + if (p != NULL) { + errorMsg = Util_String("import cycle found: %s", ModulePaths_SourceFile(importedModule, moduleDir)); + q = nodePath; + while (q != NULL) { + errorMsg = Util_String("%s <- %s", errorMsg, ModulePaths_SourceFile(q->module, q->dir)); + q = q->next; + } + Error_Handle(errorMsg); + } +} + + +static void CompileOberon(const char module[], const char dir[], int isEntryPoint) +{ + const char *outputDir, *inputFile, *symFile, *symBakFile, *entryPointOption, *command; + int error, start; + + outputDir = Util_String("%s/.obnc", dir); + + /*backup current symbol file*/ + symFile = Util_String("%s/%s.sym", outputDir, module); + symBakFile = Util_String("%s.bak", symFile); + if (Files_Exists(symFile)) { + Files_Move(symFile, symBakFile); + } else { + if (! Files_Exists(outputDir)) { + Files_CreateDir(outputDir); + } + } + + entryPointOption = isEntryPoint? "-e": ""; + inputFile = Paths_Basename(ModulePaths_SourceFile(module, dir)); + if (strcmp(dir, ".") == 0) { + command = Util_String("%s %s %s", Paths_ShellArg(ObncCompilerPath()), entryPointOption, Paths_ShellArg(inputFile)); + } else { + command = Util_String("cd %s && %s %s %s", Paths_ShellArg(dir), Paths_ShellArg(ObncCompilerPath()), entryPointOption, Paths_ShellArg(inputFile)); + } + if (verbosity == 2) { + puts(command); + } + start = Time(); + error = system(command); + obncCompileTotalTime += Time() - start; + if (error) { + Error_Handle(""); + } +} + + +static char *UnquotedString(const char s[]) +{ + int sLen; + char *result; + + sLen = strlen(s); + if ((sLen > 0) + && (((s[0] == '\'') && (s[sLen - 1] == '\'')) + || ((s[0] == '"') && (s[sLen - 1] == '"')))) { + result = Util_String("%s", s + 1); + result[sLen - 2] = '\0'; + } else { + result = Util_String("%s", s); + } + return result; +} + + +static void ReadEnvFile(const char filename[], char **keys[], char **values[], int *len) +{ + FILE *fp; + char **lines; + int linesLen, i; + const char *p; + char *key, *value; + + fp = Files_Old(filename, FILES_READ); + ReadLines(fp, &lines, &linesLen); + *len = linesLen; + NEW_ARRAY(*keys, *len); + NEW_ARRAY(*values, *len); + for (i = 0; i < linesLen; i++) { + p = strchr(lines[i], '='); + if (p != NULL) { + key = Util_String("%s", lines[i]); + key[p - lines[i]] = '\0'; + value = UnquotedString(Util_String("%s", p + 1)); + } else { + key = Util_String("%s", ""); + value = Util_String("%s", ""); + } + (*keys)[i] = key; + (*values)[i] = value; + } + Files_Close(&fp); +} + + +static char *CCompiler(void) +{ + char *cc, *result; + + cc = getenv("CC"); + if ((cc != NULL) && (strcmp(cc, "") != 0)) { + result = Util_String("%s", cc); + } else { + result = Util_String("cc"); + } + return result; +} + + +static void CompileC(const char module[], const char dir[]) +{ + const char *inputFile, *outputFile, *envFile, *cc, *includePath, *globalCFlags, *moduleCFlags, *cFlags, *command; + char **keys, **values; + int len, i, error, start; + + inputFile = Util_String("%s%s.c", AsPrefix(dir), module); + if (! Files_Exists(inputFile)) { + inputFile = Util_String("%s.obnc/%s.c", AsPrefix(dir), module); + } + + outputFile = Util_String("%s.obnc/%s.o", AsPrefix(dir), module); + envFile = Util_String("%s/%s.env", dir, module); + + cc = CCompiler(); + + globalCFlags = getenv("CFLAGS"); + if (globalCFlags == NULL) { + globalCFlags = ""; + } + includePath = Util_String("%s/include", Config_Prefix()); + globalCFlags = Util_String("-I %s %s", Paths_ShellArg(includePath), globalCFlags); + + moduleCFlags = ""; + if (Files_Exists(envFile)) { + ReadEnvFile(envFile, &keys, &values, &len); + for (i = 0; i < len; i++) { + if (strcmp(keys[i], "CC") == 0) { + cc = Util_String("%s", values[i]); + } else if (strcmp(keys[i], "CFLAGS") == 0) { + moduleCFlags = Util_String("%s", values[i]); + } + } + } + + cFlags = Util_String("%s %s", globalCFlags, moduleCFlags); + + command = Util_String("%s -c -o %s %s %s", cc, Paths_ShellArg(outputFile), cFlags, Paths_ShellArg(inputFile)); + if (verbosity == 2) { + puts(command); + } + if ((strstr(cFlags, "OBNC_CONFIG_TARGET_EMB=") != NULL) && ! crossCompilationEnabled) { + Error_Handle("OBNC_CONFIG_TARGET_EMB can only be used with option -x"); + } + start = Time(); + error = system(command); + ccCompileTotalTime += Time() - start; + if (error) { + Error_Handle(""); + } +} + + +static void Compile(const char module[], const char dir[], int oberonCompilationNeeded, int isEntryPoint) +{ + if (verbosity == 1) { + printf("Compiling module %s\n", module); + } else if (verbosity == 2) { + printf("\nCompiling module %s:\n\n", module); + } + if (oberonCompilationNeeded) { + CompileOberon(module, dir, isEntryPoint); + } + if (! crossCompilationEnabled) { + CompileC(module, dir); + } +} + + +static void UpdateObjectFile(const char module[], const char dir[], int stale, int isEntryPoint) +{ + const char *oberonFile, *dirName, *symFile, *genCFile, *hFile, *dirFile, *objectFile, *envFile, *nonGenCFile; + int dirFileUpToDate, done, oberonCompilationNeeded, cCompilationNeeded; + FILE *fp; + char *dirFileContent; + + oberonFile = ModulePaths_SourceFile(module, dir); + dirName = Paths_Basename(dir); + dirFile = Util_String("%s/.obnc/%s.dir", dir, module); + symFile = Util_String("%s/.obnc/%s.sym", dir, module); + genCFile = Util_String("%s/.obnc/%s.c", dir, module); + nonGenCFile = Util_String("%s/%s.c", dir, module); + hFile = Util_String("%s/.obnc/%s.h", dir, module); + objectFile = Util_String("%s/.obnc/%s.o", dir, module); + envFile = Util_String("%s/%s.env", dir, module); + + dirFileUpToDate = 0; + if (Files_Exists(dirFile)) { + fp = Files_Old(dirFile, FILES_READ); + ReadLine(fp, &dirFileContent, &done); + if (done && strcmp(dirFileContent, dirName) == 0) { + dirFileUpToDate = 1; + } + Files_Close(&fp); + } + + oberonCompilationNeeded = 0; + if (stale + || ! Files_Exists(genCFile) || (Files_Timestamp(genCFile) < Files_Timestamp(oberonFile) + || (isEntryPoint && Files_Exists(symFile)) + || (! isEntryPoint && ( + ! Files_Exists(symFile) || (Files_Timestamp(symFile) < Files_Timestamp(oberonFile)) + || ! Files_Exists(hFile) || (Files_Timestamp(hFile) < Files_Timestamp(oberonFile)) + || ! dirFileUpToDate)))) { + oberonCompilationNeeded = 1; + } + + cCompilationNeeded = 0; + if (! crossCompilationEnabled) { + if (oberonCompilationNeeded + || ! Files_Exists(objectFile) + || (! Files_Exists(nonGenCFile) && (Files_Timestamp(objectFile) < Files_Timestamp(genCFile))) + || (Files_Exists(nonGenCFile) && (Files_Timestamp(objectFile) < Files_Timestamp(nonGenCFile))) + || (Files_Exists(envFile) && (Files_Timestamp(objectFile) < Files_Timestamp(envFile)))) { + cCompilationNeeded = 1; + } + } + + if (oberonCompilationNeeded || cCompilationNeeded) { + Compile(module, dir, oberonCompilationNeeded, isEntryPoint); + } + + if (isEntryPoint) { + if (Files_Exists(dirFile)) { + Files_Remove(dirFile); + } + } else if (! dirFileUpToDate) { + if (! Files_Exists(dirFile)) { + fp = Files_New(dirFile); + } else { + fp = Files_Old(dirFile, FILES_WRITE); + } + fprintf(fp, "%s\n", dirName); + Files_Close(&fp); + } + +} + + +static int FilesEqual(const char f1[], const char f2[]) +{ + FILE *fp1, *fp2; + int ch1, ch2; + + fp1 = Files_Old(f1, FILES_READ); + fp2 = Files_Old(f2, FILES_READ); + do { + ch1 = getc(fp1); + ch2 = getc(fp2); + } while ((ch1 != EOF) && (ch1 == ch2)); + Files_Close(&fp1); + Files_Close(&fp2); + + return (ch1 == EOF) && (ch2 == EOF); +} + + +static void Traverse1(const char module[], const char dir[], ModuleList nodePath, int isRoot, ModuleList *discoveredModules) +{ + char **importedFiles; + int stale, symFileChanged, importedFilesLen, i; + const char *importedModule, *importedModuleDir, *oberonFile, *symFile, *symBakFile; + ModuleList newNodePath, p, moduleNode; + + *discoveredModules = NewModuleNode(module, dir, *discoveredModules); + + /*traverse imported files*/ + stale = 0; + GetImportedFiles(module, dir, &importedFiles, &importedFilesLen); + for (i = 0; i < importedFilesLen; i++) { + importedModule = Paths_SansSuffix(Paths_Basename(importedFiles[i])); + importedModuleDir = Paths_Dirname(importedFiles[i]); + DetectImportCycle(importedModule, importedModuleDir, nodePath); + if (! MatchingModuleNode(importedModule, importedModuleDir, *discoveredModules)) { + newNodePath = NewModuleNode(importedModule, importedModuleDir, nodePath); + Traverse1(importedModule, importedModuleDir, newNodePath, 0, discoveredModules); + } + p = MatchingModuleNode(importedModule, importedModuleDir, *discoveredModules); + assert(p != NULL); + if (p->stale) { + stale = 1; + } + } + + symFileChanged = 0; + oberonFile = ModulePaths_SourceFile(module, dir); + if (Files_Exists(oberonFile)) { + UpdateObjectFile(module, dir, stale, isRoot); + + /*find out if the symbol file has changed*/ + symFile = Util_String("%s/.obnc/%s.sym", dir, module); + symBakFile = Util_String("%s.bak", symFile); + if (Files_Exists(symFile) && Files_Exists(symBakFile)) { + if (! FilesEqual(symFile, symBakFile)) { + symFileChanged = 1; + } + Files_Remove(symBakFile); + } + } + moduleNode = MatchingModuleNode(module, dir, *discoveredModules); + assert(moduleNode != NULL); + moduleNode->stale = symFileChanged; +} + + +static void Traverse(const char oberonFile[], ModuleList *discoveredModules) +{ + const char *module = Paths_SansSuffix(Paths_Basename(oberonFile)); + const char *dir = Paths_Dirname(oberonFile); + ModuleList nodePath = NewModuleNode(module, dir, NULL); + + Traverse1(module, dir, nodePath, 1, discoveredModules); +} + + +static const char *NewestFile(const char *filenames[], int filenamesLen) +{ + const char *result; + int i; + + assert(filenamesLen > 0); + result = filenames[0]; + for (i = 1; i < filenamesLen; i++) { + if (Files_Timestamp(filenames[i]) > Files_Timestamp(result)) { + result = filenames[i]; + } + } + return result; +} + + +static char *CCInputFile(const char module[], const char dir[]) +{ + int found; + char *result; + + found = 0; + if (crossCompilationEnabled) { + result = Util_String("%s%s.c", AsPrefix(dir), module); + found = Files_Exists(result); + if (! found) { + result = Util_String("%s.obnc/%s.c", AsPrefix(dir), module); + found = Files_Exists(result); + } + } + if (! found) { + result = Util_String("%s.obnc/%s.o", AsPrefix(dir), module); + if (! Files_Exists(result)) { + result = Util_String("%s%s.o", AsPrefix(dir), module); + if (! Files_Exists(result)) { + Error_Handle(Util_String("object file not found for module `%s' in directory `%s'", module, dir)); + } + } + } + return result; +} + + +static void DeleteArg(const char arg[], char argList[]) +{ + int argLen; + char *p; + + assert(arg != NULL); + assert(argList != NULL); + + argLen = strlen(arg); + if (argLen > 0) { + p = strstr(argList, arg); + while (p != NULL) { + if (((p == argList) || isspace((p - 1)[0])) + && (isspace((p + argLen)[0]) || ((p + argLen)[0] == '\0'))) { + strcpy(p, Util_String("%s", p + argLen)); + } else { + p += argLen; + } + p = strstr(p, arg); + } + } +} + + +static void CreateExecutable(const char *inputFiles[], int inputFilesLen) +{ + int embedded, keysLen, i, j, error, start; + char **keys, **values; + char *ldLibs; + const char *cc, *cFlags, *includePath, *ldFlags, *inputFileArgs, *module, *envFileDir, *envFile, *command; + + cc = CCompiler(); + + embedded = 0; + if (crossCompilationEnabled) { + cFlags = getenv("CFLAGS"); + if (cFlags != NULL) { + embedded = strstr(cFlags, "OBNC_CONFIG_TARGET_EMB=1") != NULL; + } else { + cFlags = ""; + } + includePath = Util_String("%s/include", Config_Prefix()); + cFlags = Util_String("-I %s %s", Paths_ShellArg(includePath), cFlags); + } else { + cFlags = ""; + } + ldFlags = getenv("LDFLAGS"); + if (ldFlags == NULL) { + ldFlags = ""; + } + ldLibs = getenv("LDLIBS"); + if (ldLibs == NULL) { + ldLibs = Util_String("%s", ""); + } + inputFileArgs = ""; + for (i = 0; i < inputFilesLen; i++) { + module = Paths_SansSuffix(Paths_Basename(inputFiles[i])); + envFileDir = Paths_Dirname(inputFiles[i]); + if (strcmp(Paths_Basename(envFileDir), ".obnc") == 0) { + envFileDir = Paths_Dirname(envFileDir); + } + envFile = Util_String("%s/%s.env", envFileDir, module); + if (Files_Exists(envFile)) { + ReadEnvFile(envFile, &keys, &values, &keysLen); + for (j = 0; j < keysLen; j++) { + if (strcmp(keys[j], "LDFLAGS") == 0) { + ldFlags = Util_String("%s %s", ldFlags, values[j]); + } else if (strcmp(keys[j], "LDLIBS") == 0) { + ldLibs = Util_String("%s %s", ldLibs, values[j]); + } + } + } + inputFileArgs = Util_String("%s %s", inputFileArgs, Paths_ShellArg(inputFiles[i])); + } + if (embedded) { + DeleteArg("-lgc", ldLibs); + DeleteArg("-lm", ldLibs); + } + + command = Util_String("%s -o %s %s %s %s %s", cc, Paths_ShellArg(executableFile), cFlags, ldFlags, inputFileArgs, ldLibs); + if (verbosity == 1) { + printf("Creating executable %s\n", executableFile); + } else if (verbosity == 2) { + printf("\nCreating executable %s:\n\n%s\n", executableFile, command); + } + start = Time(); + error = system(command); + if (crossCompilationEnabled) { + ccTotalTime = Time() - start; + } else { + ccLinkTotalTime += Time() - start; + } + if (error) { + Error_Handle(""); + } +} + + +static void PrintTimeFractions(int startTime) +{ + int elapsedTotal, obncPercent, obncCompilePercent, ccCompilePercent = 0, ccLinkPercent = 0, ccPercent = 0; + const char *cc; + + elapsedTotal = Time() - startTime; + obncCompilePercent = (int) ((double) obncCompileTotalTime / (double) elapsedTotal * 100.0 + 0.5); + if (crossCompilationEnabled) { + ccPercent = (int) ((double) ccTotalTime / (double) elapsedTotal * 100.0 + 0.5); + obncPercent = 100 - obncCompilePercent - ccPercent; + } else { + ccCompilePercent = (int) ((double) ccCompileTotalTime / (double) elapsedTotal * 100.0 + 0.5); + ccLinkPercent = (int) ((double) ccLinkTotalTime / (double) elapsedTotal * 100.0 + 0.5); + obncPercent = 100 - obncCompilePercent - ccCompilePercent - ccLinkPercent; + } + cc = Paths_Basename(CCompiler()); + + printf("\nTiming statistics:\n\n"); + printf("Command Time spent\n"); + printf("------------------------\n"); + printf("obnc %18d%%\n", obncPercent); + printf("obnc-compile %10d%%\n", obncCompilePercent); + if (crossCompilationEnabled) { + printf("%s %*d%%\n", cc, 22 - (int) strlen(cc), ccPercent); + } else { + printf("%s compile %*d%%\n", cc, 14 - (int) strlen(cc), ccCompilePercent); + printf("%s link %*d%%\n", cc, 17 - (int) strlen(cc), ccLinkPercent); + } + printf("------------------------\n"); +} + + +static void Build(const char oberonFile[]) +{ + ModuleList discoveredModules, p; + const char *coreLibFile, *newestCCModule; + int ccInputFilesLen, i; + const char **ccInputFiles; + + discoveredModules = NULL; + Traverse(oberonFile, &discoveredModules); + + ccInputFilesLen = 1; + p = discoveredModules; + while (p != NULL) { + ccInputFilesLen++; + p = p->next; + } + assert(ccInputFilesLen >= 2); + + if (crossCompilationEnabled) { + coreLibFile = Util_String("%s/%s/obnc/OBNC.c", Config_Prefix(), Config_LibDir()); + if (! Files_Exists(coreLibFile)) { + coreLibFile = Util_String("%s/%s/obnc/OBNC.o", Config_Prefix(), Config_LibDir()); + } + } else { + coreLibFile = Util_String("%s/%s/obnc/OBNC.o", Config_Prefix(), Config_LibDir()); + } + + NEW_ARRAY(ccInputFiles, ccInputFilesLen); + ccInputFiles[0] = coreLibFile; + i = 1; + p = discoveredModules; + while (p != NULL) { + ccInputFiles[i] = CCInputFile(p->module, p->dir); + i++; + p = p->next; + } + + newestCCModule = NewestFile(ccInputFiles, ccInputFilesLen); + if (! Files_Exists(executableFile) || (Files_Timestamp(executableFile) < Files_Timestamp(newestCCModule)) || crossCompilationEnabled) { + CreateExecutable(ccInputFiles, ccInputFilesLen); + if (verbosity == 2) { + PrintTimeFractions(startTime); + } + } else { + printf("%s is up to date\n", executableFile); + } +} + + +static void PrintHelp(void) +{ + puts("obnc - build an executable for an Oberon module\n"); + puts("usage:"); + puts("\tobnc [-o OUTFILE] [-v | -V] [-x] INFILE"); + puts("\tobnc (-h | -v)\n"); + puts("\t-o\tuse pathname OUTFILE for generated executable"); + puts("\t-v\tlog compiled modules or display version and exit"); + puts("\t-V\tlog compiler and linker commands"); + puts("\t-x\tcompile and link C files in one command (for cross compilation)"); + puts("\t-h\tdisplay help and exit"); + puts(""); + puts("\tINFILE is expected to end with .obn, .Mod or .mod"); +} + + +static void PrintVersion(void) +{ + if (strcmp(CONFIG_VERSION, "") != 0) { + printf("OBNC %s\n", CONFIG_VERSION); + } else { + puts("OBNC (unknown version)"); + } +} + + +static void ExitInvalidCommand(const char msg[]) +{ + assert(msg != NULL); + + if (strcmp(msg, "") != 0) { + fprintf(stderr, "obnc: %s", msg); + } + fprintf(stderr, ". Try 'obnc -h' for more information.\n"); + exit(EXIT_FAILURE); +} + + +static void ExitFailure(const char msg[]) +{ + assert(msg != NULL); + + if (strcmp(msg, "") != 0) { + fprintf(stderr, "obnc: %s\n", msg); + } + fprintf(stderr, "obnc: build process failed\n"); + exit(EXIT_FAILURE); +} + + +int main(int argc, char *argv[]) +{ + int i, hSet = 0, vSet = 0, VSet = 0; + const char *arg, *inputFile = NULL, *fileSuffix; + + startTime = Time(); + Config_Init(); + Error_Init(); + Files_Init(); + ModulePaths_Init(); + Util_Init(); + StackTrace_Init(NULL); + + Error_SetHandler(ExitInvalidCommand); + + i = 1; + while (i < argc) { + arg = argv[i]; + if (strcmp(arg, "-h") == 0) { + hSet = 1; + } else if (strcmp(arg, "-o") == 0) { + if ((i < argc - 1) && (argv[i + 1][0] != '-')) { + executableFile = argv[i + 1]; + i++; + } else { + Error_Handle("output file parameter expected for option -o"); + } + } else if (strcmp(arg, "-v") == 0) { + vSet = 1; + } else if (strcmp(arg, "-V") == 0) { + VSet = 1; + } else if (strcmp(arg, "-x") == 0) { + crossCompilationEnabled = 1; + } else if (arg[0] == '-') { + Error_Handle(Util_String("invalid option: `%s'", arg)); + } else if (inputFile == NULL) { + fileSuffix = strrchr(arg, '.'); + if ((fileSuffix != NULL) + && ((strcmp(fileSuffix, ".obn") == 0) + || (strcmp(fileSuffix, ".Mod") == 0) + || (strcmp(fileSuffix, ".mod") == 0))) { + if (Files_Exists(arg)) { + inputFile = arg; + } else { + Error_Handle(Util_String("no such file or directory: %s", arg)); + } + } else { + Error_Handle(Util_String("invalid or missing file suffix for input file: %s", arg)); + } + } else { + Error_Handle("only one input file expected"); + } + i++; + } + + if (hSet) { + PrintHelp(); + } else if (vSet && (inputFile == NULL)) { + PrintVersion(); + } else if (inputFile != NULL) { + Error_SetHandler(ExitFailure); + if (executableFile == NULL) { +#ifdef _WIN32 + executableFile = Util_String("%s.exe", Paths_SansSuffix(Paths_Basename(inputFile))); +#else + executableFile = Paths_SansSuffix(Paths_Basename(inputFile)); +#endif + } + if (VSet) { + verbosity = 2; + } else if (vSet) { + verbosity = 1; + } + Build(inputFile); + } else { + Error_Handle("no input file"); + } + return 0; +} diff --git a/src/obncdoc.c b/src/obncdoc.c new file mode 100644 index 0000000..6ba4a22 --- /dev/null +++ b/src/obncdoc.c @@ -0,0 +1,389 @@ +/*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*/ + +#include "Config.h" +#include "Error.h" +#include "Files.h" +#include "Paths.h" +#include "Util.h" +#include /*POSIX*/ +#include /*POSIX*/ +#include +#include +#include +#include +#include + +typedef struct { int count; char **filenames; } Accumulator; + +typedef void (*Applicator)(const char filename[], Accumulator *acc); + +static void Apply(Applicator f, const char dirName[], Accumulator *acc) /*apply f on each file in directory dir with accumulator acc*/ +{ + DIR *dir; + struct dirent *file; + const char *filename; + int error; + + assert(f != NULL); + assert(dirName != NULL); + + dir = opendir(dirName); + if (dir != NULL) { + file = readdir(dir); + while (file != NULL) { + if ((strcmp(file->d_name, ".") != 0) && (strcmp(file->d_name, "..") != 0)) { + filename = file->d_name; + f(filename, acc); + } + file = readdir(dir); + } + error = closedir(dir); + if (error) { + Error_Handle(Util_String("closing directory failed: %s", strerror(errno))); + } + } else { + Error_Handle(Util_String("reading directory failed: %s", strerror(errno))); + } +} + + +static void ExitFailure(const char msg[]) +{ + assert(msg != NULL); + + if (strcmp(msg, "") != 0) { + fprintf(stderr, "obncdoc: %s\n", msg); + } + fputs("obncdoc: generating documentation failed\n", stderr); + exit(EXIT_FAILURE); +} + + +static void PrintHelp(void) +{ + puts("obncdoc - extract exported features from Oberon modules"); + putchar('\n'); + puts("usage:"); + puts("\tobncdoc [-h | -v]"); + putchar('\n'); + puts("\t-h\tdisplay help and exit"); + puts("\t-v\tdisplay version and exit"); +} + + +static void PrintVersion(void) +{ + if (strcmp(CONFIG_VERSION, "") != 0) { + printf("OBNC %s\n", CONFIG_VERSION); + } else { + puts("OBNC (unknown version)"); + } +} + + +static int EndsWith(const char pattern[], const char target[]) +{ + size_t patternLen = strlen(pattern); + size_t targetLen = strlen(target); + + return (patternLen <= targetLen) && (strcmp(target + targetLen - patternLen, pattern) == 0); +} + + +static int IsOberonFile(const char filename[]) +{ + return EndsWith(".obn", filename) || EndsWith(".Mod", filename) || EndsWith(".mod", filename); +} + + +static const char *IndexTitle(void) +{ + return Util_String("Index of %s", Paths_Basename(Paths_CurrentDir())); +} + + +static void PrintHtmlHeader(const char title[], FILE *file) +{ + fputs("\n", file); + fputs("\n", file); + fputs(" \n", file); + fputs(" \n", file); + fputs(" \n", file); + fprintf(file, " %s\n", title); + fprintf(file, " \n"); + fputs(" \n", file); + fputs(" \n", file); +} + + +static void PrintHtmlFooter(FILE *file) +{ + fputs(" \n", file); + fputs("\n", file); +} + + +static void CreateHtmlDefinition(const char module[], const char inputFile[], const char outputFile[]) +{ + const char *title, *script, *command; + FILE *outFile; + int error; + + title = Util_String("DEFINITION %s", module); + + if (Files_Exists(outputFile)) { + outFile = Files_Old(outputFile, FILES_WRITE); + } else { + outFile = Files_New(outputFile); + } + PrintHtmlHeader(title, outFile); + fprintf(outFile, "

Index

\n"); + fputc('\n', outFile); + fputs(" 
\n", outFile);
+	Files_Close(&outFile);
+
+	script = Util_String("%s/bin/obncdoc-markup", Config_Prefix());
+	command = Util_String("awk -f %s < %s >> %s", Paths_ShellArg(script), Paths_ShellArg(inputFile), Paths_ShellArg(outputFile));
+	error = system(command);
+	if (! error) {
+		outFile = Files_Old(outputFile, FILES_APPEND);
+		fputs("
\n", outFile); + PrintHtmlFooter(outFile); + Files_Close(&outFile); + } else { + Files_Remove(outputFile); + Error_Handle(""); + } +} + + +static void CreateDefinition(const char filename[], Accumulator *acc) +{ + const char *oberonFile, *module, *textOutputFile, *htmlOutputFile, *scriptFile, *command; + int error; + + assert(acc != NULL); + + if (IsOberonFile(filename)) { + oberonFile = filename; + module = Paths_SansSuffix(Paths_Basename(oberonFile)); + textOutputFile = Util_String("obncdoc/%s.def", module); + htmlOutputFile = Util_String("obncdoc/%s.def.html", module); + + if (! Files_Exists(textOutputFile) || (Files_Timestamp(textOutputFile) < Files_Timestamp(oberonFile))) { + scriptFile = Util_String("%s/bin/obncdoc-extract", Config_Prefix()); + command = Util_String("awk -f %s < %s > %s", Paths_ShellArg(scriptFile), oberonFile, textOutputFile); + error = system(command); + if (! error) { + CreateHtmlDefinition(module, textOutputFile, htmlOutputFile); + } else { + Error_Handle(""); + } + } + acc->count++; + } +} + + +static void CreateAllDefinitions(void) +{ + Accumulator acc; + + if (! Files_Exists("obncdoc")) { + Files_CreateDir("obncdoc"); + } + acc.count = 0; + Apply(CreateDefinition, ".", &acc); + if (acc.count == 0) { + Error_Handle("no oberon files"); + } +} + + +static void DeleteOrphanedDefinition(const char filename[], Accumulator *acc) +{ + const char *module; + + (void) acc; /*unused*/ + if (strstr(filename, ".def") != NULL) { + module = Paths_SansSuffix(Paths_Basename(filename)); + if (! Files_Exists(Util_String("%s.obn", module)) + && ! Files_Exists(Util_String("%s.Mod", module)) + && ! Files_Exists(Util_String("%s.mod", module))) { + Files_Remove(Util_String("obncdoc/%s", filename)); + } + } +} + + +static void DeleteAllOrphanedDefinitions(void) +{ + Apply(DeleteOrphanedDefinition, "obncdoc", NULL); +} + + +static void CountDefinition(const char filename[], Accumulator *acc) +{ + assert(filename != NULL); + assert(acc != NULL); + + if (EndsWith(".def", filename)) { + acc->count++; + } +} + + +static void AddDefinition(const char filename[], Accumulator *acc) +{ + if (EndsWith(".def", filename)) { + acc->filenames[acc->count] = Util_String("%s", filename); + acc->count++; + } +} + + +static int StringComparison(const void *a, const void *b) +{ + const char *s1 = *(const char **) a; + const char *s2 = *(const char **) b; + + return strcmp(s1, s2); +} + + +static int DefFileEmpty(const char filename[]) +{ + FILE *f; + int ch, newlineCount; + + f = Files_Old(filename, FILES_READ); + newlineCount = 0; + ch = fgetc(f); + while ((ch != EOF) && (newlineCount <= 2)) { + if (ch == '\n') { + newlineCount++; + } + ch = fgetc(f); + } + Files_Close(&f); + return newlineCount == 2; +} + + +static void CreateIndex(void) +{ + const char *indexFilename = "obncdoc/index.html", *defFilename, *module; + Accumulator acc; + FILE *indexFile; + int filenamesLen, i; + + /*count definition files*/ + acc.count = 0; + Apply(CountDefinition, "obncdoc", &acc); + + /*add definition files to string array*/ + filenamesLen = acc.count; + NEW_ARRAY(acc.filenames, filenamesLen); + acc.count = 0; + Apply(AddDefinition, "obncdoc", &acc); + assert(acc.count == filenamesLen); + + /*sort definition files*/ + qsort(acc.filenames, filenamesLen, sizeof (char *), StringComparison); + + if (Files_Exists(indexFilename)) { + indexFile = Files_Old(indexFilename, FILES_WRITE); + } else { + indexFile = Files_New(indexFilename); + } + PrintHtmlHeader(IndexTitle(), indexFile); + fputs("

Index

\n", indexFile); + fputc('\n', indexFile); + fputs(" 
\n", indexFile);
+	for (i = 0; i < filenamesLen; i++) {
+		defFilename = acc.filenames[i];
+		if (! DefFileEmpty(Util_String("obncdoc/%s", defFilename))) {
+			module = Paths_SansSuffix(Paths_Basename(defFilename));
+			fprintf(indexFile, "DEFINITION %s\n", module, module);
+		}
+	}
+	fputs("
\n", indexFile); + PrintHtmlFooter(indexFile); + Files_Close(&indexFile); +} + + +static void CreateCss(void) +{ + const char *cssFile, *command; + int error; + + if (! Files_Exists("obncdoc/style.css")) { + cssFile = Util_String("%s/share/obnc/style.css", Config_Prefix()); +#ifdef _WIN32 + command = Util_String("copy %s obncdoc > NUL", Paths_ShellArg(Util_Replace("/", "\\", cssFile))); +#else + command = Util_String("cp %s obncdoc", Paths_ShellArg(cssFile)); +#endif + error = system(command); + if (error) { + Error_Handle(""); + } + } +} + + +static void CreateOutputFiles(void) +{ + CreateAllDefinitions(); + DeleteAllOrphanedDefinitions(); + CreateIndex(); + CreateCss(); +} + + +int main(int argc, char *argv[]) +{ + int i, helpWanted = 0, versionWanted = 0; + const char *arg; + + Config_Init(); + Error_Init(); + Files_Init(); + Util_Init(); + Error_SetHandler(ExitFailure); + + for (i = 1; i < argc; i++) { + arg = argv[i]; + if (strcmp(arg, "-h") == 0) { + helpWanted = 1; + } else if (strcmp(arg, "-v") == 0) { + versionWanted = 1; + } else { + Error_Handle("Invalid command. Try 'obncdoc -h' for more information."); + } + } + if (helpWanted) { + PrintHelp(); + } else if (versionWanted) { + PrintVersion(); + } else { + CreateOutputFiles(); + } + return 0; +} diff --git a/src/y.tab.c b/src/y.tab.c new file mode 100644 index 0000000..2f1b119 --- /dev/null +++ b/src/y.tab.c @@ -0,0 +1,6014 @@ +/* A Bison parser, made by GNU Bison 3.3.2. */ + +/* Bison implementation for Yacc-like parsers in C + + Copyright (C) 1984, 1989-1990, 2000-2015, 2018-2019 Free Software Foundation, + Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* As a special exception, you may create a larger work that contains + part or all of the Bison parser skeleton and distribute that work + under terms of your choice, so long as that work isn't itself a + parser generator using the skeleton or a modified version thereof + as a parser skeleton. Alternatively, if you modify or redistribute + the parser skeleton itself, you may (at your option) remove this + special exception, which will cause the skeleton and the resulting + Bison output files to be licensed under the GNU General Public + License without this special exception. + + This special exception was added by the Free Software Foundation in + version 2.2 of Bison. */ + +/* C LALR(1) parser skeleton written by Richard Stallman, by + simplifying the original so-called "semantic" parser. */ + +/* All symbols defined below should begin with yy or YY, to avoid + infringing on user name space. This should be done even for local + variables, as they might otherwise be expanded by user macros. + There are some unavoidable exceptions within include files to + define necessary library symbols; they are noted "INFRINGES ON + USER NAME SPACE" below. */ + +/* Undocumented macros, especially those whose name start with YY_, + are private implementation details. Do not rely on them. */ + +/* Identify Bison output. */ +#define YYBISON 1 + +/* Bison version. */ +#define YYBISON_VERSION "3.3.2" + +/* Skeleton name. */ +#define YYSKELETON_NAME "yacc.c" + +/* Pure parsers. */ +#define YYPURE 0 + +/* Push parsers. */ +#define YYPUSH 0 + +/* Pull parsers. */ +#define YYPULL 1 + + + + +/* First part of user prologue. */ +#line 18 "Oberon.y" /* yacc.c:337 */ + +#include "Config.h" +#include "Error.h" +#include "Files.h" +#include "Generate.h" +#include "lex.yy.h" +#include "Maps.h" +#include "Oberon.h" +#include "ModulePaths.h" +#include "Paths.h" +#include "Range.h" +#include "Table.h" +#include "Types.h" +#include "Trees.h" +#include "Util.h" +#include "../lib/obnc/OBNC.h" +#include +#include +#include +#include +#include +#include +#include +#include + +/*assignment contexts*/ +#define ASSIGNMENT_CONTEXT 0 +#define PARAM_SUBST_CONTEXT 1 +#define PROC_RESULT_CONTEXT 2 + +static int initialized = 0; + +static const char *inputFilename; +static int parseMode; +static char *inputModuleName; + +static Trees_Node unresolvedPointerTypes; +static Trees_Node currentTypeIdentdef; +static Trees_Node recordDeclarationStack; +static Trees_Node caseExpressionStack; +static Trees_Node caseLabelsStack; +static Trees_Node procedureDeclarationStack; + +void yyerror(const char msg[]); +static void CheckUnusedIdentifiers(void); + +/*constant predicate functions*/ + +static int IsBoolean(Trees_Node node); +static int IsChar(Trees_Node node); +static int IsInteger(Trees_Node node); +static int IsReal(Trees_Node node); +static int IsString(Trees_Node node); +static int IsSet(Trees_Node node); + +/*functions for type declaration productions*/ + +static Trees_Node ResolvedType(Trees_Node type, int isTypeDecl); +static void ResolvePointerTypes(Trees_Node baseType); +static const char *TypeString(Trees_Node type); + +/*functions for expression productions*/ + +static Trees_Node Designator(const char ident[], Trees_Node selectorList); +static int IsDesignator(Trees_Node exp); +static Trees_Node BaseIdent(Trees_Node designator); +static Trees_Node FirstSelector(Trees_Node designator); +static const char *DesignatorString(Trees_Node designator); +static void CheckIsValueExpression(Trees_Node exp); +static void SetSelectorTypes(Trees_Node identType, Trees_Node designator, int *parameterListFound); +static void RemoveActualParameters(Trees_Node *designator, Trees_Node *actualParameters); +static int IsConstExpression(Trees_Node exp); +static Trees_Node ExpressionConstValue(int relation, Trees_Node expA, Trees_Node expB); +static Trees_Node SimpleExpressionConstValue(int addOperator, Trees_Node expA, Trees_Node expB); +static Trees_Node TermConstValue(int mulOperator, Trees_Node expA, Trees_Node expB); +static const char *OperatorString(int operator); + +/*functions for statement productions*/ + +static int Writable(Trees_Node designator); +static void ValidateAssignment(Trees_Node expression, Trees_Node targetType, int context, int paramPos); +static void HandleProcedureCall(Trees_Node designator, Trees_Node actualParameters, int isFunctionCall, Trees_Node *ast); +static void CheckCaseLabelUniqueness(Trees_Node label); + +/*functions for module productions*/ + +static void ExportSymbolTable(const char symfilePath[]); + +#line 159 "y.tab.c" /* yacc.c:337 */ +# ifndef YY_NULLPTR +# if defined __cplusplus +# if 201103L <= __cplusplus +# define YY_NULLPTR nullptr +# else +# define YY_NULLPTR 0 +# endif +# else +# define YY_NULLPTR ((void*)0) +# endif +# endif + +/* Enabling verbose error messages. */ +#ifdef YYERROR_VERBOSE +# undef YYERROR_VERBOSE +# define YYERROR_VERBOSE 1 +#else +# define YYERROR_VERBOSE 1 +#endif + +/* In a future release of Bison, this section will be replaced + by #include "y.tab.h". */ +#ifndef YY_YY_Y_TAB_H_INCLUDED +# define YY_YY_Y_TAB_H_INCLUDED +/* Debug traces. */ +#ifndef YYDEBUG +# define YYDEBUG 1 +#endif +#if YYDEBUG +extern int yydebug; +#endif + +/* Token type. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + enum yytokentype + { + TOKEN_START = 258, + ARRAY = 259, + BEGIN_ = 260, + BY = 261, + CASE = 262, + CONST = 263, + DIV = 264, + DO = 265, + ELSE = 266, + ELSIF = 267, + END = 268, + FALSE = 269, + FOR = 270, + IF = 271, + IMPORT = 272, + IN = 273, + IS = 274, + MOD = 275, + MODULE = 276, + NIL = 277, + OF = 278, + OR = 279, + POINTER = 280, + PROCEDURE = 281, + RECORD = 282, + REPEAT = 283, + RETURN = 284, + THEN = 285, + TO = 286, + TRUE = 287, + TYPE = 288, + UNTIL = 289, + VAR = 290, + WHILE = 291, + BECOMES = 292, + DOTDOT = 293, + GE = 294, + LE = 295, + IDENT = 296, + INTEGER = 297, + REAL = 298, + STRING = 299, + TOKEN_END = 300 + }; +#endif +/* Tokens. */ +#define TOKEN_START 258 +#define ARRAY 259 +#define BEGIN_ 260 +#define BY 261 +#define CASE 262 +#define CONST 263 +#define DIV 264 +#define DO 265 +#define ELSE 266 +#define ELSIF 267 +#define END 268 +#define FALSE 269 +#define FOR 270 +#define IF 271 +#define IMPORT 272 +#define IN 273 +#define IS 274 +#define MOD 275 +#define MODULE 276 +#define NIL 277 +#define OF 278 +#define OR 279 +#define POINTER 280 +#define PROCEDURE 281 +#define RECORD 282 +#define REPEAT 283 +#define RETURN 284 +#define THEN 285 +#define TO 286 +#define TRUE 287 +#define TYPE 288 +#define UNTIL 289 +#define VAR 290 +#define WHILE 291 +#define BECOMES 292 +#define DOTDOT 293 +#define GE 294 +#define LE 295 +#define IDENT 296 +#define INTEGER 297 +#define REAL 298 +#define STRING 299 +#define TOKEN_END 300 + +/* Value type. */ +#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED + +union YYSTYPE +{ +#line 107 "Oberon.y" /* yacc.c:352 */ + + const char *ident; + OBNC_INTEGER integer; + OBNC_REAL real; + const char *string; + Trees_Node node; + +#line 300 "y.tab.c" /* yacc.c:352 */ +}; + +typedef union YYSTYPE YYSTYPE; +# define YYSTYPE_IS_TRIVIAL 1 +# define YYSTYPE_IS_DECLARED 1 +#endif + + +extern YYSTYPE yylval; + +int yyparse (void); + +#endif /* !YY_YY_Y_TAB_H_INCLUDED */ + + + +#ifdef short +# undef short +#endif + +#ifdef YYTYPE_UINT8 +typedef YYTYPE_UINT8 yytype_uint8; +#else +typedef unsigned char yytype_uint8; +#endif + +#ifdef YYTYPE_INT8 +typedef YYTYPE_INT8 yytype_int8; +#else +typedef signed char yytype_int8; +#endif + +#ifdef YYTYPE_UINT16 +typedef YYTYPE_UINT16 yytype_uint16; +#else +typedef unsigned short yytype_uint16; +#endif + +#ifdef YYTYPE_INT16 +typedef YYTYPE_INT16 yytype_int16; +#else +typedef short yytype_int16; +#endif + +#ifndef YYSIZE_T +# ifdef __SIZE_TYPE__ +# define YYSIZE_T __SIZE_TYPE__ +# elif defined size_t +# define YYSIZE_T size_t +# elif ! defined YYSIZE_T +# include /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# else +# define YYSIZE_T unsigned +# endif +#endif + +#define YYSIZE_MAXIMUM ((YYSIZE_T) -1) + +#ifndef YY_ +# if defined YYENABLE_NLS && YYENABLE_NLS +# if ENABLE_NLS +# include /* INFRINGES ON USER NAME SPACE */ +# define YY_(Msgid) dgettext ("bison-runtime", Msgid) +# endif +# endif +# ifndef YY_ +# define YY_(Msgid) Msgid +# endif +#endif + +#ifndef YY_ATTRIBUTE +# if (defined __GNUC__ \ + && (2 < __GNUC__ || (__GNUC__ == 2 && 96 <= __GNUC_MINOR__))) \ + || defined __SUNPRO_C && 0x5110 <= __SUNPRO_C +# define YY_ATTRIBUTE(Spec) __attribute__(Spec) +# else +# define YY_ATTRIBUTE(Spec) /* empty */ +# endif +#endif + +#ifndef YY_ATTRIBUTE_PURE +# define YY_ATTRIBUTE_PURE YY_ATTRIBUTE ((__pure__)) +#endif + +#ifndef YY_ATTRIBUTE_UNUSED +# define YY_ATTRIBUTE_UNUSED YY_ATTRIBUTE ((__unused__)) +#endif + +/* Suppress unused-variable warnings by "using" E. */ +#if ! defined lint || defined __GNUC__ +# define YYUSE(E) ((void) (E)) +#else +# define YYUSE(E) /* empty */ +#endif + +#if defined __GNUC__ && ! defined __ICC && 407 <= __GNUC__ * 100 + __GNUC_MINOR__ +/* Suppress an incorrect diagnostic about yylval being uninitialized. */ +# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \ + _Pragma ("GCC diagnostic push") \ + _Pragma ("GCC diagnostic ignored \"-Wuninitialized\"")\ + _Pragma ("GCC diagnostic ignored \"-Wmaybe-uninitialized\"") +# define YY_IGNORE_MAYBE_UNINITIALIZED_END \ + _Pragma ("GCC diagnostic pop") +#else +# define YY_INITIAL_VALUE(Value) Value +#endif +#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_END +#endif +#ifndef YY_INITIAL_VALUE +# define YY_INITIAL_VALUE(Value) /* Nothing. */ +#endif + + +#if ! defined yyoverflow || YYERROR_VERBOSE + +/* The parser invokes alloca or malloc; define the necessary symbols. */ + +# ifdef YYSTACK_USE_ALLOCA +# if YYSTACK_USE_ALLOCA +# ifdef __GNUC__ +# define YYSTACK_ALLOC __builtin_alloca +# elif defined __BUILTIN_VA_ARG_INCR +# include /* INFRINGES ON USER NAME SPACE */ +# elif defined _AIX +# define YYSTACK_ALLOC __alloca +# elif defined _MSC_VER +# include /* INFRINGES ON USER NAME SPACE */ +# define alloca _alloca +# else +# define YYSTACK_ALLOC alloca +# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS +# include /* INFRINGES ON USER NAME SPACE */ + /* Use EXIT_SUCCESS as a witness for stdlib.h. */ +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 +# endif +# endif +# endif +# endif +# endif + +# ifdef YYSTACK_ALLOC + /* Pacify GCC's 'empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0) +# ifndef YYSTACK_ALLOC_MAXIMUM + /* The OS might guarantee only one guard page at the bottom of the stack, + and a page size can be as small as 4096 bytes. So we cannot safely + invoke alloca (N) if N exceeds 4096. Use a slightly smaller number + to allow for a few compiler-allocated temporary stack slots. */ +# define YYSTACK_ALLOC_MAXIMUM 4032 /* reasonable circa 2006 */ +# endif +# else +# define YYSTACK_ALLOC YYMALLOC +# define YYSTACK_FREE YYFREE +# ifndef YYSTACK_ALLOC_MAXIMUM +# define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM +# endif +# if (defined __cplusplus && ! defined EXIT_SUCCESS \ + && ! ((defined YYMALLOC || defined malloc) \ + && (defined YYFREE || defined free))) +# include /* INFRINGES ON USER NAME SPACE */ +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 +# endif +# endif +# ifndef YYMALLOC +# define YYMALLOC malloc +# if ! defined malloc && ! defined EXIT_SUCCESS +void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# ifndef YYFREE +# define YYFREE free +# if ! defined free && ! defined EXIT_SUCCESS +void free (void *); /* INFRINGES ON USER NAME SPACE */ +# endif +# endif +# endif +#endif /* ! defined yyoverflow || YYERROR_VERBOSE */ + + +#if (! defined yyoverflow \ + && (! defined __cplusplus \ + || (defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) + +/* A type that is properly aligned for any stack member. */ +union yyalloc +{ + yytype_int16 yyss_alloc; + YYSTYPE yyvs_alloc; +}; + +/* The size of the maximum gap between one aligned stack and the next. */ +# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1) + +/* The size of an array large to enough to hold all stacks, each with + N elements. */ +# define YYSTACK_BYTES(N) \ + ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE)) \ + + YYSTACK_GAP_MAXIMUM) + +# define YYCOPY_NEEDED 1 + +/* Relocate STACK from its old location to the new one. The + local variables YYSIZE and YYSTACKSIZE give the old and new number of + elements in the stack, and YYPTR gives the new location of the + stack. Advance YYPTR to a properly aligned location for the next + stack. */ +# define YYSTACK_RELOCATE(Stack_alloc, Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \ + Stack = &yyptr->Stack_alloc; \ + yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (0) + +#endif + +#if defined YYCOPY_NEEDED && YYCOPY_NEEDED +/* Copy COUNT objects from SRC to DST. The source and destination do + not overlap. */ +# ifndef YYCOPY +# if defined __GNUC__ && 1 < __GNUC__ +# define YYCOPY(Dst, Src, Count) \ + __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src))) +# else +# define YYCOPY(Dst, Src, Count) \ + do \ + { \ + YYSIZE_T yyi; \ + for (yyi = 0; yyi < (Count); yyi++) \ + (Dst)[yyi] = (Src)[yyi]; \ + } \ + while (0) +# endif +# endif +#endif /* !YYCOPY_NEEDED */ + +/* YYFINAL -- State number of the termination state. */ +#define YYFINAL 5 +/* YYLAST -- Last index in YYTABLE. */ +#define YYLAST 236 + +/* YYNTOKENS -- Number of terminals. */ +#define YYNTOKENS 68 +/* YYNNTS -- Number of nonterminals. */ +#define YYNNTS 97 +/* YYNRULES -- Number of rules. */ +#define YYNRULES 181 +/* YYNSTATES -- Number of states. */ +#define YYNSTATES 284 + +#define YYUNDEFTOK 2 +#define YYMAXUTOK 300 + +/* YYTRANSLATE(TOKEN-NUM) -- Symbol number corresponding to TOKEN-NUM + as returned by yylex, with out-of-bounds checking. */ +#define YYTRANSLATE(YYX) \ + ((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) + +/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM + as returned by yylex. */ +static const yytype_uint8 yytranslate[] = +{ + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 54, 2, 2, 60, 2, + 50, 51, 47, 57, 49, 58, 46, 59, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 53, 52, + 55, 48, 56, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 62, 2, 63, 64, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 65, 67, 66, 61, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 2, 3, 4, + 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, + 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, + 45 +}; + +#if YYDEBUG + /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */ +static const yytype_uint16 yyrline[] = +{ + 0, 221, 221, 225, 232, 250, 255, 264, 268, 278, + 294, 309, 332, 342, 343, 344, 345, 346, 350, 370, + 380, 384, 391, 411, 419, 430, 435, 441, 482, 488, + 494, 498, 526, 575, 579, 589, 624, 633, 640, 647, + 649, 658, 696, 697, 744, 748, 752, 756, 760, 764, + 768, 772, 779, 801, 830, 834, 839, 845, 849, 853, + 860, 861, 891, 895, 899, 903, 907, 914, 915, 919, + 924, 928, 932, 938, 958, 963, 984, 1004, 1023, 1029, + 1037, 1055, 1060, 1065, 1072, 1076, 1083, 1084, 1097, 1117, + 1141, 1146, 1160, 1161, 1162, 1163, 1164, 1165, 1166, 1168, + 1174, 1217, 1235, 1243, 1251, 1262, 1285, 1298, 1303, 1309, + 1314, 1320, 1341, 1379, 1387, 1402, 1408, 1414, 1418, 1434, + 1443, 1490, 1499, 1513, 1598, 1605, 1610, 1616, 1631, 1649, + 1675, 1686, 1704, 1713, 1763, 1784, 1799, 1804, 1810, 1815, + 1821, 1825, 1826, 1830, 1831, 1835, 1847, 1853, 1860, 1861, + 1865, 1866, 1870, 1871, 1875, 1876, 1880, 1887, 1893, 1899, + 1904, 1937, 1957, 1963, 1982, 1987, 1993, 1997, 2018, 2034, + 2039, 2048, 2075, 2089, 2096, 2104, 2140, 2148, 2159, 2234, + 2239, 2245 +}; +#endif + +#if YYDEBUG || YYERROR_VERBOSE || 1 +/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. + First, the terminals, then, starting at YYNTOKENS, nonterminals. */ +static const char *const yytname[] = +{ + "$end", "error", "$undefined", "TOKEN_START", "ARRAY", "BEGIN_", "BY", + "CASE", "CONST", "DIV", "DO", "ELSE", "ELSIF", "END", "FALSE", "FOR", + "IF", "IMPORT", "IN", "IS", "MOD", "MODULE", "NIL", "OF", "OR", + "POINTER", "PROCEDURE", "RECORD", "REPEAT", "RETURN", "THEN", "TO", + "TRUE", "TYPE", "UNTIL", "VAR", "WHILE", "BECOMES", "DOTDOT", "GE", "LE", + "IDENT", "INTEGER", "REAL", "STRING", "TOKEN_END", "'.'", "'*'", "'='", + "','", "'('", "')'", "';'", "':'", "'#'", "'<'", "'>'", "'+'", "'-'", + "'/'", "'&'", "'~'", "'['", "']'", "'^'", "'{'", "'}'", "'|'", "$accept", + "qualident", "identdef", "ExportMarkOpt", "number", "ConstDeclaration", + "ConstExpression", "TypeDeclaration", "TypeIdentDef", "type", + "ArrayType", "ArrayLengthOf", "LengthRep", "length", "RecordType", + "RecordHeading", "BaseTypeOpt", "BaseType", "FieldListSequenceOpt", + "FieldListSequence", "FieldList", "IdentList", "PointerType", + "PointerTo", "ProcedureType", "ProcedureTypeSansParam", + "FormalParametersOpt", "VariableDeclaration", "expression", "relation", + "SimpleExpression", "SignOpt", "AddOperator", "term", "MulOperator", + "factor", "designator", "SelectorOptRep", "selector", "set", + "ElementRep", "element", "ExpList", "statement", "assignment", + "ProcedureCall", "StatementSequence", "StatementSequenceReversed", + "IfStatement", "guard", "ElseIfThenOptRep", "ElseOpt", "CaseStatement", + "CaseExpression", "CaseRep", "case", "CaseLabelList", "LabelRange", + "label", "WhileStatement", "ElseIfDoOptRep", "RepeatStatement", + "ForStatement", "ForInit", "ForLimit", "ByOpt", "ProcedureDeclaration", + "ProcedureHeading", "ProcedureHeadingSansParam", "StatementSequenceOpt", + "ReturnExpressionOpt", "DeclarationSequence", "ConstSectionOpt", + "ConstDeclarationOptRep", "TypeSectionOpt", "TypeKeyword", + "TypeDeclarationOptRep", "VariableSectionOpt", + "VariableDeclarationOptRep", "ProcedureDeclarationOptRep", + "FormalParameters", "FPSectionsOpt", "FPSectionRep", "ResultTypeOpt", + "FPSection", "ParameterKindOpt", "IdentRep", "FormalType", + "OpenArrayOptRep", "module", "ModuleHeading", "ImportListOpt", + "ImportList", "ImportRep", "import", "BecomesIdentOpt", + "ModuleStatements", YY_NULLPTR +}; +#endif + +# ifdef YYPRINT +/* YYTOKNUM[NUM] -- (External) token number corresponding to the + (internal) symbol number NUM (which must be that of a token). */ +static const yytype_uint16 yytoknum[] = +{ + 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 272, 273, 274, + 275, 276, 277, 278, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 46, 42, 61, 44, + 40, 41, 59, 58, 35, 60, 62, 43, 45, 47, + 38, 126, 91, 93, 94, 123, 125, 124 +}; +# endif + +#define YYPACT_NINF -132 + +#define yypact_value_is_default(Yystate) \ + (!!((Yystate) == (-132))) + +#define YYTABLE_NINF -166 + +#define yytable_value_is_error(Yytable_value) \ + 0 + + /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing + STATE-NUM. */ +static const yytype_int16 yypact[] = +{ + -5, -21, 49, -8, -132, -132, 37, 19, 54, -132, + 36, 46, -132, -132, 75, 61, 58, -132, 19, -132, + 68, 100, -132, 98, -132, 90, -132, -132, -132, 70, + 79, 80, 29, 92, 29, 100, 29, -132, 94, -132, + -132, -132, -132, 83, -132, -132, -132, -132, -132, 93, + -132, -132, 68, -132, -132, 29, -132, -132, -132, -132, + 64, 9, 114, 101, 108, -132, 110, 109, 132, -32, + 29, 100, 99, 68, 118, 103, 95, 20, -132, -132, + -132, -132, -132, -132, -132, -132, -132, -132, -132, -132, + -132, 29, 9, -132, -132, -132, -132, -132, -132, 29, + 9, -24, -132, 8, -132, -132, -132, 82, 29, 29, + 100, 29, 100, 105, 7, 29, -132, -132, -132, -132, + -132, -132, -27, 96, 68, 97, 104, 111, -132, -132, + 29, 119, -132, 113, 106, -132, -132, -132, 20, -132, + 68, -132, 20, -132, 111, 33, 8, 107, -132, -132, + 115, -37, -132, -132, -132, -132, -132, -132, 9, -132, + -132, -132, -4, -132, 23, -132, 116, -132, -132, 149, + -132, -132, -132, -132, -132, -132, -12, -36, 68, 20, + -132, -132, -132, 54, -20, -132, -132, -132, -13, -132, + -132, 124, -132, 125, -132, 146, 126, -132, 43, -132, + -132, -132, 29, 29, -132, -132, -132, 82, 82, 100, + 82, 29, 150, 102, 117, 29, -132, -132, -132, -132, + 75, -132, 120, 127, -132, 128, -132, 29, -132, 129, + -132, -132, 68, 20, -132, -132, -132, -132, -132, -132, + -132, 100, 100, 29, 154, 29, -132, -132, 139, 123, + 135, -132, 44, -132, -132, -132, -132, 164, -132, 152, + -132, 173, 29, 171, 124, -132, -132, 145, -132, -132, + 100, 100, -132, 147, -132, -132, -132, 15, -132, -132, + -132, 166, -132, -132 +}; + + /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM. + Performed when YYTABLE does not specify something else to do. Zero + means the default is an error. */ +static const yytype_uint8 yydefact[] = +{ + 0, 0, 0, 0, 172, 1, 174, 0, 142, 173, + 180, 0, 176, 144, 137, 146, 0, 178, 0, 175, + 141, 99, 181, 0, 147, 151, 149, 179, 177, 6, + 0, 0, 56, 0, 56, 99, 56, 78, 101, 103, + 92, 93, 136, 102, 94, 95, 96, 97, 98, 0, + 153, 155, 145, 5, 4, 56, 143, 54, 55, 112, + 42, 0, 0, 0, 0, 106, 0, 0, 0, 76, + 56, 99, 0, 150, 140, 0, 0, 0, 9, 10, + 50, 51, 59, 49, 47, 44, 45, 46, 48, 57, + 58, 56, 0, 71, 69, 70, 7, 8, 68, 56, + 0, 56, 67, 52, 60, 73, 72, 116, 56, 56, + 99, 56, 99, 0, 56, 56, 81, 77, 100, 104, + 171, 33, 0, 0, 0, 0, 0, 40, 12, 148, + 56, 0, 38, 26, 2, 13, 11, 14, 0, 15, + 29, 16, 0, 17, 40, 43, 53, 0, 75, 84, + 88, 0, 86, 64, 65, 62, 63, 66, 0, 121, + 122, 123, 0, 113, 0, 117, 119, 129, 130, 132, + 108, 127, 126, 79, 83, 90, 0, 0, 0, 0, + 152, 135, 154, 142, 158, 134, 39, 22, 0, 20, + 36, 0, 24, 0, 18, 0, 28, 30, 0, 35, + 37, 74, 56, 56, 85, 61, 111, 116, 0, 99, + 0, 56, 0, 110, 0, 56, 82, 80, 34, 41, + 137, 164, 0, 157, 159, 0, 19, 56, 27, 0, + 3, 23, 0, 0, 89, 87, 114, 118, 115, 120, + 131, 99, 99, 56, 0, 56, 124, 91, 139, 162, + 165, 166, 0, 21, 25, 31, 32, 0, 109, 0, + 105, 0, 56, 0, 0, 156, 160, 0, 170, 128, + 99, 99, 138, 0, 161, 167, 163, 0, 107, 125, + 133, 0, 168, 169 +}; + + /* YYPGOTO[NTERM-NUM]. */ +static const yytype_int16 yypgoto[] = +{ + -132, -102, -14, -132, -132, -132, -54, -132, -132, -131, + -132, -132, -132, -40, -132, -132, -132, -132, -132, -132, + -42, 121, -132, -132, -132, -132, 47, -132, -30, -132, + 112, -132, -132, 122, -132, -92, -57, -132, -132, -132, + -132, -11, 78, 130, -132, -132, -35, -132, -132, -33, + -132, -132, -132, -132, -132, -9, -132, -6, -15, -132, + -132, -132, -132, -132, -132, -132, -132, -132, -132, -16, + -132, 13, -132, -132, -132, -132, -132, -132, -132, -132, + -132, -132, -132, -132, -51, -132, -132, -132, -132, -132, + -132, -132, -132, -132, 182, -132, -132 +}; + + /* YYDEFGOTO[NTERM-NUM]. */ +static const yytype_int16 yydefgoto[] = +{ + -1, 135, 121, 54, 102, 31, 187, 76, 77, 136, + 137, 138, 188, 189, 139, 140, 192, 229, 195, 196, + 197, 198, 141, 142, 143, 144, 185, 123, 65, 91, + 60, 61, 92, 103, 158, 104, 38, 69, 117, 106, + 151, 152, 176, 39, 40, 41, 42, 43, 44, 66, + 213, 244, 45, 62, 162, 163, 164, 165, 166, 46, + 214, 47, 48, 64, 169, 212, 125, 126, 127, 22, + 263, 14, 15, 20, 25, 26, 52, 51, 73, 74, + 186, 222, 223, 265, 224, 225, 252, 276, 277, 2, + 3, 8, 9, 11, 12, 17, 23 +}; + + /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If + positive, shift that token. If negative, reduce the rule whose + number is the opposite. If YYTABLE_NINF, syntax error. */ +static const yytype_int16 yytable[] = +{ + 67, 78, 59, 68, 105, 161, 30, 194, 148, 206, + 226, 199, 203, 215, 113, 221, 1, 153, 114, 281, + 4, -165, 178, 93, 130, 79, 179, 217, 154, 204, + 115, 94, 116, 57, 58, 105, 227, 215, 75, 216, + 118, 95, 149, 105, 6, 131, 132, 133, 219, 5, + 37, 96, 97, 98, 7, 155, 134, 82, 174, 99, + 10, 134, 13, 207, 57, 58, 205, 156, 157, 147, + 100, 150, 208, 16, 101, 170, 209, 172, 167, 168, + 21, 171, 80, 81, 175, 175, 57, 58, 82, 228, + 89, 90, 178, 267, 24, 18, 233, 268, 19, 27, + 79, 105, 256, 83, 84, 161, 161, 32, 161, 29, + 181, 49, 85, 242, 243, 33, 34, 53, 86, 87, + 88, 89, 90, 134, 159, 50, 160, 55, 35, 245, + 246, 70, 56, 63, 72, 71, 36, 107, 108, 109, + 110, 37, 112, 111, 124, 120, 173, 129, 180, 182, + 190, 128, 193, 202, 210, 211, 183, 240, 201, 231, + 241, 184, 274, 191, 218, 134, 230, 260, 262, 251, + 221, 249, 234, 150, 238, 282, 264, 269, 232, 250, + 254, 79, 270, 271, 273, 247, 275, 253, 280, 283, + 255, 200, 235, 177, 122, 239, 220, 79, 236, 266, + 28, 119, 237, 145, 248, 0, 257, 258, 0, 0, + 259, 0, 261, 0, 146, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 272, 0, 0, 278, 279 +}; + +static const yytype_int16 yycheck[] = +{ + 35, 55, 32, 36, 61, 107, 20, 138, 100, 13, + 23, 142, 49, 49, 46, 35, 21, 9, 50, 4, + 41, 41, 49, 14, 4, 55, 53, 63, 20, 66, + 62, 22, 64, 57, 58, 92, 49, 49, 52, 51, + 70, 32, 66, 100, 52, 25, 26, 27, 179, 0, + 41, 42, 43, 44, 17, 47, 41, 24, 51, 50, + 41, 41, 8, 67, 57, 58, 158, 59, 60, 99, + 61, 101, 49, 37, 65, 110, 53, 112, 108, 109, + 5, 111, 18, 19, 114, 115, 57, 58, 24, 191, + 57, 58, 49, 49, 33, 49, 53, 53, 52, 41, + 130, 158, 233, 39, 40, 207, 208, 7, 210, 41, + 124, 13, 48, 11, 12, 15, 16, 47, 54, 55, + 56, 57, 58, 41, 42, 35, 44, 48, 28, 12, + 13, 37, 52, 41, 41, 52, 36, 23, 37, 31, + 30, 41, 10, 34, 26, 46, 41, 52, 52, 52, + 31, 48, 46, 38, 38, 6, 52, 211, 51, 13, + 10, 50, 264, 50, 178, 41, 41, 13, 29, 41, + 35, 51, 202, 203, 209, 277, 53, 13, 52, 52, + 51, 211, 30, 10, 13, 215, 41, 227, 41, 23, + 232, 144, 203, 115, 73, 210, 183, 227, 207, 250, + 18, 71, 208, 91, 220, -1, 241, 242, -1, -1, + 243, -1, 245, -1, 92, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 262, -1, -1, 270, 271 +}; + + /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing + symbol of state STATE-NUM. */ +static const yytype_uint8 yystos[] = +{ + 0, 21, 157, 158, 41, 0, 52, 17, 159, 160, + 41, 161, 162, 8, 139, 140, 37, 163, 49, 52, + 141, 5, 137, 164, 33, 142, 143, 41, 162, 41, + 70, 73, 7, 15, 16, 28, 36, 41, 104, 111, + 112, 113, 114, 115, 116, 120, 127, 129, 130, 13, + 35, 145, 144, 47, 71, 48, 52, 57, 58, 96, + 98, 99, 121, 41, 131, 96, 117, 114, 117, 105, + 37, 52, 41, 146, 147, 70, 75, 76, 74, 96, + 18, 19, 24, 39, 40, 48, 54, 55, 56, 57, + 58, 97, 100, 14, 22, 32, 42, 43, 44, 50, + 61, 65, 72, 101, 103, 104, 107, 23, 37, 31, + 30, 34, 10, 46, 50, 62, 64, 106, 96, 111, + 46, 70, 89, 95, 26, 134, 135, 136, 48, 52, + 4, 25, 26, 27, 41, 69, 77, 78, 79, 82, + 83, 90, 91, 92, 93, 98, 101, 96, 103, 66, + 96, 108, 109, 9, 20, 47, 59, 60, 102, 42, + 44, 69, 122, 123, 124, 125, 126, 96, 96, 132, + 114, 96, 114, 41, 51, 96, 110, 110, 49, 53, + 52, 70, 52, 52, 50, 94, 148, 74, 80, 81, + 31, 50, 84, 46, 77, 86, 87, 88, 89, 77, + 94, 51, 38, 49, 66, 103, 13, 67, 49, 53, + 38, 6, 133, 118, 128, 49, 51, 63, 70, 77, + 139, 35, 149, 150, 152, 153, 23, 49, 69, 85, + 41, 13, 52, 53, 96, 109, 123, 125, 114, 126, + 74, 10, 11, 12, 119, 12, 13, 96, 137, 51, + 52, 41, 154, 81, 51, 88, 77, 114, 114, 117, + 13, 117, 29, 138, 53, 151, 152, 49, 53, 13, + 30, 10, 96, 13, 69, 41, 155, 156, 114, 114, + 41, 4, 69, 23 +}; + + /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const yytype_uint8 yyr1[] = +{ + 0, 68, 69, 69, 70, 71, 71, 72, 72, 73, + 74, 75, 76, 77, 77, 77, 77, 77, 78, 79, + 80, 80, 81, 82, 83, 84, 84, 85, 86, 86, + 87, 87, 88, 89, 89, 90, 91, 92, 93, 94, + 94, 95, 96, 96, 97, 97, 97, 97, 97, 97, + 97, 97, 98, 98, 99, 99, 99, 100, 100, 100, + 101, 101, 102, 102, 102, 102, 102, 103, 103, 103, + 103, 103, 103, 103, 103, 103, 104, 105, 105, 106, + 106, 106, 106, 106, 107, 107, 108, 108, 109, 109, + 110, 110, 111, 111, 111, 111, 111, 111, 111, 111, + 112, 113, 114, 115, 115, 116, 117, 118, 118, 119, + 119, 120, 121, 122, 122, 123, 123, 124, 124, 125, + 125, 126, 126, 126, 127, 128, 128, 129, 130, 131, + 132, 133, 133, 134, 135, 136, 137, 137, 138, 138, + 139, 140, 140, 141, 141, 142, 142, 143, 144, 144, + 145, 145, 146, 146, 147, 147, 148, 149, 149, 150, + 150, 151, 151, 152, 153, 153, 154, 154, 155, 156, + 156, 157, 158, 159, 159, 160, 161, 161, 162, 163, + 163, 164 +}; + + /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */ +static const yytype_uint8 yyr2[] = +{ + 0, 2, 1, 3, 2, 1, 0, 1, 1, 3, + 1, 2, 2, 1, 1, 1, 1, 1, 2, 3, + 1, 3, 1, 3, 2, 3, 0, 1, 1, 0, + 1, 3, 3, 1, 3, 2, 2, 2, 1, 1, + 0, 3, 1, 3, 1, 1, 1, 1, 1, 1, + 1, 1, 2, 3, 1, 1, 0, 1, 1, 1, + 1, 3, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 3, 2, 2, 2, 0, 2, + 3, 1, 3, 2, 2, 3, 1, 3, 1, 3, + 1, 3, 1, 1, 1, 1, 1, 1, 1, 0, + 3, 1, 1, 1, 3, 7, 1, 5, 0, 2, + 0, 5, 1, 1, 3, 3, 0, 1, 3, 1, + 3, 1, 1, 1, 6, 5, 0, 4, 8, 3, + 1, 2, 0, 7, 2, 2, 2, 0, 2, 0, + 4, 2, 0, 3, 0, 2, 0, 1, 3, 0, + 2, 0, 3, 0, 3, 0, 4, 1, 0, 1, + 3, 2, 0, 4, 1, 0, 1, 3, 2, 3, + 0, 8, 2, 1, 0, 3, 1, 3, 2, 2, + 0, 1 +}; + + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY (-2) +#define YYEOF 0 + +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrorlab + + +#define YYRECOVERING() (!!yyerrstatus) + +#define YYBACKUP(Token, Value) \ + do \ + if (yychar == YYEMPTY) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + YYPOPSTACK (yylen); \ + yystate = *yyssp; \ + goto yybackup; \ + } \ + else \ + { \ + yyerror (YY_("syntax error: cannot back up")); \ + YYERROR; \ + } \ + while (0) + +/* Error token number */ +#define YYTERROR 1 +#define YYERRCODE 256 + + + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# include /* INFRINGES ON USER NAME SPACE */ +# define YYFPRINTF fprintf +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (0) + +/* This macro is provided for backward compatibility. */ +#ifndef YY_LOCATION_PRINT +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) +#endif + + +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ +do { \ + if (yydebug) \ + { \ + YYFPRINTF (stderr, "%s ", Title); \ + yy_symbol_print (stderr, \ + Type, Value); \ + YYFPRINTF (stderr, "\n"); \ + } \ +} while (0) + + +/*-----------------------------------. +| Print this symbol's value on YYO. | +`-----------------------------------*/ + +static void +yy_symbol_value_print (FILE *yyo, int yytype, YYSTYPE const * const yyvaluep) +{ + FILE *yyoutput = yyo; + YYUSE (yyoutput); + if (!yyvaluep) + return; +# ifdef YYPRINT + if (yytype < YYNTOKENS) + YYPRINT (yyo, yytoknum[yytype], *yyvaluep); +# endif + YYUSE (yytype); +} + + +/*---------------------------. +| Print this symbol on YYO. | +`---------------------------*/ + +static void +yy_symbol_print (FILE *yyo, int yytype, YYSTYPE const * const yyvaluep) +{ + YYFPRINTF (yyo, "%s %s (", + yytype < YYNTOKENS ? "token" : "nterm", yytname[yytype]); + + yy_symbol_value_print (yyo, yytype, yyvaluep); + YYFPRINTF (yyo, ")"); +} + +/*------------------------------------------------------------------. +| yy_stack_print -- Print the state stack from its BOTTOM up to its | +| TOP (included). | +`------------------------------------------------------------------*/ + +static void +yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop) +{ + YYFPRINTF (stderr, "Stack now"); + for (; yybottom <= yytop; yybottom++) + { + int yybot = *yybottom; + YYFPRINTF (stderr, " %d", yybot); + } + YYFPRINTF (stderr, "\n"); +} + +# define YY_STACK_PRINT(Bottom, Top) \ +do { \ + if (yydebug) \ + yy_stack_print ((Bottom), (Top)); \ +} while (0) + + +/*------------------------------------------------. +| Report that the YYRULE is going to be reduced. | +`------------------------------------------------*/ + +static void +yy_reduce_print (yytype_int16 *yyssp, YYSTYPE *yyvsp, int yyrule) +{ + unsigned long yylno = yyrline[yyrule]; + int yynrhs = yyr2[yyrule]; + int yyi; + YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", + yyrule - 1, yylno); + /* The symbols being reduced. */ + for (yyi = 0; yyi < yynrhs; yyi++) + { + YYFPRINTF (stderr, " $%d = ", yyi + 1); + yy_symbol_print (stderr, + yystos[yyssp[yyi + 1 - yynrhs]], + &yyvsp[(yyi + 1) - (yynrhs)] + ); + YYFPRINTF (stderr, "\n"); + } +} + +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (yyssp, yyvsp, Rule); \ +} while (0) + +/* Nonzero means print parse trace. It is left uninitialized so that + multiple parsers can coexist. */ +int yydebug; +#else /* !YYDEBUG */ +# define YYDPRINTF(Args) +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) +# define YY_STACK_PRINT(Bottom, Top) +# define YY_REDUCE_PRINT(Rule) +#endif /* !YYDEBUG */ + + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#ifndef YYINITDEPTH +# define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only + if the built-in stack extension method is used). + + Do not make this value too large; the results are undefined if + YYSTACK_ALLOC_MAXIMUM < YYSTACK_BYTES (YYMAXDEPTH) + evaluated with infinite-precision integer arithmetic. */ + +#ifndef YYMAXDEPTH +# define YYMAXDEPTH 10000 +#endif + + +#if YYERROR_VERBOSE + +# ifndef yystrlen +# if defined __GLIBC__ && defined _STRING_H +# define yystrlen strlen +# else +/* Return the length of YYSTR. */ +static YYSIZE_T +yystrlen (const char *yystr) +{ + YYSIZE_T yylen; + for (yylen = 0; yystr[yylen]; yylen++) + continue; + return yylen; +} +# endif +# endif + +# ifndef yystpcpy +# if defined __GLIBC__ && defined _STRING_H && defined _GNU_SOURCE +# define yystpcpy stpcpy +# else +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in + YYDEST. */ +static char * +yystpcpy (char *yydest, const char *yysrc) +{ + char *yyd = yydest; + const char *yys = yysrc; + + while ((*yyd++ = *yys++) != '\0') + continue; + + return yyd - 1; +} +# endif +# endif + +# ifndef yytnamerr +/* Copy to YYRES the contents of YYSTR after stripping away unnecessary + quotes and backslashes, so that it's suitable for yyerror. The + heuristic is that double-quoting is unnecessary unless the string + contains an apostrophe, a comma, or backslash (other than + backslash-backslash). YYSTR is taken from yytname. If YYRES is + null, do not copy; instead, return the length of what the result + would have been. */ +static YYSIZE_T +yytnamerr (char *yyres, const char *yystr) +{ + if (*yystr == '"') + { + YYSIZE_T yyn = 0; + char const *yyp = yystr; + + for (;;) + switch (*++yyp) + { + case '\'': + case ',': + goto do_not_strip_quotes; + + case '\\': + if (*++yyp != '\\') + goto do_not_strip_quotes; + else + goto append; + + append: + default: + if (yyres) + yyres[yyn] = *yyp; + yyn++; + break; + + case '"': + if (yyres) + yyres[yyn] = '\0'; + return yyn; + } + do_not_strip_quotes: ; + } + + if (! yyres) + return yystrlen (yystr); + + return (YYSIZE_T) (yystpcpy (yyres, yystr) - yyres); +} +# endif + +/* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message + about the unexpected token YYTOKEN for the state stack whose top is + YYSSP. + + Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is + not large enough to hold the message. In that case, also set + *YYMSG_ALLOC to the required number of bytes. Return 2 if the + required number of bytes is too large to store. */ +static int +yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, + yytype_int16 *yyssp, int yytoken) +{ + YYSIZE_T yysize0 = yytnamerr (YY_NULLPTR, yytname[yytoken]); + YYSIZE_T yysize = yysize0; + enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; + /* Internationalized format string. */ + const char *yyformat = YY_NULLPTR; + /* Arguments of yyformat. */ + char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; + /* Number of reported tokens (one for the "unexpected", one per + "expected"). */ + int yycount = 0; + + /* There are many possibilities here to consider: + - If this state is a consistent state with a default action, then + the only way this function was invoked is if the default action + is an error action. In that case, don't check for expected + tokens because there are none. + - The only way there can be no lookahead present (in yychar) is if + this state is a consistent state with a default action. Thus, + detecting the absence of a lookahead is sufficient to determine + that there is no unexpected or expected token to report. In that + case, just report a simple "syntax error". + - Don't assume there isn't a lookahead just because this state is a + consistent state with a default action. There might have been a + previous inconsistent state, consistent state with a non-default + action, or user semantic action that manipulated yychar. + - Of course, the expected token list depends on states to have + correct lookahead information, and it depends on the parser not + to perform extra reductions after fetching a lookahead from the + scanner and before detecting a syntax error. Thus, state merging + (from LALR or IELR) and default reductions corrupt the expected + token list. However, the list is correct for canonical LR with + one exception: it will still contain any token that will not be + accepted due to an error action in a later state. + */ + if (yytoken != YYEMPTY) + { + int yyn = yypact[*yyssp]; + yyarg[yycount++] = yytname[yytoken]; + if (!yypact_value_is_default (yyn)) + { + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. In other words, skip the first -YYN actions for + this state because they are default actions. */ + int yyxbegin = yyn < 0 ? -yyn : 0; + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn + 1; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yyx; + + for (yyx = yyxbegin; yyx < yyxend; ++yyx) + if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR + && !yytable_value_is_error (yytable[yyx + yyn])) + { + if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) + { + yycount = 1; + yysize = yysize0; + break; + } + yyarg[yycount++] = yytname[yyx]; + { + YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULLPTR, yytname[yyx]); + if (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM) + yysize = yysize1; + else + return 2; + } + } + } + } + + switch (yycount) + { +# define YYCASE_(N, S) \ + case N: \ + yyformat = S; \ + break + default: /* Avoid compiler warnings. */ + YYCASE_(0, YY_("syntax error")); + YYCASE_(1, YY_("syntax error, unexpected %s")); + YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s")); + YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s")); + YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s")); + YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s")); +# undef YYCASE_ + } + + { + YYSIZE_T yysize1 = yysize + yystrlen (yyformat); + if (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM) + yysize = yysize1; + else + return 2; + } + + if (*yymsg_alloc < yysize) + { + *yymsg_alloc = 2 * yysize; + if (! (yysize <= *yymsg_alloc + && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM)) + *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM; + return 1; + } + + /* Avoid sprintf, as that infringes on the user's name space. + Don't have undefined behavior even if the translation + produced a string with the wrong number of "%s"s. */ + { + char *yyp = *yymsg; + int yyi = 0; + while ((*yyp = *yyformat) != '\0') + if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount) + { + yyp += yytnamerr (yyp, yyarg[yyi++]); + yyformat += 2; + } + else + { + yyp++; + yyformat++; + } + } + return 0; +} +#endif /* YYERROR_VERBOSE */ + +/*-----------------------------------------------. +| Release the memory associated to this symbol. | +`-----------------------------------------------*/ + +static void +yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep) +{ + YYUSE (yyvaluep); + if (!yymsg) + yymsg = "Deleting"; + YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); + + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + YYUSE (yytype); + YY_IGNORE_MAYBE_UNINITIALIZED_END +} + + + + +/* The lookahead symbol. */ +int yychar; + +/* The semantic value of the lookahead symbol. */ +YYSTYPE yylval; +/* Number of syntax errors so far. */ +int yynerrs; + + +/*----------. +| yyparse. | +`----------*/ + +int +yyparse (void) +{ + int yystate; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; + + /* The stacks and their tools: + 'yyss': related to states. + 'yyvs': related to semantic values. + + Refer to the stacks through separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ + + /* The state stack. */ + yytype_int16 yyssa[YYINITDEPTH]; + yytype_int16 *yyss; + yytype_int16 *yyssp; + + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs; + YYSTYPE *yyvsp; + + YYSIZE_T yystacksize; + + int yyn; + int yyresult; + /* Lookahead token as an internal (translated) token number. */ + int yytoken = 0; + /* The variables used to return semantic value and location from the + action routines. */ + YYSTYPE yyval; + +#if YYERROR_VERBOSE + /* Buffer for error messages, and its allocated size. */ + char yymsgbuf[128]; + char *yymsg = yymsgbuf; + YYSIZE_T yymsg_alloc = sizeof yymsgbuf; +#endif + +#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N)) + + /* The number of symbols on the RHS of the reduced rule. + Keep to zero when no symbol should be popped. */ + int yylen = 0; + + yyssp = yyss = yyssa; + yyvsp = yyvs = yyvsa; + yystacksize = YYINITDEPTH; + + YYDPRINTF ((stderr, "Starting parse\n")); + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + goto yysetstate; + + +/*------------------------------------------------------------. +| yynewstate -- push a new state, which is found in yystate. | +`------------------------------------------------------------*/ +yynewstate: + /* In all cases, when you get here, the value and location stacks + have just been pushed. So pushing a state here evens the stacks. */ + yyssp++; + + +/*--------------------------------------------------------------------. +| yynewstate -- set current state (the top of the stack) to yystate. | +`--------------------------------------------------------------------*/ +yysetstate: + *yyssp = (yytype_int16) yystate; + + if (yyss + yystacksize - 1 <= yyssp) +#if !defined yyoverflow && !defined YYSTACK_RELOCATE + goto yyexhaustedlab; +#else + { + /* Get the current used size of the three stacks, in elements. */ + YYSIZE_T yysize = (YYSIZE_T) (yyssp - yyss + 1); + +# if defined yyoverflow + { + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + yytype_int16 *yyss1 = yyss; + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. This used to be a + conditional around just the two extra args, but that might + be undefined if yyoverflow is a macro. */ + yyoverflow (YY_("memory exhausted"), + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yystacksize); + yyss = yyss1; + yyvs = yyvs1; + } +# else /* defined YYSTACK_RELOCATE */ + /* Extend the stack our own way. */ + if (YYMAXDEPTH <= yystacksize) + goto yyexhaustedlab; + yystacksize *= 2; + if (YYMAXDEPTH < yystacksize) + yystacksize = YYMAXDEPTH; + + { + yytype_int16 *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyexhaustedlab; + YYSTACK_RELOCATE (yyss_alloc, yyss); + YYSTACK_RELOCATE (yyvs_alloc, yyvs); +# undef YYSTACK_RELOCATE + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); + } +# endif + + yyssp = yyss + yysize - 1; + yyvsp = yyvs + yysize - 1; + + YYDPRINTF ((stderr, "Stack size increased to %lu\n", + (unsigned long) yystacksize)); + + if (yyss + yystacksize - 1 <= yyssp) + YYABORT; + } +#endif /* !defined yyoverflow && !defined YYSTACK_RELOCATE */ + + YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + + if (yystate == YYFINAL) + YYACCEPT; + + goto yybackup; + + +/*-----------. +| yybackup. | +`-----------*/ +yybackup: + /* Do appropriate processing given the current state. Read a + lookahead token if we need one and don't already have one. */ + + /* First try to decide what to do without reference to lookahead token. */ + yyn = yypact[yystate]; + if (yypact_value_is_default (yyn)) + goto yydefault; + + /* Not known => get a lookahead token if don't already have one. */ + + /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ + if (yychar == YYEMPTY) + { + YYDPRINTF ((stderr, "Reading a token: ")); + yychar = yylex (); + } + + if (yychar <= YYEOF) + { + yychar = yytoken = YYEOF; + YYDPRINTF ((stderr, "Now at end of input.\n")); + } + else + { + yytoken = YYTRANSLATE (yychar); + YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc); + } + + /* If the proper action on seeing token YYTOKEN is to reduce or to + detect an error, take that action. */ + yyn += yytoken; + if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken) + goto yydefault; + yyn = yytable[yyn]; + if (yyn <= 0) + { + if (yytable_value_is_error (yyn)) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + + /* Count tokens shifted since error; after three, turn off error + status. */ + if (yyerrstatus) + yyerrstatus--; + + /* Shift the lookahead token. */ + YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); + + /* Discard the shifted token. */ + yychar = YYEMPTY; + + yystate = yyn; + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END + + goto yynewstate; + + +/*-----------------------------------------------------------. +| yydefault -- do the default action for the current state. | +`-----------------------------------------------------------*/ +yydefault: + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + goto yyreduce; + + +/*-----------------------------. +| yyreduce -- do a reduction. | +`-----------------------------*/ +yyreduce: + /* yyn is the number of a rule to reduce with. */ + yylen = yyr2[yyn]; + + /* If YYLEN is nonzero, implement the default value of the action: + '$$ = $1'. + + Otherwise, the following line sets YYVAL to garbage. + This behavior is undocumented and Bison + users should not rely upon it. Assigning to YYVAL + unconditionally makes the parser a bit smaller, and it avoids a + GCC warning that YYVAL may be used uninitialized. */ + yyval = yyvsp[1-yylen]; + + + YY_REDUCE_PRINT (yyn); + switch (yyn) + { + case 2: +#line 222 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewIdent((yyvsp[0].ident)); + } +#line 1626 "y.tab.c" /* yacc.c:1652 */ + break; + + case 3: +#line 226 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewIdent(Util_String("%s.%s", (yyvsp[-2].ident), (yyvsp[0].ident))); + } +#line 1634 "y.tab.c" /* yacc.c:1652 */ + break; + + case 4: +#line 233 "Oberon.y" /* yacc.c:1652 */ + { + if (! Table_LocallyDeclared((yyvsp[-1].ident)) || (recordDeclarationStack != NULL)) { + (yyval.node) = Trees_NewIdent((yyvsp[-1].ident)); + if ((yyvsp[0].integer)) { + Trees_SetExported((yyval.node)); + } + if (Table_ScopeLocal()) { + Trees_SetLocal((yyval.node)); + } + } else { + Oberon_PrintError("error: redeclaration of identifier: %s", (yyvsp[-1].ident)); + YYABORT; + } + } +#line 1653 "y.tab.c" /* yacc.c:1652 */ + break; + + case 5: +#line 251 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = 1; + } +#line 1661 "y.tab.c" /* yacc.c:1652 */ + break; + + case 6: +#line 255 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = 0; + } +#line 1669 "y.tab.c" /* yacc.c:1652 */ + break; + + case 7: +#line 265 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewInteger((yyvsp[0].integer)); + } +#line 1677 "y.tab.c" /* yacc.c:1652 */ + break; + + case 8: +#line 269 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewReal((yyvsp[0].real)); + } +#line 1685 "y.tab.c" /* yacc.c:1652 */ + break; + + case 9: +#line 279 "Oberon.y" /* yacc.c:1652 */ + { + if (! (Trees_Exported((yyvsp[-2].node)) && Trees_Local((yyvsp[-2].node)))) { + Trees_SetKind(TREES_CONSTANT_KIND, (yyvsp[-2].node)); + Trees_SetType(Trees_Type((yyvsp[0].node)), (yyvsp[-2].node)); + Trees_SetValue((yyvsp[0].node), (yyvsp[-2].node)); + Table_Put((yyvsp[-2].node)); + Generate_ConstDeclaration((yyvsp[-2].node)); + } else { + Oberon_PrintError("error: cannot export local constant: %s", Trees_Name((yyvsp[-2].node))); + YYABORT; + } + } +#line 1702 "y.tab.c" /* yacc.c:1652 */ + break; + + case 10: +#line 295 "Oberon.y" /* yacc.c:1652 */ + { + if (IsConstExpression((yyvsp[0].node))) { + (yyval.node) = (yyvsp[0].node); + } else { + Oberon_PrintError("error: constant expression expected"); + YYABORT; + } + } +#line 1715 "y.tab.c" /* yacc.c:1652 */ + break; + + case 11: +#line 310 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node sourceType; + + sourceType = ResolvedType((yyvsp[0].node), 1); + if (sourceType != NULL) { + if (! (Trees_Exported((yyvsp[-1].node)) && Trees_Local((yyvsp[-1].node)))) { + Trees_SetType(sourceType, (yyvsp[-1].node)); + ResolvePointerTypes((yyvsp[-1].node)); + currentTypeIdentdef = NULL; + Generate_TypeDeclaration((yyvsp[-1].node)); + } else { + Oberon_PrintError("error: cannot export local type: %s", Trees_Name((yyvsp[-1].node))); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + } +#line 1739 "y.tab.c" /* yacc.c:1652 */ + break; + + case 12: +#line 333 "Oberon.y" /* yacc.c:1652 */ + { + Trees_SetKind(TREES_TYPE_KIND, (yyvsp[-1].node)); + currentTypeIdentdef = (yyvsp[-1].node); + Table_Put((yyvsp[-1].node)); + (yyval.node) = (yyvsp[-1].node); + } +#line 1750 "y.tab.c" /* yacc.c:1652 */ + break; + + case 18: +#line 351 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node reversedLengths, length; + + (yyval.node) = ResolvedType((yyvsp[0].node), 0); + if ((yyval.node) != NULL) { + reversedLengths = (yyvsp[-1].node); + do { + length = Trees_Left(reversedLengths); + (yyval.node) = Types_NewArray(length, (yyval.node)); + reversedLengths = Trees_Right(reversedLengths); + } while (reversedLengths != NULL); + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name((yyvsp[0].node))); + exit(EXIT_FAILURE); + } + } +#line 1771 "y.tab.c" /* yacc.c:1652 */ + break; + + case 19: +#line 371 "Oberon.y" /* yacc.c:1652 */ + { + if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) { + Trees_SetType(Trees_NewLeaf(ARRAY), currentTypeIdentdef); /*incomplete type*/ + } + (yyval.node) = (yyvsp[-1].node); + } +#line 1782 "y.tab.c" /* yacc.c:1652 */ + break; + + case 20: +#line 381 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(TREES_NOSYM, (yyvsp[0].node), NULL); + } +#line 1790 "y.tab.c" /* yacc.c:1652 */ + break; + + case 21: +#line 385 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(TREES_NOSYM, (yyvsp[0].node), (yyvsp[-2].node)); + } +#line 1798 "y.tab.c" /* yacc.c:1652 */ + break; + + case 22: +#line 392 "Oberon.y" /* yacc.c:1652 */ + { + if (Types_IsInteger(Trees_Type((yyvsp[0].node)))) { + if (IsInteger((yyvsp[0].node))) { + if (Trees_Integer((yyvsp[0].node)) <= 0) { + Oberon_PrintError("error: positive length expected: %" OBNC_INT_MOD "d", Trees_Integer((yyvsp[0].node))); + YYABORT; + } + } else { + Oberon_PrintError("error: fully evaluated constant expression expected as increment"); + YYABORT; + } + } else { + Oberon_PrintError("error: integer length expected"); + YYABORT; + } + } +#line 1819 "y.tab.c" /* yacc.c:1652 */ + break; + + case 23: +#line 412 "Oberon.y" /* yacc.c:1652 */ + { + recordDeclarationStack = Trees_Right(recordDeclarationStack); + (yyval.node) = Types_NewRecord(Types_RecordBaseType((yyvsp[-2].node)), (yyvsp[-1].node)); + } +#line 1828 "y.tab.c" /* yacc.c:1652 */ + break; + + case 24: +#line 420 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Types_NewRecord((yyvsp[0].node), NULL); + if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) { + Trees_SetType((yyval.node), currentTypeIdentdef); + } + recordDeclarationStack = Trees_NewNode(TREES_NOSYM, (yyval.node), recordDeclarationStack); + } +#line 1840 "y.tab.c" /* yacc.c:1652 */ + break; + + case 25: +#line 431 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[-1].node); + } +#line 1848 "y.tab.c" /* yacc.c:1652 */ + break; + + case 26: +#line 435 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 1856 "y.tab.c" /* yacc.c:1652 */ + break; + + case 27: +#line 442 "Oberon.y" /* yacc.c:1652 */ + { + const char *name; + Trees_Node symbol; + + (yyval.node) = NULL; + name = Trees_Name((yyvsp[0].node)); + symbol = Table_At(name); + if (symbol != NULL) { + if (Trees_Kind(symbol) == TREES_TYPE_KIND) { + if (symbol != currentTypeIdentdef) { + switch (Trees_Symbol(Types_Structure(symbol))) { + case POINTER: + if (Types_Same(Types_PointerBaseType(symbol), currentTypeIdentdef)) { + Oberon_PrintError("error: self-referring base type: %s", name); + YYABORT; + } + /*fall through*/ + case RECORD: + (yyval.node) = symbol; + break; + default: + Oberon_PrintError("error: record or pointer base type expected: %s", name); + YYABORT; + } + } else { + Oberon_PrintError("error: self-referring base type: %s", name); + YYABORT; + } + } else { + Oberon_PrintError("error: type name expected: %s", name); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", name); + YYABORT; + } + } +#line 1898 "y.tab.c" /* yacc.c:1652 */ + break; + + case 28: +#line 483 "Oberon.y" /* yacc.c:1652 */ + { + Trees_ReverseList(&(yyvsp[0].node)); /*correct order*/ + (yyval.node) = (yyvsp[0].node); + } +#line 1907 "y.tab.c" /* yacc.c:1652 */ + break; + + case 29: +#line 488 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 1915 "y.tab.c" /* yacc.c:1652 */ + break; + + case 30: +#line 495 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(TREES_FIELD_LIST_SEQUENCE, (yyvsp[0].node), NULL); + } +#line 1923 "y.tab.c" /* yacc.c:1652 */ + break; + + case 31: +#line 499 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node currSeq, currList, currSeqList; + const char *seqIdentName, *listIdentName; + + currList = (yyvsp[0].node); + while (currList != NULL) { + listIdentName = Trees_Name(Trees_Left(currList)); + currSeq = (yyvsp[-2].node); + while (currSeq != NULL) { + currSeqList = Trees_Left(currSeq); + while (currSeqList != NULL) { + seqIdentName = Trees_Name(Trees_Left(currSeqList)); + if (strcmp(listIdentName, seqIdentName) == 0) { + Oberon_PrintError("error: redeclaration of field: %s", listIdentName); + YYABORT; + } + currSeqList = Trees_Right(currSeqList); + } + currSeq = Trees_Right(currSeq); + } + currList = Trees_Right(currList); + } + (yyval.node) = Trees_NewNode(TREES_FIELD_LIST_SEQUENCE, (yyvsp[0].node), (yyvsp[-2].node)); + } +#line 1952 "y.tab.c" /* yacc.c:1652 */ + break; + + case 32: +#line 527 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node type, tail, ident, p, directBaseType, baseTypeField, baseType; + + (yyval.node) = NULL; + type = ResolvedType((yyvsp[0].node), 0); + if (type != NULL) { + if (! ((type == currentTypeIdentdef) && ! Types_IsPointer(type))) { + Trees_ReverseList(&(yyvsp[-2].node)); /*correct order*/ + tail = (yyvsp[-2].node); + do { + ident = Trees_Left(tail); + p = (yyvsp[-2].node); + while ((p != tail) && (strcmp(Trees_Name(ident), Trees_Name(Trees_Left(p))) != 0)) { + p = Trees_Right(p); + } + if (p == tail) { + assert(recordDeclarationStack != NULL); + directBaseType = Types_RecordBaseType(Trees_Left(recordDeclarationStack)); + if (directBaseType != NULL) { + Types_GetFieldIdent(Trees_Name(ident), directBaseType, 0, &baseTypeField, &baseType); + } + if ((directBaseType == NULL) || (baseTypeField == NULL)) { + Trees_SetKind(TREES_FIELD_KIND, ident); + Trees_SetType(type, ident); + } else { + Oberon_PrintError("error: redeclaration of field: %s defined in %s", Trees_Name(ident), Trees_Name(baseType)); + YYABORT; + } + } else { + Oberon_PrintError("error: redeclaration of field: %s", Trees_Name(ident)); + YYABORT; + } + tail = Trees_Right(tail); + } while (tail != NULL); + + (yyval.node) = (yyvsp[-2].node); + } else { + Oberon_PrintError("error: recursive field type must be a pointer: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared type: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + } +#line 2002 "y.tab.c" /* yacc.c:1652 */ + break; + + case 33: +#line 576 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(TREES_IDENT_LIST, (yyvsp[0].node), NULL); + } +#line 2010 "y.tab.c" /* yacc.c:1652 */ + break; + + case 34: +#line 580 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node reversedIdents; + + reversedIdents = Trees_NewNode(TREES_IDENT_LIST, (yyvsp[0].node), (yyvsp[-2].node)); + (yyval.node) = reversedIdents; + } +#line 2021 "y.tab.c" /* yacc.c:1652 */ + break; + + case 35: +#line 590 "Oberon.y" /* yacc.c:1652 */ + { + const char *baseTypeName; + Trees_Node declaredBaseType; + + (yyval.node) = NULL; + if (Trees_Symbol((yyvsp[0].node)) == IDENT) { + baseTypeName = Trees_Name((yyvsp[0].node)); + declaredBaseType = Table_At(baseTypeName); + if (declaredBaseType != NULL) { + if (Types_IsRecord(declaredBaseType)) { + (yyval.node) = Types_NewPointer(declaredBaseType); + } else { + Oberon_PrintError("error: record expected as pointer base type: %s", baseTypeName); + YYABORT; + } + } else if (currentTypeIdentdef != NULL) { + Trees_SetKind(TREES_TYPE_KIND, (yyvsp[0].node)); + Trees_SetType(Types_NewRecord(NULL, NULL), (yyvsp[0].node)); + (yyval.node) = Types_NewPointer((yyvsp[0].node)); + unresolvedPointerTypes = Trees_NewNode(TREES_NOSYM, (yyval.node), unresolvedPointerTypes); + } else { + Oberon_PrintError("error: undeclared type: %s", baseTypeName); + YYABORT; + } + } else if(Trees_Symbol((yyvsp[0].node)) == RECORD) { + (yyval.node) = Types_NewPointer((yyvsp[0].node)); + } else { + Oberon_PrintError("error: record expected as pointer base type"); + YYABORT; + } + } +#line 2057 "y.tab.c" /* yacc.c:1652 */ + break; + + case 36: +#line 625 "Oberon.y" /* yacc.c:1652 */ + { + if ((currentTypeIdentdef != NULL) && (Trees_Type(currentTypeIdentdef) == NULL)) { + Trees_SetType(Types_NewPointer(NULL), currentTypeIdentdef); /*incomplete type*/ + } + } +#line 2067 "y.tab.c" /* yacc.c:1652 */ + break; + + case 37: +#line 634 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[0].node); + } +#line 2075 "y.tab.c" /* yacc.c:1652 */ + break; + + case 38: +#line 641 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 2083 "y.tab.c" /* yacc.c:1652 */ + break; + + case 40: +#line 649 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewLeaf(PROCEDURE); + } +#line 2091 "y.tab.c" /* yacc.c:1652 */ + break; + + case 41: +#line 659 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node type, identList, ident; + + type = ResolvedType((yyvsp[0].node), 0); + if (type != NULL) { + Trees_ReverseList(&(yyvsp[-2].node)); /*correct order*/ + identList = (yyvsp[-2].node); + do { + ident = Trees_Left(identList); + if (! (Trees_Exported(ident) && Trees_Local(ident))) { + if (! Table_LocallyDeclared(Trees_Name(ident))) { + Trees_SetKind(TREES_VARIABLE_KIND, ident); + Trees_SetType(type, ident); + Table_Put(ident); + } else { + Oberon_PrintError("error: redeclaration of identifier with the same name: %s", Trees_Name(ident)); + YYABORT; + } + } else { + Oberon_PrintError("error: cannot export local variable: %s", Trees_Name(ident)); + YYABORT; + } + identList = Trees_Right(identList); + } while (identList != NULL); + + Generate_VariableDeclaration((yyvsp[-2].node)); + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name((yyvsp[0].node))); + exit(EXIT_FAILURE); + } + } +#line 2127 "y.tab.c" /* yacc.c:1652 */ + break; + + case 43: +#line 698 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node expA, expB, typeA, typeB; + int op = (int) (yyvsp[-1].integer); + + expA = (yyvsp[-2].node); + expB = (yyvsp[0].node); + typeA = Trees_Type((yyvsp[-2].node)); + typeB = Trees_Type((yyvsp[0].node)); + + CheckIsValueExpression((yyvsp[-2].node)); + if (op == IS) { + if (IsDesignator((yyvsp[-2].node))) { + if (! (Types_IsRecord(typeA) && (Trees_Kind(BaseIdent((yyvsp[-2].node))) != TREES_VAR_PARAM_KIND))) { + expB = BaseIdent((yyvsp[0].node)); + typeB = BaseIdent((yyvsp[0].node)); + } else { + Oberon_PrintError("error: variable parameter expected as first operand of IS"); + YYABORT; + } + } else { + Oberon_PrintError("error: identifier expected as first operand of IS"); + YYABORT; + } + } else { + CheckIsValueExpression((yyvsp[0].node)); + } + if (Types_ExpressionCompatible(op, typeA, typeB)) { + (yyval.node) = ExpressionConstValue(op, expA, expB); + if ((yyval.node) == NULL) { + if (IsString(expA) && Types_IsChar(typeB)) { + expA = Trees_NewChar(Trees_String(expA)[0]); + } else if (Types_IsChar(typeA) && IsString(expB)) { + expB = Trees_NewChar(Trees_String(expB)[0]); + } + (yyval.node) = Trees_NewNode(op, expA, expB); + Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), (yyval.node)); + } + } else { + Oberon_PrintError("error: incompatible types in relation \"%s\": %s, %s", + OperatorString(op), TypeString(typeA), TypeString(typeB)); + YYABORT; + } + } +#line 2175 "y.tab.c" /* yacc.c:1652 */ + break; + + case 44: +#line 745 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '='; + } +#line 2183 "y.tab.c" /* yacc.c:1652 */ + break; + + case 45: +#line 749 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '#'; + } +#line 2191 "y.tab.c" /* yacc.c:1652 */ + break; + + case 46: +#line 753 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '<'; + } +#line 2199 "y.tab.c" /* yacc.c:1652 */ + break; + + case 47: +#line 757 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = LE; + } +#line 2207 "y.tab.c" /* yacc.c:1652 */ + break; + + case 48: +#line 761 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '>'; + } +#line 2215 "y.tab.c" /* yacc.c:1652 */ + break; + + case 49: +#line 765 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = GE; + } +#line 2223 "y.tab.c" /* yacc.c:1652 */ + break; + + case 50: +#line 769 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = IN; + } +#line 2231 "y.tab.c" /* yacc.c:1652 */ + break; + + case 51: +#line 773 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = IS; + } +#line 2239 "y.tab.c" /* yacc.c:1652 */ + break; + + case 52: +#line 780 "Oberon.y" /* yacc.c:1652 */ + { + int op = (int) (yyvsp[-1].integer); + (yyval.node) = (yyvsp[0].node); + if (op >= 0) { + CheckIsValueExpression((yyvsp[0].node)); + if (Types_ExpressionCompatible(op, Trees_Type((yyvsp[0].node)), NULL)) { + (yyval.node) = SimpleExpressionConstValue(op, (yyvsp[0].node), NULL); + if ((yyval.node) == NULL) { + (yyval.node) = Trees_NewNode(op, (yyvsp[0].node), NULL); + if (Types_IsByte(Trees_Type((yyvsp[0].node)))) { + Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), (yyval.node)); + } else { + Trees_SetType(Trees_Type((yyvsp[0].node)), (yyval.node)); + } + } + } else { + Oberon_PrintError("error: incompatible type in unary operation \"%s\": %s", OperatorString(op), TypeString(Trees_Type((yyvsp[0].node)))); + YYABORT; + } + } + } +#line 2265 "y.tab.c" /* yacc.c:1652 */ + break; + + case 53: +#line 802 "Oberon.y" /* yacc.c:1652 */ + { + int op = (int) (yyvsp[-1].integer); + + (yyval.node) = NULL; + + CheckIsValueExpression((yyvsp[-2].node)); + CheckIsValueExpression((yyvsp[0].node)); + + if (Types_ExpressionCompatible(op, Trees_Type((yyvsp[-2].node)), Trees_Type((yyvsp[0].node)))) { + (yyval.node) = SimpleExpressionConstValue(op, (yyvsp[-2].node), (yyvsp[0].node)); + if ((yyval.node) == NULL) { + (yyval.node) = Trees_NewNode(op, (yyvsp[-2].node), (yyvsp[0].node)); + if (Types_IsByte(Trees_Type((yyvsp[-2].node))) || Types_IsByte(Trees_Type((yyvsp[0].node)))) { + Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), (yyval.node)); + } else { + Trees_SetType(Trees_Type((yyvsp[-2].node)), (yyval.node)); + } + } + } else { + Oberon_PrintError("error: incompatible types in operation \"%s\": %s, %s", + OperatorString(op), TypeString(Trees_Type((yyvsp[-2].node))), TypeString(Trees_Type((yyvsp[0].node)))); + YYABORT; + } + assert((yyval.node) != NULL); + } +#line 2295 "y.tab.c" /* yacc.c:1652 */ + break; + + case 54: +#line 831 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '+'; + } +#line 2303 "y.tab.c" /* yacc.c:1652 */ + break; + + case 55: +#line 835 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '-'; + } +#line 2311 "y.tab.c" /* yacc.c:1652 */ + break; + + case 56: +#line 839 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = -1; + } +#line 2319 "y.tab.c" /* yacc.c:1652 */ + break; + + case 57: +#line 846 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '+'; + } +#line 2327 "y.tab.c" /* yacc.c:1652 */ + break; + + case 58: +#line 850 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '-'; + } +#line 2335 "y.tab.c" /* yacc.c:1652 */ + break; + + case 59: +#line 854 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = OR; + } +#line 2343 "y.tab.c" /* yacc.c:1652 */ + break; + + case 61: +#line 862 "Oberon.y" /* yacc.c:1652 */ + { + int op = (int) (yyvsp[-1].integer); + + (yyval.node) = NULL; + + CheckIsValueExpression((yyvsp[-2].node)); + CheckIsValueExpression((yyvsp[0].node)); + + if (Types_ExpressionCompatible(op, Trees_Type((yyvsp[-2].node)), Trees_Type((yyvsp[0].node)))) { + (yyval.node) = TermConstValue(op, (yyvsp[-2].node), (yyvsp[0].node)); + if ((yyval.node) == NULL) { + (yyval.node) = Trees_NewNode(op, (yyvsp[-2].node), (yyvsp[0].node)); + if (Types_IsByte(Trees_Type((yyvsp[-2].node))) || Types_IsByte(Trees_Type((yyvsp[0].node)))) { + Trees_SetType(Trees_NewLeaf(TREES_INTEGER_TYPE), (yyval.node)); + } else { + Trees_SetType(Trees_Type((yyvsp[-2].node)), (yyval.node)); + } + } + } else { + Oberon_PrintError("error: incompatible types in operation \"%s\": %s, %s", + OperatorString(op), TypeString(Trees_Type((yyvsp[-2].node))), TypeString(Trees_Type((yyvsp[0].node)))); + YYABORT; + } + + assert((yyval.node) != NULL); + } +#line 2374 "y.tab.c" /* yacc.c:1652 */ + break; + + case 62: +#line 892 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '*'; + } +#line 2382 "y.tab.c" /* yacc.c:1652 */ + break; + + case 63: +#line 896 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '/'; + } +#line 2390 "y.tab.c" /* yacc.c:1652 */ + break; + + case 64: +#line 900 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = DIV; + } +#line 2398 "y.tab.c" /* yacc.c:1652 */ + break; + + case 65: +#line 904 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = MOD; + } +#line 2406 "y.tab.c" /* yacc.c:1652 */ + break; + + case 66: +#line 908 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = '&'; + } +#line 2414 "y.tab.c" /* yacc.c:1652 */ + break; + + case 68: +#line 916 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewString((yyvsp[0].string)); + } +#line 2422 "y.tab.c" /* yacc.c:1652 */ + break; + + case 69: +#line 920 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewLeaf(NIL); + Trees_SetType(Trees_NewLeaf(TREES_NIL_TYPE), (yyval.node)); + } +#line 2431 "y.tab.c" /* yacc.c:1652 */ + break; + + case 70: +#line 925 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewBoolean(1); + } +#line 2439 "y.tab.c" /* yacc.c:1652 */ + break; + + case 71: +#line 929 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewBoolean(0); + } +#line 2447 "y.tab.c" /* yacc.c:1652 */ + break; + + case 72: +#line 933 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[0].node); + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), (yyval.node)); + } +#line 2456 "y.tab.c" /* yacc.c:1652 */ + break; + + case 73: +#line 939 "Oberon.y" /* yacc.c:1652 */ + { + const int isFunctionCall = 1; + Trees_Node designator, actualParameters, ident; + + (yyval.node) = NULL; + if (Trees_Symbol((yyvsp[0].node)) == TREES_PROCEDURE_CALL) { + designator = Trees_Left((yyvsp[0].node)); + actualParameters = Trees_Right((yyvsp[0].node)); + HandleProcedureCall(designator, actualParameters, isFunctionCall, &(yyval.node)); + } else { + ident = Trees_Left((yyvsp[0].node)); + if (Trees_Kind(ident) == TREES_CONSTANT_KIND) { + (yyval.node) = Trees_Value(ident); + } else { + (yyval.node) = (yyvsp[0].node); + } + } + assert((yyval.node) != NULL); + } +#line 2480 "y.tab.c" /* yacc.c:1652 */ + break; + + case 74: +#line 959 "Oberon.y" /* yacc.c:1652 */ + { + CheckIsValueExpression((yyvsp[-1].node)); + (yyval.node) = (yyvsp[-1].node); + } +#line 2489 "y.tab.c" /* yacc.c:1652 */ + break; + + case 75: +#line 964 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + CheckIsValueExpression((yyvsp[0].node)); + if (Types_ExpressionCompatible('~', Trees_Type((yyvsp[0].node)), NULL)) { + if (IsBoolean((yyvsp[0].node))) { + (yyval.node) = Trees_NewBoolean(! Trees_Boolean((yyvsp[0].node))); + } else { + (yyval.node) = Trees_NewNode('~', (yyvsp[0].node), NULL); + Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), (yyval.node)); + } + } else { + Oberon_PrintError("error: incompatible type in operation \"~\": %s", TypeString(Trees_Type((yyvsp[0].node)))); + YYABORT; + } + assert((yyval.node) != NULL); + } +#line 2510 "y.tab.c" /* yacc.c:1652 */ + break; + + case 76: +#line 985 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node designator, identType, actualParameters; + int parameterListFound; /*possibly empty*/ + + Trees_ReverseList(&(yyvsp[0].node)); /*correct order*/ + designator = Designator((yyvsp[-1].ident), (yyvsp[0].node)); + + identType = Trees_Type(BaseIdent(designator)); + SetSelectorTypes(identType, designator, ¶meterListFound); + if (parameterListFound) { + RemoveActualParameters(&designator, &actualParameters); + (yyval.node) = Trees_NewNode(TREES_PROCEDURE_CALL, designator, actualParameters); + } else { + (yyval.node) = designator; + } + } +#line 2531 "y.tab.c" /* yacc.c:1652 */ + break; + + case 77: +#line 1005 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node curr; + + if ((Trees_Symbol((yyvsp[0].node)) == '[') && (Trees_Right((yyvsp[0].node)) != NULL)) { /*multi-dimensional element selector*/ + /*attatch last element selector node to $1*/ + Trees_ReverseList(&(yyvsp[0].node)); + (yyval.node) = (yyvsp[-1].node); + curr = (yyvsp[0].node); + do { + (yyval.node) = Trees_NewNode('[', Trees_Left(curr), (yyval.node)); + curr = Trees_Right(curr); + } while (curr != NULL); + Trees_ReverseList(&(yyval.node)); + } else { + (yyval.node) = Trees_NewNode(Trees_Symbol((yyvsp[0].node)), Trees_Left((yyvsp[0].node)), (yyvsp[-1].node)); + } + } +#line 2553 "y.tab.c" /* yacc.c:1652 */ + break; + + case 78: +#line 1023 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 2561 "y.tab.c" /* yacc.c:1652 */ + break; + + case 79: +#line 1030 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node field; + + field = Trees_NewIdent((yyvsp[0].ident)); + Trees_SetKind(TREES_FIELD_KIND, field); + (yyval.node) = Trees_NewNode('.', field, NULL); + } +#line 2573 "y.tab.c" /* yacc.c:1652 */ + break; + + case 80: +#line 1038 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node curr, exp; + + /*create one selector node per index*/ + (yyval.node) = NULL; + curr = (yyvsp[-1].node); /*NOTE: ExpList is reversed*/ + do { + exp = Trees_Left(curr); + if (Types_IsInteger(Trees_Type(exp))) { + (yyval.node) = Trees_NewNode('[', Trees_Left(curr), (yyval.node)); + } else { + Oberon_PrintError("error: integer array index expected"); + YYABORT; + } + curr = Trees_Right(curr); + } while (curr != NULL); + } +#line 2595 "y.tab.c" /* yacc.c:1652 */ + break; + + case 81: +#line 1056 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode('^', NULL, NULL); + } +#line 2603 "y.tab.c" /* yacc.c:1652 */ + break; + + case 82: +#line 1061 "Oberon.y" /* yacc.c:1652 */ + { + Trees_ReverseList(&(yyvsp[-1].node)); /*correct order*/ + (yyval.node) = Trees_NewNode('(', (yyvsp[-1].node), NULL); + } +#line 2612 "y.tab.c" /* yacc.c:1652 */ + break; + + case 83: +#line 1066 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode('(', NULL, NULL); + } +#line 2620 "y.tab.c" /* yacc.c:1652 */ + break; + + case 84: +#line 1073 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewSet(0x0u); + } +#line 2628 "y.tab.c" /* yacc.c:1652 */ + break; + + case 85: +#line 1077 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[-1].node); + } +#line 2636 "y.tab.c" /* yacc.c:1652 */ + break; + + case 87: +#line 1085 "Oberon.y" /* yacc.c:1652 */ + { + if ((Trees_Symbol((yyvsp[-2].node)) == TREES_SET_CONSTANT) + && (Trees_Symbol((yyvsp[0].node)) == TREES_SET_CONSTANT)) { + (yyval.node) = Trees_NewSet(Trees_Set((yyvsp[-2].node)) | Trees_Set((yyvsp[0].node))); + } else { + (yyval.node) = Trees_NewNode('+', (yyvsp[-2].node), (yyvsp[0].node)); + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), (yyval.node)); + } + } +#line 2650 "y.tab.c" /* yacc.c:1652 */ + break; + + case 88: +#line 1098 "Oberon.y" /* yacc.c:1652 */ + { + OBNC_INTEGER i; + Trees_Node type; + + CheckIsValueExpression((yyvsp[0].node)); + (yyval.node) = NULL; + type = Trees_Type((yyvsp[0].node)); + if (IsInteger((yyvsp[0].node))) { + i = Trees_Integer((yyvsp[0].node)); + Range_CheckSetElement(i); + (yyval.node) = Trees_NewSet(1u << i); + } else if (Types_IsInteger(type)) { + (yyval.node) = Trees_NewNode(TREES_SINGLE_ELEMENT_SET, (yyvsp[0].node), NULL); + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), (yyval.node)); + } else { + Oberon_PrintError("error: element must have integer type"); + YYABORT; + } + } +#line 2674 "y.tab.c" /* yacc.c:1652 */ + break; + + case 89: +#line 1118 "Oberon.y" /* yacc.c:1652 */ + { + CheckIsValueExpression((yyvsp[-2].node)); + CheckIsValueExpression((yyvsp[0].node)); + (yyval.node) = NULL; + if (IsInteger((yyvsp[-2].node))) { + Range_CheckSetElement(Trees_Integer((yyvsp[-2].node))); + } + if (IsInteger((yyvsp[0].node))) { + Range_CheckSetElement(Trees_Integer((yyvsp[0].node))); + } + if (IsInteger((yyvsp[-2].node)) && IsInteger((yyvsp[0].node))) { + (yyval.node) = Trees_NewSet(OBNC_RANGE(Trees_Integer((yyvsp[-2].node)), Trees_Integer((yyvsp[0].node)))); + } else if (Types_IsInteger(Trees_Type((yyvsp[-2].node))) && Types_IsInteger(Trees_Type((yyvsp[0].node)))) { + (yyval.node) = Trees_NewNode(TREES_RANGE_SET, (yyvsp[-2].node), (yyvsp[0].node)); + Trees_SetType(Trees_NewLeaf(TREES_SET_TYPE), (yyval.node)); + } else { + Oberon_PrintError("error: element must have integer type"); + YYABORT; + } + } +#line 2699 "y.tab.c" /* yacc.c:1652 */ + break; + + case 90: +#line 1142 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(TREES_EXP_LIST, (yyvsp[0].node), NULL); + Trees_SetType(Trees_Type((yyvsp[0].node)), (yyval.node)); + } +#line 2708 "y.tab.c" /* yacc.c:1652 */ + break; + + case 91: +#line 1147 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node reversedList; + + reversedList = Trees_NewNode(TREES_EXP_LIST, (yyvsp[0].node), (yyvsp[-2].node)); + (yyval.node) = reversedList; + Trees_SetType(Trees_Type((yyvsp[0].node)), (yyval.node)); + } +#line 2720 "y.tab.c" /* yacc.c:1652 */ + break; + + case 99: +#line 1168 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 2728 "y.tab.c" /* yacc.c:1652 */ + break; + + case 100: +#line 1175 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node designator, ident, designatorType, exp; + + CheckIsValueExpression((yyvsp[0].node)); + switch (Trees_Symbol((yyvsp[-2].node))) { + case TREES_DESIGNATOR: + designator = (yyvsp[-2].node); + exp = (yyvsp[0].node); + ident = BaseIdent((yyvsp[-2].node)); + designatorType = Trees_Type((yyvsp[-2].node)); + switch (Trees_Kind(ident)) { + case TREES_VARIABLE_KIND: + case TREES_VALUE_PARAM_KIND: + case TREES_VAR_PARAM_KIND: + if (Writable((yyvsp[-2].node))) { + ValidateAssignment(exp, designatorType, ASSIGNMENT_CONTEXT, 0); + if (Types_IsChar(designatorType) && IsString(exp)) { + exp = Trees_NewChar(Trees_String(exp)[0]); + } + } else { + Oberon_PrintError("error: assignment to read-only variable"); + YYABORT; + } + break; + default: + Oberon_PrintError("error: assignment to non-variable"); + YYABORT; + } + (yyval.node) = Trees_NewNode(BECOMES, designator, exp); + break; + case TREES_PROCEDURE_CALL: + Oberon_PrintError("error: unexpected procedure call in assignment target"); + YYABORT; + break; + default: + assert(0); + } + } +#line 2771 "y.tab.c" /* yacc.c:1652 */ + break; + + case 101: +#line 1218 "Oberon.y" /* yacc.c:1652 */ + { + const int isFunctionCall = 0; + Trees_Node designator, actualParameters; + + if (Trees_Symbol((yyvsp[0].node)) == TREES_PROCEDURE_CALL) { + designator = Trees_Left((yyvsp[0].node)); + actualParameters = Trees_Right((yyvsp[0].node)); + } else { + designator = (yyvsp[0].node); + actualParameters = NULL; + } + HandleProcedureCall(designator, actualParameters, isFunctionCall, &(yyval.node)); + assert((yyval.node) != NULL); + } +#line 2790 "y.tab.c" /* yacc.c:1652 */ + break; + + case 102: +#line 1236 "Oberon.y" /* yacc.c:1652 */ + { + Trees_ReverseList(&(yyvsp[0].node)); /*correct order*/ + (yyval.node) = (yyvsp[0].node); + } +#line 2799 "y.tab.c" /* yacc.c:1652 */ + break; + + case 103: +#line 1244 "Oberon.y" /* yacc.c:1652 */ + { + if ((yyvsp[0].node) == NULL) { + (yyval.node) = NULL; + } else { + (yyval.node) = Trees_NewNode(TREES_STATEMENT_SEQUENCE, (yyvsp[0].node), NULL); + } + } +#line 2811 "y.tab.c" /* yacc.c:1652 */ + break; + + case 104: +#line 1252 "Oberon.y" /* yacc.c:1652 */ + { + if ((yyvsp[0].node) != NULL) { + (yyval.node) = Trees_NewNode(TREES_STATEMENT_SEQUENCE, (yyvsp[0].node), (yyvsp[-2].node)); + } else { + (yyval.node) = (yyvsp[-2].node); + } + } +#line 2823 "y.tab.c" /* yacc.c:1652 */ + break; + + case 105: +#line 1263 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node currElsif, currExp, currThen, currStmt; + + if ((yyvsp[-2].node) == NULL) { + (yyval.node) = Trees_NewNode(IF, (yyvsp[-5].node), Trees_NewNode(THEN, (yyvsp[-3].node), (yyvsp[-1].node))); + } else { + /*correct order of elsif nodes*/ + (yyval.node) = (yyvsp[-1].node); + currElsif = (yyvsp[-2].node); + do { + currExp = Trees_Left(currElsif); + currThen = Trees_Right(currElsif); + currStmt = Trees_Left(currThen); + (yyval.node) = Trees_NewNode(ELSIF, currExp, Trees_NewNode(THEN, currStmt, (yyval.node))); + currElsif = Trees_Right(currThen); + } while (currElsif != NULL); + (yyval.node) = Trees_NewNode(IF, (yyvsp[-5].node), Trees_NewNode(THEN, (yyvsp[-3].node), (yyval.node))); + } + } +#line 2847 "y.tab.c" /* yacc.c:1652 */ + break; + + case 106: +#line 1286 "Oberon.y" /* yacc.c:1652 */ + { + CheckIsValueExpression((yyvsp[0].node)); + if (Types_IsBoolean(Trees_Type((yyvsp[0].node)))) { + (yyval.node) = (yyvsp[0].node); + } else { + Oberon_PrintError("error: boolean expression expected"); + YYABORT; + } + } +#line 2861 "y.tab.c" /* yacc.c:1652 */ + break; + + case 107: +#line 1299 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(ELSIF, (yyvsp[-2].node), Trees_NewNode(THEN, (yyvsp[0].node), (yyvsp[-4].node))); + } +#line 2869 "y.tab.c" /* yacc.c:1652 */ + break; + + case 108: +#line 1303 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 2877 "y.tab.c" /* yacc.c:1652 */ + break; + + case 109: +#line 1310 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(ELSE, (yyvsp[0].node), NULL); + } +#line 2885 "y.tab.c" /* yacc.c:1652 */ + break; + + case 110: +#line 1314 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 2893 "y.tab.c" /* yacc.c:1652 */ + break; + + case 111: +#line 1321 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node expType, caseVariable; + + if ((yyvsp[-1].node) != NULL) { + Trees_ReverseList(&(yyvsp[-1].node)); /*correct order*/ + } + assert(caseLabelsStack != NULL); + caseLabelsStack = Trees_Right(caseLabelsStack); + expType = Trees_Type((yyvsp[-3].node)); + if (Types_IsRecord(expType) || Types_IsPointer(expType)) { + /*reset original type*/ + caseVariable = Trees_Left((yyvsp[-3].node)); + Trees_SetType(Trees_Type((yyvsp[-3].node)), caseVariable); + caseExpressionStack = Trees_Right(caseExpressionStack); + } + (yyval.node) = Trees_NewNode(CASE, (yyvsp[-3].node), (yyvsp[-1].node)); + } +#line 2915 "y.tab.c" /* yacc.c:1652 */ + break; + + case 112: +#line 1342 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node typeStruct, caseVariable; + + CheckIsValueExpression((yyvsp[0].node)); + typeStruct = Types_Structure(Trees_Type((yyvsp[0].node))); + switch (Trees_Symbol(typeStruct)) { + case RECORD: + /*fall through*/ + case POINTER: + if (IsDesignator((yyvsp[0].node)) && (FirstSelector((yyvsp[0].node)) == NULL)) { + caseVariable = BaseIdent((yyvsp[0].node)); + if (! Types_IsRecord(typeStruct) || (Trees_Kind(caseVariable) == TREES_VAR_PARAM_KIND)) { + (yyval.node) = (yyvsp[0].node); + } else { + Oberon_PrintError("error: record CASE expression must be a variable parameter"); + YYABORT; + } + } else { + Oberon_PrintError("error: non-integral CASE expression must be a variable"); + YYABORT; + } + /*fall through*/ + case TREES_INTEGER_TYPE: + /*fall through*/ + case TREES_CHAR_TYPE: + caseExpressionStack = Trees_NewNode(TREES_NOSYM, (yyvsp[0].node), caseExpressionStack); + caseLabelsStack = Trees_NewNode(TREES_NOSYM, NULL, caseLabelsStack); + (yyval.node) = (yyvsp[0].node); + break; + default: + Oberon_PrintError("error: invalid type of CASE expression"); + YYABORT; + } + } +#line 2954 "y.tab.c" /* yacc.c:1652 */ + break; + + case 113: +#line 1380 "Oberon.y" /* yacc.c:1652 */ + { + if ((yyvsp[0].node) != NULL) { + (yyval.node) = Trees_NewNode(TREES_CASE_REP, (yyvsp[0].node), NULL); + } else { + (yyval.node) = NULL; + } + } +#line 2966 "y.tab.c" /* yacc.c:1652 */ + break; + + case 114: +#line 1388 "Oberon.y" /* yacc.c:1652 */ + { + if ((yyvsp[0].node) != NULL) { + if ((yyvsp[-2].node) != NULL) { + (yyval.node) = Trees_NewNode(TREES_CASE_REP, (yyvsp[0].node), (yyvsp[-2].node)); + } else { + (yyval.node) = Trees_NewNode(TREES_CASE_REP, (yyvsp[0].node), NULL); + } + } else { + (yyval.node) = NULL; + } + } +#line 2982 "y.tab.c" /* yacc.c:1652 */ + break; + + case 115: +#line 1403 "Oberon.y" /* yacc.c:1652 */ + { + Trees_ReverseList(&(yyvsp[-2].node)); /*correct order*/ + (yyval.node) = Trees_NewNode(TREES_CASE, (yyvsp[-2].node), (yyvsp[0].node)); + } +#line 2991 "y.tab.c" /* yacc.c:1652 */ + break; + + case 116: +#line 1408 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 2999 "y.tab.c" /* yacc.c:1652 */ + break; + + case 117: +#line 1415 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(TREES_CASE_LABEL_LIST, (yyvsp[0].node), NULL); + } +#line 3007 "y.tab.c" /* yacc.c:1652 */ + break; + + case 118: +#line 1419 "Oberon.y" /* yacc.c:1652 */ + { + switch (Trees_Symbol((yyvsp[0].node))) { + case INTEGER: + case TREES_CHAR_CONSTANT: + case DOTDOT: + (yyval.node) = Trees_NewNode(TREES_CASE_LABEL_LIST, (yyvsp[0].node), (yyvsp[-2].node)); + break; + default: + Oberon_PrintError("error: unexpected list of type name case labels"); + YYABORT; + } + } +#line 3024 "y.tab.c" /* yacc.c:1652 */ + break; + + case 119: +#line 1435 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[0].node); + CheckCaseLabelUniqueness((yyvsp[0].node)); + assert(caseLabelsStack != NULL); + caseLabelsStack = Trees_NewNode(TREES_NOSYM, + Trees_NewNode(TREES_NOSYM, (yyvsp[0].node), Trees_Left(caseLabelsStack)), + Trees_Right(caseLabelsStack)); + } +#line 3037 "y.tab.c" /* yacc.c:1652 */ + break; + + case 120: +#line 1444 "Oberon.y" /* yacc.c:1652 */ + { + const int rangeLenMax = 255; + int leftSym, rightSym; + OBNC_INTEGER rangeMin, rangeMax; + + leftSym = Trees_Symbol((yyvsp[-2].node)); + rightSym = Trees_Symbol((yyvsp[0].node)); + if (leftSym == rightSym) { + switch (leftSym) { + case INTEGER: + rangeMin = Trees_Integer((yyvsp[-2].node)); + rangeMax = Trees_Integer((yyvsp[0].node)); + if (rangeMin <= rangeMax) { + if (rangeMax - rangeMin > rangeLenMax) { + Oberon_PrintError("warning: maximum range length of %d exceeded", rangeLenMax); + YYABORT; + } + } else { + Oberon_PrintError("error: left integer must be less than right integer in case range"); + YYABORT; + } + break; + case TREES_CHAR_CONSTANT: + if (Trees_Char((yyvsp[-2].node)) >= Trees_Char((yyvsp[0].node))) { + Oberon_PrintError("error: left string must be less than right string in case range"); + YYABORT; + } + break; + default: + Oberon_PrintError("error: case label ranges must contain integers or single-character strings"); + YYABORT; + } + } else { + Oberon_PrintError("error: case labels in a range must have the same type"); + YYABORT; + } + (yyval.node) = Trees_NewNode(DOTDOT, (yyvsp[-2].node), (yyvsp[0].node)); + CheckCaseLabelUniqueness((yyval.node)); + assert(caseLabelsStack != NULL); + caseLabelsStack = Trees_NewNode(TREES_NOSYM, + Trees_NewNode(TREES_NOSYM, (yyval.node), Trees_Left(caseLabelsStack)), + Trees_Right(caseLabelsStack)); + } +#line 3085 "y.tab.c" /* yacc.c:1652 */ + break; + + case 121: +#line 1491 "Oberon.y" /* yacc.c:1652 */ + { + if (Types_IsInteger(Trees_Type(Trees_Left(caseExpressionStack)))) { + (yyval.node) = Trees_NewInteger((yyvsp[0].integer)); + } else { + Oberon_PrintError("error: unexpected integer case label"); + YYABORT; + } + } +#line 3098 "y.tab.c" /* yacc.c:1652 */ + break; + + case 122: +#line 1500 "Oberon.y" /* yacc.c:1652 */ + { + if (Types_IsChar(Trees_Type(Trees_Left(caseExpressionStack)))) { + if (strlen((yyvsp[0].string)) <= 1) { + (yyval.node) = Trees_NewChar((yyvsp[0].string)[0]); + } else { + Oberon_PrintError("error: single-character string expected: \"%s\"", (yyvsp[0].string)); + YYABORT; + } + } else { + Oberon_PrintError("error: unexpected string case label: \"%s\"", (yyvsp[0].string)); + YYABORT; + } + } +#line 3116 "y.tab.c" /* yacc.c:1652 */ + break; + + case 123: +#line 1514 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node caseExp, constValue, caseVariable; + + (yyval.node) = Table_At(Trees_Name((yyvsp[0].node))); + if ((yyval.node) != NULL) { + caseExp = Trees_Left(caseExpressionStack); + switch (Trees_Symbol(Types_Structure(Trees_Type(caseExp)))) { + case TREES_INTEGER_TYPE: + if (Trees_Kind((yyval.node)) == TREES_CONSTANT_KIND) { + constValue = Trees_Value((yyval.node)); + if (Trees_Symbol(constValue) == INTEGER) { + if (Trees_Integer(constValue) >= 0) { + (yyval.node) = constValue; + } else { + Oberon_PrintError("error: non-negative case label expected: %" OBNC_INT_MOD "d", Trees_Integer(constValue)); + YYABORT; + } + } else { + Oberon_PrintError("error: integer case label expected"); + YYABORT; + } + } else { + Oberon_PrintError("error: constant identifier expected: %s", Trees_Name((yyval.node))); + YYABORT; + } + break; + case TREES_CHAR_TYPE: + if (Trees_Kind((yyval.node)) == TREES_CONSTANT_KIND) { + constValue = Trees_Value((yyval.node)); + if (Trees_Symbol(constValue) == STRING) { + if (Types_StringLength(Trees_Type(constValue)) <= 1) { + (yyval.node) = Trees_NewChar(Trees_String(constValue)[0]); + } else { + Oberon_PrintError("error: single-character string expected: %s", Trees_String(constValue)); + YYABORT; + } + } else { + Oberon_PrintError("error: character case label expected"); + YYABORT; + } + } else { + Oberon_PrintError("error: constant identifier expected: %s", Trees_Name((yyval.node))); + YYABORT; + } + break; + case RECORD: + if (Types_IsType((yyval.node)) && Types_IsRecord((yyval.node))) { + if (Types_Extends(Trees_Type(caseExp), (yyval.node))) { + caseVariable = Trees_Left(caseExp); + Trees_SetType((yyval.node), caseVariable); + } else { + Oberon_PrintError("error: case label is not an extension of %s: %s", Trees_Name(Trees_Type(caseExp)), Trees_Name((yyval.node))); + YYABORT; + } + } else { + Oberon_PrintError("error: record type case label expected"); + YYABORT; + } + break; + case POINTER: + if (Types_IsType((yyval.node)) && Types_IsPointer((yyval.node))) { + if (Types_Extends(Trees_Type(caseExp), (yyval.node))) { + caseVariable = Trees_Left(caseExp); + Trees_SetType((yyval.node), caseVariable); + } else { + Oberon_PrintError("error: case label is not an extension of %s: %s", Trees_Name(Trees_Type(caseExp)), Trees_Name((yyval.node))); + YYABORT; + } + } else { + Oberon_PrintError("error: pointer type case label expected"); + YYABORT; + } + break; + default: + assert(0); + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + } +#line 3202 "y.tab.c" /* yacc.c:1652 */ + break; + + case 124: +#line 1599 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(WHILE, (yyvsp[-4].node), Trees_NewNode(DO, (yyvsp[-2].node), (yyvsp[-1].node))); + } +#line 3210 "y.tab.c" /* yacc.c:1652 */ + break; + + case 125: +#line 1606 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(ELSIF, (yyvsp[-2].node), Trees_NewNode(THEN, (yyvsp[0].node), (yyvsp[-4].node))); + } +#line 3218 "y.tab.c" /* yacc.c:1652 */ + break; + + case 126: +#line 1610 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3226 "y.tab.c" /* yacc.c:1652 */ + break; + + case 127: +#line 1617 "Oberon.y" /* yacc.c:1652 */ + { + CheckIsValueExpression((yyvsp[0].node)); + (yyval.node) = NULL; + if (Types_IsBoolean(Trees_Type((yyvsp[0].node)))) { + (yyval.node) = Trees_NewNode(REPEAT, (yyvsp[-2].node), (yyvsp[0].node)); + } else { + Oberon_PrintError("error: boolean expression expected"); + YYABORT; + } + } +#line 3241 "y.tab.c" /* yacc.c:1652 */ + break; + + case 128: +#line 1632 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node byExp; + + if ((yyvsp[-3].node) != NULL) { + byExp = (yyvsp[-3].node); + } else { + byExp = Trees_NewInteger(1); + } + (yyval.node) = Trees_NewNode(FOR, + (yyvsp[-6].node), + Trees_NewNode(TO, + (yyvsp[-4].node), + Trees_NewNode(BY, byExp, (yyvsp[-1].node)))); + } +#line 3260 "y.tab.c" /* yacc.c:1652 */ + break; + + case 129: +#line 1650 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node ctrlVar, ctrlVarType; + + CheckIsValueExpression((yyvsp[0].node)); + ctrlVar = Table_At((yyvsp[-2].ident)); + if (ctrlVar != NULL) { + ctrlVarType = Trees_Type(ctrlVar); + if (Types_IsInteger(ctrlVarType)) { + if (Types_IsInteger(Trees_Type((yyvsp[0].node)))) { + (yyval.node) = Trees_NewNode(BECOMES, ctrlVar, (yyvsp[0].node)); + } else { + Oberon_PrintError("error: integer expression expected as initial value"); + YYABORT; + } + } else { + Oberon_PrintError("error: integer control variable expected: %s", (yyvsp[-2].ident)); + YYABORT; + } + } else { + Oberon_PrintError("error: undeclared control variable: %s", (yyvsp[-2].ident)); + YYABORT; + } + } +#line 3288 "y.tab.c" /* yacc.c:1652 */ + break; + + case 130: +#line 1676 "Oberon.y" /* yacc.c:1652 */ + { + CheckIsValueExpression((yyvsp[0].node)); + if (! Types_IsInteger(Trees_Type((yyvsp[0].node)))) { + Oberon_PrintError("error: integer expression expected as upper limit"); + YYABORT; + } + } +#line 3300 "y.tab.c" /* yacc.c:1652 */ + break; + + case 131: +#line 1687 "Oberon.y" /* yacc.c:1652 */ + { + if (Types_IsInteger(Trees_Type((yyvsp[0].node)))) { + if (IsInteger((yyvsp[0].node))) { + if (Trees_Integer((yyvsp[0].node)) == 0) { + Oberon_PrintError("warning: steps by zero leads to infinite loop"); + } + (yyval.node) = (yyvsp[0].node); + } else { + Oberon_PrintError("error: fully evaluated constant expression expected as increment"); + YYABORT; + } + } else { + Oberon_PrintError("error: integer increment expected"); + YYABORT; + } + } +#line 3321 "y.tab.c" /* yacc.c:1652 */ + break; + + case 132: +#line 1704 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3329 "y.tab.c" /* yacc.c:1652 */ + break; + + case 133: +#line 1714 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node procIdent, procType, resultType, procStatements, returnExp; + const char *procName; + + procIdent = (yyvsp[-6].node); + procName = Trees_Name(procIdent); + procType = Trees_Type((yyvsp[-6].node)); + resultType = Types_ResultType(procType); + procStatements = (yyvsp[-3].node); + returnExp = (yyvsp[-2].node); + + if (strcmp(procName, (yyvsp[0].ident)) == 0) { + if (resultType == NULL) { + if (returnExp != NULL) { + Oberon_PrintError("error: unexpected return expression"); + YYABORT; + } + } else { + if (returnExp != NULL) { + CheckIsValueExpression(returnExp); + ValidateAssignment(returnExp, resultType, PROC_RESULT_CONTEXT, 0); + if ((Trees_Symbol(returnExp) == STRING) && Types_IsChar(resultType)) { + returnExp = Trees_NewChar(Trees_String(returnExp)[0]); + } + } else { + Oberon_PrintError("error: return expression expected"); + YYABORT; + } + } + if (procStatements != NULL) { + Generate_ProcedureStatements(procStatements); + } + if (returnExp != NULL) { + Generate_ReturnClause(returnExp); + } + if (procedureDeclarationStack != NULL) { + procedureDeclarationStack = Trees_Right(procedureDeclarationStack); + } + Generate_ProcedureEnd(procIdent); + CheckUnusedIdentifiers(); + Table_CloseScope(); + } else { + Oberon_PrintError("error: expected procedure name: %s", procName); + YYABORT; + } + } +#line 3380 "y.tab.c" /* yacc.c:1652 */ + break; + + case 134: +#line 1764 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node paramList, param; + + (yyval.node) = NULL; + Trees_SetType((yyvsp[0].node), (yyvsp[-1].node)); + + paramList = Types_Parameters((yyvsp[0].node)); + while (paramList != NULL) { + param = Trees_Left(paramList); + Table_Put(param); + paramList = Trees_Right(paramList); + } + + procedureDeclarationStack = Trees_NewNode(TREES_NOSYM, (yyvsp[-1].node), procedureDeclarationStack); + Generate_ProcedureHeading((yyvsp[-1].node)); + (yyval.node) = (yyvsp[-1].node); + } +#line 3402 "y.tab.c" /* yacc.c:1652 */ + break; + + case 135: +#line 1785 "Oberon.y" /* yacc.c:1652 */ + { + if (! (Trees_Exported((yyvsp[0].node)) && Trees_Local((yyvsp[0].node)))) { + Trees_SetKind(TREES_PROCEDURE_KIND, (yyvsp[0].node)); + Table_Put((yyvsp[0].node)); + Table_OpenScope(); + } else { + Oberon_PrintError("error: cannot export local procedure: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + (yyval.node) = (yyvsp[0].node); + } +#line 3418 "y.tab.c" /* yacc.c:1652 */ + break; + + case 136: +#line 1800 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[0].node); + } +#line 3426 "y.tab.c" /* yacc.c:1652 */ + break; + + case 137: +#line 1804 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3434 "y.tab.c" /* yacc.c:1652 */ + break; + + case 138: +#line 1811 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[0].node); + } +#line 3442 "y.tab.c" /* yacc.c:1652 */ + break; + + case 139: +#line 1815 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3450 "y.tab.c" /* yacc.c:1652 */ + break; + + case 145: +#line 1836 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node unresolvedPointerType, undeclaredBaseType; + + if (unresolvedPointerTypes != NULL) { + unresolvedPointerType = Trees_Left(unresolvedPointerTypes); + undeclaredBaseType = Types_PointerBaseType(unresolvedPointerType); + Oberon_PrintError("error: undeclared pointer base type: %s", Trees_Name(undeclaredBaseType)); + YYABORT; + } + } +#line 3465 "y.tab.c" /* yacc.c:1652 */ + break; + + case 146: +#line 1847 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3473 "y.tab.c" /* yacc.c:1652 */ + break; + + case 147: +#line 1854 "Oberon.y" /* yacc.c:1652 */ + { + unresolvedPointerTypes = NULL; + } +#line 3481 "y.tab.c" /* yacc.c:1652 */ + break; + + case 156: +#line 1881 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Types_NewProcedure((yyvsp[-2].node), (yyvsp[0].node)); + } +#line 3489 "y.tab.c" /* yacc.c:1652 */ + break; + + case 157: +#line 1888 "Oberon.y" /* yacc.c:1652 */ + { + Trees_ReverseList(&(yyvsp[0].node)); /*correct order*/ + (yyval.node) = (yyvsp[0].node); + } +#line 3498 "y.tab.c" /* yacc.c:1652 */ + break; + + case 158: +#line 1893 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3506 "y.tab.c" /* yacc.c:1652 */ + break; + + case 159: +#line 1900 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = (yyvsp[0].node); + Trees_ReverseList(&(yyval.node)); + } +#line 3515 "y.tab.c" /* yacc.c:1652 */ + break; + + case 160: +#line 1905 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node p, p1; + const char *paramName, *paramName1; + + /*make sure no parameter is repeated*/ + p = (yyvsp[0].node); + while (p != NULL) { + paramName = Trees_Name(Trees_Left(p)); + p1 = (yyvsp[-2].node); + while (p1 != NULL) { + paramName1 = Trees_Name(Trees_Left(p1)); + if (strcmp(paramName1, paramName) == 0) { + Oberon_PrintError("error: repeated parameter: %s", paramName); + YYABORT; + } + p1 = Trees_Right(p1); + } + p = Trees_Right(p); + } + + /*make one list of the two lists*/ + (yyval.node) = (yyvsp[-2].node); + p = (yyvsp[0].node); + do { + (yyval.node) = Trees_NewNode(TREES_IDENT_LIST, Trees_Left(p), (yyval.node)); + p = Trees_Right(p); + } while (p != NULL); + /*$$ in reversed order*/ + } +#line 3549 "y.tab.c" /* yacc.c:1652 */ + break; + + case 161: +#line 1938 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = ResolvedType((yyvsp[0].node), 0); + if ((yyval.node) != NULL) { + if (Trees_Symbol((yyval.node)) == IDENT) { + if (Trees_Kind((yyval.node)) != TREES_TYPE_KIND) { + Oberon_PrintError("error: type name expected as result type: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + if (! Types_Scalar((yyval.node))) { + Oberon_PrintError("error: scalar result type expected: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name((yyvsp[0].node))); + YYABORT; + } + } +#line 3572 "y.tab.c" /* yacc.c:1652 */ + break; + + case 162: +#line 1957 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3580 "y.tab.c" /* yacc.c:1652 */ + break; + + case 163: +#line 1964 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node curr, ident; + + Trees_ReverseList(&(yyvsp[-2].node)); /*correct order*/ + curr = (yyvsp[-2].node); + do { + ident = Trees_Left(curr); + Trees_SetKind((int) (yyvsp[-3].integer), ident); + Trees_SetType((yyvsp[0].node), ident); + Trees_SetLocal(ident); + curr = Trees_Right(curr); + } while (curr != NULL); + + (yyval.node) = (yyvsp[-2].node); + } +#line 3600 "y.tab.c" /* yacc.c:1652 */ + break; + + case 164: +#line 1983 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = TREES_VAR_PARAM_KIND; + } +#line 3608 "y.tab.c" /* yacc.c:1652 */ + break; + + case 165: +#line 1987 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.integer) = TREES_VALUE_PARAM_KIND; + } +#line 3616 "y.tab.c" /* yacc.c:1652 */ + break; + + case 166: +#line 1994 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(TREES_IDENT_LIST, Trees_NewIdent((yyvsp[0].ident)), NULL); + } +#line 3624 "y.tab.c" /* yacc.c:1652 */ + break; + + case 167: +#line 1998 "Oberon.y" /* yacc.c:1652 */ + { + Trees_Node curr; + const char *identName; + + /*make sure no name is repeated*/ + curr = (yyvsp[-2].node); + while (curr != NULL) { + identName = Trees_Name(Trees_Left(curr)); + if (strcmp(identName, (yyvsp[0].ident)) == 0) { + Oberon_PrintError("error: repeated identifier: %s", identName); + YYABORT; + } + curr = Trees_Right(curr); + } + + (yyval.node) = Trees_NewNode(TREES_IDENT_LIST, Trees_NewIdent((yyvsp[0].ident)), (yyvsp[-2].node)); + } +#line 3646 "y.tab.c" /* yacc.c:1652 */ + break; + + case 168: +#line 2019 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = ResolvedType((yyvsp[0].node), 0); + if ((yyval.node) != NULL) { + while ((yyvsp[-1].node) != NULL) { + (yyval.node) = Types_NewArray(NULL, (yyval.node)); + (yyvsp[-1].node) = Trees_Right((yyvsp[-1].node)); + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name((yyvsp[0].node))); + exit(EXIT_FAILURE); + } + } +#line 3663 "y.tab.c" /* yacc.c:1652 */ + break; + + case 169: +#line 2035 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = Trees_NewNode(ARRAY, NULL, (yyvsp[-2].node)); + } +#line 3671 "y.tab.c" /* yacc.c:1652 */ + break; + + case 170: +#line 2039 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.node) = NULL; + } +#line 3679 "y.tab.c" /* yacc.c:1652 */ + break; + + case 171: +#line 2049 "Oberon.y" /* yacc.c:1652 */ + { + const char *symfilePath; + + if (strcmp((yyvsp[-1].ident), inputModuleName) == 0) { + CheckUnusedIdentifiers(); + Generate_ModuleEnd(); + Generate_Close(); + + symfilePath = Util_String(".obnc/%s.sym", inputModuleName); + if (parseMode == OBERON_ENTRY_POINT_MODE) { + if (Files_Exists(symfilePath)) { + Files_Remove(symfilePath); + } + } else { + ExportSymbolTable(symfilePath); + } + YYACCEPT; + } else { + Oberon_PrintError("error: expected identifier %s", inputModuleName); + YYABORT; + } + } +#line 3706 "y.tab.c" /* yacc.c:1652 */ + break; + + case 172: +#line 2076 "Oberon.y" /* yacc.c:1652 */ + { + if (strcmp((yyvsp[0].ident), inputModuleName) == 0) { + if (parseMode != OBERON_IMPORT_LIST_MODE) { + Generate_ModuleHeading(); + } + } else { + Oberon_PrintError("error: module name does not match filename: %s", (yyvsp[0].ident)); + YYABORT; + } + } +#line 3721 "y.tab.c" /* yacc.c:1652 */ + break; + + case 173: +#line 2090 "Oberon.y" /* yacc.c:1652 */ + { + if (parseMode == OBERON_IMPORT_LIST_MODE) { + YYACCEPT; + } + } +#line 3731 "y.tab.c" /* yacc.c:1652 */ + break; + + case 174: +#line 2096 "Oberon.y" /* yacc.c:1652 */ + { + if (parseMode == OBERON_IMPORT_LIST_MODE) { + YYACCEPT; + } + } +#line 3741 "y.tab.c" /* yacc.c:1652 */ + break; + + case 175: +#line 2105 "Oberon.y" /* yacc.c:1652 */ + { + const char *impfilePath; + Trees_Node moduleAndDirPath, module, p; + FILE *impFile; + const char *name; + + if ((yyvsp[-1].node) != NULL) { + Trees_ReverseList(&(yyvsp[-1].node)); /*correct order*/ + if (parseMode == OBERON_IMPORT_LIST_MODE) { + while ((yyvsp[-1].node) != NULL) { + name = Trees_Name(Trees_Left((yyvsp[-1].node))); + puts(name); + (yyvsp[-1].node) = Trees_Right((yyvsp[-1].node)); + } + } else { + if (parseMode == OBERON_NORMAL_MODE) { + impfilePath = Util_String(".obnc/%s.imp", inputModuleName); + impFile = Files_Exists(impfilePath)? Files_Old(impfilePath, FILES_WRITE): Files_New(impfilePath); + p = (yyvsp[-1].node); + do { + moduleAndDirPath = Trees_Left(p); + module = Trees_Left(moduleAndDirPath); + name = Trees_UnaliasedName(module); + fprintf(impFile, "%s\n", name); + p = Trees_Right(p); + } while (p != NULL); + Files_Close(&impFile); + } + Generate_ImportList((yyvsp[-1].node)); + } + } + } +#line 3778 "y.tab.c" /* yacc.c:1652 */ + break; + + case 176: +#line 2141 "Oberon.y" /* yacc.c:1652 */ + { + if ((yyvsp[0].node) != NULL) { + (yyval.node) = Trees_NewNode(TREES_NOSYM, (yyvsp[0].node), NULL); + } else { + (yyval.node) = NULL; + } + } +#line 3790 "y.tab.c" /* yacc.c:1652 */ + break; + + case 177: +#line 2149 "Oberon.y" /* yacc.c:1652 */ + { + if ((yyvsp[0].node) != NULL) { + (yyval.node) = Trees_NewNode(TREES_NOSYM, (yyvsp[0].node), (yyvsp[-2].node)); + } else { + (yyval.node) = (yyvsp[-2].node); + } + } +#line 3802 "y.tab.c" /* yacc.c:1652 */ + break; + + case 178: +#line 2160 "Oberon.y" /* yacc.c:1652 */ + { + static Maps_Map importedModules = NULL; + const char *module, *qualifier, *symbolFileDir, *symbolFileName, *moduleDirPath; + Trees_Node qualifierSym, moduleIdent; + + if (importedModules == NULL) { + importedModules = Maps_New(); + } + if ((yyvsp[0].ident) != NULL) { + module = (yyvsp[0].ident); + qualifier = (yyvsp[-1].ident); + } else { + module = (yyvsp[-1].ident); + qualifier = (yyvsp[-1].ident); + } + (yyval.node) = NULL; + if (strcmp(module, inputModuleName) != 0) { + if (! Maps_HasKey(module, importedModules)) { + Maps_Put(module, NULL, &importedModules); + qualifierSym = Table_At(qualifier); + if (qualifierSym == NULL) { + qualifierSym = Trees_NewIdent(qualifier); + if ((yyvsp[0].ident) != NULL) { + Trees_SetUnaliasedName(module, qualifierSym); + } + Trees_SetKind(TREES_QUALIFIER_KIND, qualifierSym); + Table_Put(qualifierSym); + + if (strcmp(module, "SYSTEM") == 0) { + if (parseMode != OBERON_IMPORT_LIST_MODE) { + Table_ImportSystem(qualifier); + } + } else if (parseMode == OBERON_IMPORT_LIST_MODE) { + (yyval.node) = Trees_NewIdent(module); + } else { + moduleDirPath = ModulePaths_Directory(module, ".", 0); + if (moduleDirPath != NULL) { + /*import identifiers into the symbol table*/ + symbolFileDir = Util_String("%s/.obnc", moduleDirPath); + if (! Files_Exists(symbolFileDir)) { + symbolFileDir = Util_String("%s", moduleDirPath); + } + symbolFileName = Util_String("%s/%s.sym", symbolFileDir, module); + if (Files_Exists(symbolFileName)) { + Table_Import(symbolFileName, module, qualifier); + } else { + Oberon_PrintError("error: symbol file not found for module %s: %s", module, symbolFileName); + YYABORT; + } + + moduleIdent = Trees_NewIdent(module); + Trees_SetKind(TREES_QUALIFIER_KIND, moduleIdent); + (yyval.node) = Trees_NewNode(TREES_NOSYM, moduleIdent, Trees_NewString(moduleDirPath)); + } else { + Oberon_PrintError("error: imported module not found: %s", module); + YYABORT; + } + } + } else { + Oberon_PrintError("error: qualifier already used: %s", qualifier); + YYABORT; + } + } else { + Oberon_PrintError("error: module already imported: %s", module); + YYABORT; + } + } else { + Oberon_PrintError("error: a module cannot import itself"); + YYABORT; + } + } +#line 3878 "y.tab.c" /* yacc.c:1652 */ + break; + + case 179: +#line 2235 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.ident) = (yyvsp[0].ident); + } +#line 3886 "y.tab.c" /* yacc.c:1652 */ + break; + + case 180: +#line 2239 "Oberon.y" /* yacc.c:1652 */ + { + (yyval.ident) = NULL; + } +#line 3894 "y.tab.c" /* yacc.c:1652 */ + break; + + case 181: +#line 2246 "Oberon.y" /* yacc.c:1652 */ + { + Generate_ModuleStatements((yyvsp[0].node)); + } +#line 3902 "y.tab.c" /* yacc.c:1652 */ + break; + + +#line 3906 "y.tab.c" /* yacc.c:1652 */ + default: break; + } + /* User semantic actions sometimes alter yychar, and that requires + that yytoken be updated with the new translation. We take the + approach of translating immediately before every use of yytoken. + One alternative is translating here after every semantic action, + but that translation would be missed if the semantic action invokes + YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or + if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an + incorrect destructor might then be invoked immediately. In the + case of YYERROR or YYBACKUP, subsequent parser actions might lead + to an incorrect destructor call or verbose syntax error message + before the lookahead is translated. */ + YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); + + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + + *++yyvsp = yyval; + + /* Now 'shift' the result of the reduction. Determine what state + that goes to, based on the state we popped back to and the rule + number reduced by. */ + { + const int yylhs = yyr1[yyn] - YYNTOKENS; + const int yyi = yypgoto[yylhs] + *yyssp; + yystate = (0 <= yyi && yyi <= YYLAST && yycheck[yyi] == *yyssp + ? yytable[yyi] + : yydefgoto[yylhs]); + } + + goto yynewstate; + + +/*--------------------------------------. +| yyerrlab -- here on detecting error. | +`--------------------------------------*/ +yyerrlab: + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); + + /* If not already recovering from an error, report this error. */ + if (!yyerrstatus) + { + ++yynerrs; +#if ! YYERROR_VERBOSE + yyerror (YY_("syntax error")); +#else +# define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \ + yyssp, yytoken) + { + char const *yymsgp = YY_("syntax error"); + int yysyntax_error_status; + yysyntax_error_status = YYSYNTAX_ERROR; + if (yysyntax_error_status == 0) + yymsgp = yymsg; + else if (yysyntax_error_status == 1) + { + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); + yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc); + if (!yymsg) + { + yymsg = yymsgbuf; + yymsg_alloc = sizeof yymsgbuf; + yysyntax_error_status = 2; + } + else + { + yysyntax_error_status = YYSYNTAX_ERROR; + yymsgp = yymsg; + } + } + yyerror (yymsgp); + if (yysyntax_error_status == 2) + goto yyexhaustedlab; + } +# undef YYSYNTAX_ERROR +#endif + } + + + + if (yyerrstatus == 3) + { + /* If just tried and failed to reuse lookahead token after an + error, discard it. */ + + if (yychar <= YYEOF) + { + /* Return failure if at end of input. */ + if (yychar == YYEOF) + YYABORT; + } + else + { + yydestruct ("Error: discarding", + yytoken, &yylval); + yychar = YYEMPTY; + } + } + + /* Else will try to reuse lookahead token after shifting the error + token. */ + goto yyerrlab1; + + +/*---------------------------------------------------. +| yyerrorlab -- error raised explicitly by YYERROR. | +`---------------------------------------------------*/ +yyerrorlab: + /* Pacify compilers when the user code never invokes YYERROR and the + label yyerrorlab therefore never appears in user code. */ + if (0) + YYERROR; + + /* Do not reclaim the symbols of the rule whose action triggered + this YYERROR. */ + YYPOPSTACK (yylen); + yylen = 0; + YY_STACK_PRINT (yyss, yyssp); + yystate = *yyssp; + goto yyerrlab1; + + +/*-------------------------------------------------------------. +| yyerrlab1 -- common code for both syntax error and YYERROR. | +`-------------------------------------------------------------*/ +yyerrlab1: + yyerrstatus = 3; /* Each real token shifted decrements this. */ + + for (;;) + { + yyn = yypact[yystate]; + if (!yypact_value_is_default (yyn)) + { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) + { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } + + /* Pop the current state because it cannot handle the error token. */ + if (yyssp == yyss) + YYABORT; + + + yydestruct ("Error: popping", + yystos[yystate], yyvsp); + YYPOPSTACK (1); + yystate = *yyssp; + YY_STACK_PRINT (yyss, yyssp); + } + + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END + + + /* Shift the error token. */ + YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp); + + yystate = yyn; + goto yynewstate; + + +/*-------------------------------------. +| yyacceptlab -- YYACCEPT comes here. | +`-------------------------------------*/ +yyacceptlab: + yyresult = 0; + goto yyreturn; + + +/*-----------------------------------. +| yyabortlab -- YYABORT comes here. | +`-----------------------------------*/ +yyabortlab: + yyresult = 1; + goto yyreturn; + + +#if !defined yyoverflow || YYERROR_VERBOSE +/*-------------------------------------------------. +| yyexhaustedlab -- memory exhaustion comes here. | +`-------------------------------------------------*/ +yyexhaustedlab: + yyerror (YY_("memory exhausted")); + yyresult = 2; + /* Fall through. */ +#endif + + +/*-----------------------------------------------------. +| yyreturn -- parsing is finished, return the result. | +`-----------------------------------------------------*/ +yyreturn: + if (yychar != YYEMPTY) + { + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = YYTRANSLATE (yychar); + yydestruct ("Cleanup: discarding lookahead", + yytoken, &yylval); + } + /* Do not reclaim the symbols of the rule whose action triggered + this YYABORT or YYACCEPT. */ + YYPOPSTACK (yylen); + YY_STACK_PRINT (yyss, yyssp); + while (yyssp != yyss) + { + yydestruct ("Cleanup: popping", + yystos[*yyssp], yyvsp); + YYPOPSTACK (1); + } +#ifndef yyoverflow + if (yyss != yyssa) + YYSTACK_FREE (yyss); +#endif +#if YYERROR_VERBOSE + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); +#endif + return yyresult; +} +#line 2251 "Oberon.y" /* yacc.c:1918 */ + + +void Oberon_Init(void) +{ + if (! initialized) { + initialized = 1; + Error_Init(); + Files_Init(); + Generate_Init(); + ModulePaths_Init(); + Table_Init(); + } +} + + +void Oberon_Parse(const char inputFile[], int mode) +{ + const char *impFile; + FILE *fp; + int error; + + assert(initialized); + inputFilename = inputFile; + parseMode = mode; + inputModuleName = Paths_SansSuffix(Paths_Basename(inputFile)); + + yyin = fopen(inputFile, "r"); + if (yyin != NULL) { + if (mode != OBERON_IMPORT_LIST_MODE) { + Generate_Open(inputFile, mode == OBERON_ENTRY_POINT_MODE); + + impFile = Util_String(".obnc/%s.imp", inputModuleName); + if (parseMode == OBERON_NORMAL_MODE) { + if (! Files_Exists(impFile)) { + fp = Files_New(impFile); + Files_Close(&fp); + } + } else { + assert(parseMode == OBERON_ENTRY_POINT_MODE); + if (Files_Exists(impFile)) { + Files_Remove(impFile); + } + } + } + error = yyparse(); + if (error) { + exit(EXIT_FAILURE); + } + } else { + Error_Handle(Util_String("error: cannot open file: %s: %s", inputFile, strerror(errno))); + } +} + + +void Oberon_PrintError(const char format[], ...) +{ + va_list ap; + + assert(initialized); + fprintf(stderr, "obnc-compile: %s:%d: ", inputFilename, yylineno); + va_start(ap, format); + vfprintf(stderr, format, ap); + va_end(ap); + fputc('\n', stderr); +} + + +void yyerror(const char msg[]) +{ + Oberon_PrintError("%s", msg); +} + + +static void PrintError(int line, const char format[], ...) + __attribute__ ((format (printf, 2, 3))); + +static void PrintError(int line, const char format[], ...) +{ + va_list ap; + + fprintf(stderr, "obnc-compile: %s:%d: ", inputFilename, line); + va_start(ap, format); + vfprintf(stderr, format, ap); + va_end(ap); + fputc('\n', stderr); +} + + +static char *IdentKindString(int kind) +{ + char *result; + + switch (kind) { + case TREES_CONSTANT_KIND: + result = Util_String("constant"); + break; + case TREES_TYPE_KIND: + result = Util_String("type"); + break; + case TREES_VARIABLE_KIND: + result = Util_String("variable"); + break; + case TREES_PROCEDURE_KIND: + result = Util_String("procedure"); + break; + case TREES_QUALIFIER_KIND: + result = Util_String("module"); + break; + default: + result = Util_String("identifier"); + } + return result; +} + + +static void CheckUnusedIdentifiers(void) +{ + Trees_Node unusedIdents, ident; + int kind; + + unusedIdents = Table_UnusedIdentifiers(); + while (unusedIdents != NULL) { + ident = Trees_Left(unusedIdents); + kind = Trees_Kind(ident); + if (! Trees_Exported(ident) + && (kind != TREES_VALUE_PARAM_KIND) + && (kind != TREES_VAR_PARAM_KIND)) { + PrintError(Trees_LineNumber(ident), "note: unused %s: %s", IdentKindString(Trees_Kind(ident)), Trees_UnaliasedName(ident)); + } + unusedIdents = Trees_Right(unusedIdents); + } +} + + +/*constant predicate functions*/ + +static int IsBoolean(Trees_Node node) +{ + return (Trees_Symbol(node) == TRUE) || (Trees_Symbol(node) == FALSE); +} + + +static int IsChar(Trees_Node node) +{ + return Trees_Symbol(node) == TREES_CHAR_CONSTANT; +} + + +static int IsInteger(Trees_Node node) +{ + return Trees_Symbol(node) == INTEGER; +} + + +static int IsReal(Trees_Node node) +{ + return Trees_Symbol(node) == REAL; +} + + +static int IsString(Trees_Node node) +{ + return Trees_Symbol(node) == STRING; +} + + +static int IsSet(Trees_Node node) +{ + return Trees_Symbol(node) == TREES_SET_CONSTANT; +} + + +/*functions for type declaration productions*/ + +static Trees_Node ResolvedType(Trees_Node type, int isTypeDecl) +{ + Trees_Node result, identDef, typeStruct; + const char *name; + + result = NULL; + if (Trees_Symbol(type) == IDENT) { + name = Trees_Name(type); + identDef = Table_At(name); + if (identDef != NULL) { + if (Trees_Kind(identDef) == TREES_TYPE_KIND) { + typeStruct = Types_Structure(identDef); + if (typeStruct != NULL) { + if (Types_Basic(Trees_Type(identDef)) && ! isTypeDecl) { + result = Trees_Type(identDef); + } else { + result = identDef; + } + } else { + Oberon_PrintError("error: unresolved type: %s", name); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: type expected: %s", name); + exit(EXIT_FAILURE); + } + } + } else { + result = type; + } + return result; +} + + +static void ResolvePointerTypes(Trees_Node baseType) +{ + const char *baseTypeName; + Trees_Node prev, curr, currPointerType, currBaseType; + + assert(Trees_Symbol(baseType) == IDENT); + baseTypeName = Trees_Name(baseType); + + prev = NULL; + curr = unresolvedPointerTypes; + while (curr != NULL) { + currPointerType = Trees_Left(curr); + currBaseType = Types_PointerBaseType(currPointerType); + if (strcmp(Trees_Name(currBaseType), baseTypeName) == 0) { + if (Types_IsRecord(baseType)) { + Trees_SetUsed(baseType); + /*update pointer base type*/ + Types_SetPointerBaseType(baseType, currPointerType); + /*delete current node*/ + if (curr == unresolvedPointerTypes) { + unresolvedPointerTypes = Trees_Right(curr); + } else { + Trees_SetRight(Trees_Right(curr), prev); + } + } else { + Oberon_PrintError("error: record type expected in declaration of pointer base type: %s", baseTypeName); + exit(EXIT_FAILURE); + } + } + prev = curr; + curr = Trees_Right(curr); + } +} + + +static const char *TypeString(Trees_Node type) +{ + const char *result = Util_String("%s", ""); + + assert(Types_IsType(type)); + + switch (Trees_Symbol(Types_Structure(type))) { + case TREES_STRING_TYPE: + switch (Types_StringLength(type)) { + case 0: + result = Util_String("empty string"); + break; + case 1: + result = Util_String("single-char string"); + break; + default: + result = Util_String("multi-char string"); + } + break; + case TREES_BOOLEAN_TYPE: + result = Util_String("BOOLEAN"); + break; + case TREES_CHAR_TYPE: + result = Util_String("CHAR"); + break; + case TREES_INTEGER_TYPE: + result = Util_String("INTEGER"); + break; + case TREES_REAL_TYPE: + result = Util_String("REAL"); + break; + case TREES_BYTE_TYPE: + result = Util_String("BYTE"); + break; + case TREES_SET_TYPE: + result = Util_String("SET"); + break; + case ARRAY: + if (Types_IsOpenArray(type)) { + result = Util_String("open array type"); + } else { + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("array type"); + } + break; + case RECORD: + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("record type"); + break; + case POINTER: + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("pointer type"); + break; + case PROCEDURE: + if (Trees_Symbol(type) != IDENT) { + result = Util_String("anonymous "); + } + result = Util_String("procedure type"); + break; + case TREES_NIL_TYPE: + result = Util_String("NIL"); + break; + default: + assert(0); + } + if (Trees_Symbol(type) == IDENT) { + result = Util_String("%s (%s)", Trees_Name(type), result); + } + return result; +} + + +/*functions for expression productions*/ + +static int IsDesignator(Trees_Node exp) +{ + return Trees_Symbol(exp) == TREES_DESIGNATOR; +} + + +static int IsValueExpression(Trees_Node exp) +{ + int result = 1; + + if (IsDesignator(exp)) { + switch (Trees_Kind(BaseIdent(exp))) { + case TREES_CONSTANT_KIND: + case TREES_FIELD_KIND: + case TREES_VARIABLE_KIND: + case TREES_PROCEDURE_KIND: + case TREES_VALUE_PARAM_KIND: + case TREES_VAR_PARAM_KIND: + break; + default: + result = 0; + } + } + return result; +} + + +static void CheckIsValueExpression(Trees_Node exp) +{ + if (! IsValueExpression(exp)) { + Oberon_PrintError("error: value expected: %s", Trees_Name(BaseIdent(exp))); + exit(EXIT_FAILURE); + } +} + + +static Trees_Node Designator(const char identName[], Trees_Node selectorList) +{ + Trees_Node identSym, qualidentSym, designator, qualidentSelectorList; + const char *qualidentName; + + /*set qualident name, symbol and selector list*/ + qualidentSym = NULL; + qualidentSelectorList = NULL; + identSym = Table_At(identName); + if ((identSym == NULL) && (procedureDeclarationStack != NULL) + && (strcmp(identName, Trees_Name(Trees_Left(procedureDeclarationStack))) == 0)) { + qualidentSym = Trees_Left(procedureDeclarationStack); + qualidentSelectorList = selectorList; + } else { + if (identSym != NULL) { + if (Trees_Kind(identSym) == TREES_QUALIFIER_KIND) { + if ((selectorList != NULL) && (Trees_Symbol(selectorList) == '.')) { + qualidentName = Util_String("%s.%s", identName, Trees_Name(Trees_Left(selectorList))); + qualidentSym = Table_At(qualidentName); + qualidentSelectorList = Trees_Right(selectorList); + if (qualidentSym == NULL) { + Oberon_PrintError("error: undeclared identifier: %s", qualidentName); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: '.' expected after qualifier: %s", identName); + exit(EXIT_FAILURE); + } + } else { + qualidentSym = identSym; + qualidentSelectorList = selectorList; + } + + } else { + Oberon_PrintError("error: undeclared identifier: %s", identName); + exit(EXIT_FAILURE); + } + } + assert(qualidentSym != NULL); + + designator = Trees_NewNode(TREES_DESIGNATOR, qualidentSym, qualidentSelectorList); + + return designator; +} + + +static Trees_Node BaseIdent(Trees_Node designator) +{ + assert(Trees_Symbol(designator) == TREES_DESIGNATOR); + + return Trees_Left(designator); +} + + +static Trees_Node FirstSelector(Trees_Node designator) +{ + assert(Trees_Symbol(designator) == TREES_DESIGNATOR); + + return Trees_Right(designator); +} + + +static void SetSelectorTypes(Trees_Node identType, Trees_Node designator, int *parameterListFound) +{ + Trees_Node currType, currTypeStruct, currSelector, prevSelector, indexExp, lengthNode, pointerNode, expList, extendedType, symbol, varField, typeField, fieldBaseType; + OBNC_INTEGER length, index; + const char *fieldName; + + currType = identType; + currSelector = FirstSelector(designator); + prevSelector = designator; + *parameterListFound = 0; + while ((currSelector != NULL) && ! *parameterListFound) { + currTypeStruct = Types_Structure(currType); + switch (Trees_Symbol(currSelector)) { + case '[': + if ((currTypeStruct != NULL) && (Trees_Symbol(currTypeStruct) == ARRAY)) { + indexExp = Trees_Left(currSelector); + lengthNode = Types_ArrayLength(currTypeStruct); + if ((lengthNode != NULL) && (Trees_Symbol(indexExp) == INTEGER)) { + length = Trees_Integer(lengthNode); + index = Trees_Integer(indexExp); + if ((index < 0) || (index >= length)) { + Oberon_PrintError("error: invalid array index: %" OBNC_INT_MOD "d not between 0 and %" OBNC_INT_MOD "d", index, (OBNC_INTEGER) (length - 1)); + exit(EXIT_FAILURE); + } + } + Trees_SetType(currType, currSelector); + currType = Types_ElementType(currTypeStruct); + } else { + Oberon_PrintError("error: array variable expected in element selector"); + exit(EXIT_FAILURE); + } + break; + case '.': + if (currType != NULL) { + switch (Trees_Symbol(currTypeStruct)) { + case POINTER: + pointerNode = Trees_NewNode('^', NULL, currSelector); + Trees_SetType(currType, pointerNode); + Trees_SetRight(pointerNode, prevSelector); + currType = Types_PointerBaseType(currTypeStruct); + /*fall through*/ + case RECORD: + Trees_SetType(currType, currSelector); + varField = Trees_Left(currSelector); + fieldName = Trees_Name(varField); + Types_GetFieldIdent(fieldName, currType, Trees_Imported(BaseIdent(designator)), &typeField, &fieldBaseType); + if (typeField != NULL) { + if (Trees_Exported(typeField)) { + Trees_SetExported(varField); + } + currType = Trees_Type(typeField); + } else { + Oberon_PrintError("error: undeclared field: %s", fieldName); + exit(EXIT_FAILURE); + } + break; + default: + Oberon_PrintError("error: record variable expected in field selector"); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: record variable expected in field selector"); + exit(EXIT_FAILURE); + } + break; + case '^': + if ((currType != NULL) && (Trees_Symbol(currTypeStruct) == POINTER)) { + Trees_SetType(currType, currSelector); + currType = Types_PointerBaseType(currTypeStruct); + } else { + Oberon_PrintError("error: pointer variable expected in pointer dereference"); + exit(EXIT_FAILURE); + } + break; + case '(': + if (Types_IsProcedure(currTypeStruct)) { + *parameterListFound = 1; + } else if (Types_IsRecord(currTypeStruct) || Types_IsPointer(currTypeStruct)) { + /*type guard*/ + expList = Trees_Left(currSelector); + if (Trees_Right(expList) == NULL) { + if ((Trees_Symbol(Trees_Left(expList)) == TREES_DESIGNATOR) + && (Trees_Right(Trees_Left(expList)) == NULL)) { + extendedType = Trees_Left(Trees_Left(expList)); + symbol = Table_At(Trees_Name(extendedType)); + if (symbol != NULL) { + if (Trees_Kind(symbol) == TREES_TYPE_KIND) { + if ((Types_IsRecord(currType) && Types_IsRecord(Trees_Type(symbol)) + && (Trees_Kind(BaseIdent(designator)) == TREES_VAR_PARAM_KIND)) + || (Types_IsPointer(currType) && Types_IsPointer(Trees_Type(symbol)))) { + if (Types_Extends(currType, Trees_Type(symbol))) { + Trees_SetLeft(extendedType, currSelector); + Trees_SetType(extendedType, currSelector); + currType = extendedType; + } else { + Oberon_PrintError("error: extended type expected: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } else { + if (Types_IsRecord(currType)) { + if (Trees_Kind(BaseIdent(designator)) != TREES_VAR_PARAM_KIND) { + Oberon_PrintError("error: variable parameter expected in type guard"); + } else { + Oberon_PrintError("error: record type expected in type guard: %s", Trees_Name(extendedType)); + } + exit(EXIT_FAILURE); + } else { + Oberon_PrintError("error: pointer type expected in type guard: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } + } else { + Oberon_PrintError("error: type name expected: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: undeclared identifier: %s", Trees_Name(extendedType)); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: identifier expected in type guard"); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: unexpected comma in type guard"); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: unexpected parenthesis in designator which is not a record, pointer or procedure"); + exit(EXIT_FAILURE); + } + break; + default: + assert(0); + } + prevSelector = currSelector; + currSelector = Trees_Right(currSelector); + } + + if (currSelector == NULL) { + Trees_SetType(currType, designator); + } else { + Oberon_PrintError("error: unexpected selector after procedure call"); + exit(EXIT_FAILURE); + } +} + + +static void RemoveActualParameters(Trees_Node *designator, Trees_Node *actualParameters) +{ + Trees_Node currSelector; + + currSelector = FirstSelector(*designator); + assert(currSelector != NULL); + if (Trees_Right(currSelector) == NULL) { + *actualParameters = Trees_Left(currSelector); + Trees_SetRight(NULL, *designator); + } else { + while (Trees_Right(Trees_Right(currSelector)) != NULL) { + currSelector = Trees_Right(currSelector); + } + *actualParameters = Trees_Left(Trees_Right(currSelector)); + Trees_SetRight(NULL, currSelector); + } +} + + +static int IsConstExpression(Trees_Node exp) +{ + int result = 0; + + assert(exp != NULL); + switch (Trees_Symbol(exp)) { + case TRUE: + case FALSE: + case STRING: + case TREES_CHAR_CONSTANT: + case INTEGER: + case REAL: + case TREES_SET_CONSTANT: + case NIL: + case TREES_SIZE_PROC: /*type sizes cannot always be evaluated in the Oberon-to-C translation*/ + result = 1; + break; + case IDENT: + case TREES_DESIGNATOR: + case TREES_ADR_PROC: + case TREES_BIT_PROC: + result = 0; + break; + default: + result = ((Trees_Left(exp) == NULL) || IsConstExpression(Trees_Left(exp))) + && ((Trees_Right(exp) == NULL) || IsConstExpression(Trees_Right(exp))); + } + return result; +} + + +static Trees_Node ExpressionConstValue(int relation, Trees_Node expA, Trees_Node expB) +{ + Trees_Node result = NULL; + + switch (relation) { + case '=': + switch (Trees_Symbol(expA)) { + case TRUE: + case FALSE: + if (IsBoolean(expB)) { + result = Trees_NewLeaf((Trees_Symbol(expA) == Trees_Symbol(expB))? TRUE: FALSE); + } + break; + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) == Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) == Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) == Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) == Trees_Real(expB))? TRUE: FALSE); + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewLeaf((Trees_Set(expA) == Trees_Set(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] == Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) == 0)? TRUE: FALSE); + } + break; + } + break; + case '#': + switch (Trees_Symbol(expA)) { + case TRUE: + case FALSE: + if (IsBoolean(expB)) { + result = Trees_NewLeaf((Trees_Symbol(expA) != Trees_Symbol(expB))? TRUE: FALSE); + } + break; + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) != Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) != Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) != Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) != Trees_Real(expB))? TRUE: FALSE); + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewLeaf((Trees_Set(expA) != Trees_Set(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] != Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) != 0)? TRUE: FALSE); + } + break; + } + break; + case '<': + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) < Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) < Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) < Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) < Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] < Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) < 0)? TRUE: FALSE); + } + break; + } + break; + case LE: + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) <= Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) <= Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) <= Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) <= Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] <= Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) <= 0)? TRUE: FALSE); + } + break; + } + break; + case '>': + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) > Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) > Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) > Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) > Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] > Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) > 0)? TRUE: FALSE); + } + break; + } + break; + case GE: + switch (Trees_Symbol(expA)) { + case TREES_CHAR_CONSTANT: + if (IsString(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) >= Trees_String(expB)[0])? TRUE: FALSE); + } else if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_Char(expA) >= Trees_Char(expB))? TRUE: FALSE); + } + break; + case INTEGER: + if (IsInteger(expB)) { + result = Trees_NewLeaf((Trees_Integer(expA) >= Trees_Integer(expB))? TRUE: FALSE); + } + break; + case REAL: + if (IsReal(expB)) { + result = Trees_NewLeaf((Trees_Real(expA) >= Trees_Real(expB))? TRUE: FALSE); + } + break; + case STRING: + if (IsChar(expB)) { + result = Trees_NewLeaf((Trees_String(expA)[0] >= Trees_Char(expB))? TRUE: FALSE); + } else if (IsString(expB)) { + result = Trees_NewLeaf((strcmp(Trees_String(expA), Trees_String(expB)) >= 0)? TRUE: FALSE); + } + break; + } + break; + case IN: + if (IsInteger(expA)) { + Range_CheckSetElement(Trees_Integer(expA)); + if (IsSet(expB)) { + result = Trees_NewLeaf(OBNC_IN(Trees_Integer(expA), Trees_Set(expB))? TRUE: FALSE); + } + } + break; + } + if (result != NULL) { + Trees_SetType(Trees_NewLeaf(TREES_BOOLEAN_TYPE), result); + } + + return result; +} + + +static Trees_Node SimpleExpressionConstValue(int operator, Trees_Node expA, Trees_Node expB) +{ + Trees_Node result = NULL; + + switch (operator) { + case '+': + switch (Trees_Symbol(expA)) { + case INTEGER: + if (expB == NULL) { + result = expA; + } else if (IsInteger(expB)) { + Range_CheckIntSum(Trees_Integer(expA), Trees_Integer(expB)); + result = Trees_NewInteger(Trees_Integer(expA) + Trees_Integer(expB)); + } + break; + case REAL: + if (expB == NULL) { + result = expA; + } else if (IsReal(expB)) { + Range_CheckRealSum(Trees_Real(expA), Trees_Real(expB)); + result = Trees_NewReal(Trees_Real(expA) + Trees_Real(expB)); + } + break; + case TREES_SET_CONSTANT: + if (expB == NULL) { + result = expA; + } else if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) | Trees_Set(expB)); + } + break; + } + break; + case '-': + switch (Trees_Symbol(expA)) { + case INTEGER: + if (expB == NULL) { + Range_CheckIntDiff(0, Trees_Integer(expA)); + result = Trees_NewInteger(-Trees_Integer(expA)); + } else if (IsInteger(expB)) { + Range_CheckIntDiff(Trees_Integer(expA), Trees_Integer(expB)); + result = Trees_NewInteger(Trees_Integer(expA) - Trees_Integer(expB)); + } + break; + case REAL: + if (expB == NULL) { + Range_CheckRealDiff(0.0, Trees_Real(expA)); + result = Trees_NewReal(-Trees_Real(expA)); + } else if (IsReal(expB)) { + Range_CheckRealDiff(Trees_Real(expA), Trees_Real(expB)); + result = Trees_NewReal(Trees_Real(expA) - Trees_Real(expB)); + } + break; + case TREES_SET_CONSTANT: + if (expB == NULL) { + result = Trees_NewSet(~Trees_Set(expA)); + } else if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) & ~Trees_Set(expB)); + } + break; + } + break; + case OR: + if (IsBoolean(expA) && IsBoolean(expB)) { + result = (Trees_Symbol(expA) == TRUE)? expA: expB; + } + break; + } + + return result; +} + + +static Trees_Node TermConstValue(int operator, Trees_Node expA, Trees_Node expB) +{ + Trees_Node result = NULL; + + switch (operator) { + case '*': + switch (Trees_Symbol(expA)) { + case INTEGER: + if (IsInteger(expB)) { + Range_CheckIntProd(Trees_Integer(expA), Trees_Integer(expB)); + result = Trees_NewInteger(Trees_Integer(expA) * Trees_Integer(expB)); + } + break; + case REAL: + if (IsReal(expB)) { + Range_CheckRealProd(Trees_Real(expA), Trees_Real(expB)); + result = Trees_NewReal(Trees_Real(expA) * Trees_Real(expB)); + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) & Trees_Set(expB)); + } + break; + } + break; + case '/': + switch (Trees_Symbol(expA)) { + case REAL: + if (IsReal(expA) && IsReal(expB)) { + if (Trees_Real(expB) != 0) { + result = Trees_NewReal(Trees_Real(expA) / Trees_Real(expB)); + } else { + Oberon_PrintError("warning: division by zero"); + } + } + break; + case TREES_SET_CONSTANT: + if (IsSet(expB)) { + result = Trees_NewSet(Trees_Set(expA) ^ Trees_Set(expB)); + } + break; + } + break; + case DIV: + if (IsInteger(expA) && IsInteger(expB)) { + if (Trees_Integer(expB) > 0) { + result = Trees_NewInteger(OBNC_DIV(Trees_Integer(expA), Trees_Integer(expB))); + } else { + Oberon_PrintError("error: positive divisor expected in DIV expression: %" OBNC_INT_MOD "d", Trees_Integer(expB)); + exit(EXIT_FAILURE); + } + } + break; + case MOD: + if (IsInteger(expA) && IsInteger(expB)) { + if (Trees_Integer(expB) > 0) { + result = Trees_NewInteger(OBNC_MOD(Trees_Integer(expA), Trees_Integer(expB))); + } else { + Oberon_PrintError("error: positive divisor expected in MOD expression: %" OBNC_INT_MOD "d", Trees_Integer(expB)); + exit(EXIT_FAILURE); + } + } + break; + case '&': + if (IsBoolean(expA) && IsBoolean(expB)) { + if (Trees_Symbol(expA) == TRUE) { + result = expB; + } else { + result = expA; + } + } + break; + } + + return result; +} + + +static const char *DesignatorString(Trees_Node designator) +{ + const char *baseName, *result; + + assert(IsDesignator(designator)); + + baseName = Trees_Name(BaseIdent(designator)); + if (FirstSelector(designator) != NULL) { + result = Util_String("%s...", baseName); + } else { + result = Util_String("%s", baseName); + } + return result; +} + + +static const char *OperatorString(int operator) +{ + const char *result = ""; + + switch (operator) { + case '+': + result = "+"; + break; + case '-': + result = "-"; + break; + case '*': + result = "*"; + break; + case '/': + result = "/"; + break; + case DIV: + result = "DIV"; + break; + case MOD: + result = "MOD"; + break; + case OR: + result = "OR"; + break; + case '&': + result = "&"; + break; + case '~': + result = "~"; + break; + case '=': + result = "="; + break; + case '#': + result = "#"; + break; + case '<': + result = "<"; + break; + case LE: + result = "<="; + break; + case '>': + result = ">"; + break; + case GE: + result = ">="; + break; + case IN: + result = "IN"; + break; + case IS: + result = "IS"; + break; + default: + assert(0); + } + return result; +} + + +/*functions for statement productions*/ + +static int Writable(Trees_Node designator) +{ + Trees_Node ident, type; + int kind, result; + + assert(IsDesignator(designator)); + + ident = BaseIdent(designator); + kind = Trees_Kind(ident); + type = Trees_Type(ident); + result = ((kind == TREES_VARIABLE_KIND) && ! Trees_Imported(ident)) + || (kind == TREES_VAR_PARAM_KIND) + || ((kind == TREES_VALUE_PARAM_KIND) && ! Types_IsArray(type) && ! Types_IsRecord(type)); + return result; +} + + +static const char *AssignmentErrorContext(int context, int paramPos) +{ + const char *result; + + switch (context) { + case ASSIGNMENT_CONTEXT: + result = Util_String("assignment"); + break; + case PARAM_SUBST_CONTEXT: + assert(paramPos >= 0); + result = Util_String("substitution of parameter %d", paramPos + 1); + break; + case PROC_RESULT_CONTEXT: + result = Util_String("return clause"); + break; + default: + assert(0); + } + return result; +} + + +static void ValidateAssignment(Trees_Node expression, Trees_Node targetType, int context, int paramPos) +{ + const char *errorContext; + + assert(expression != NULL); + assert(targetType != NULL); + assert(context >= 0); + assert(paramPos >= 0); + if (Types_AssignmentCompatible(expression, targetType)) { + if (Types_IsByte(targetType) && IsInteger(expression)) { + Range_CheckByte(Trees_Integer(expression)); + } + } else { + errorContext = AssignmentErrorContext(context, paramPos); + if (IsString(expression) && Types_IsCharacterArray(targetType) && !Types_IsOpenArray(targetType)) { + Oberon_PrintError("error: string too long in %s: %" OBNC_INT_MOD "d + 1 > %" OBNC_INT_MOD "d", errorContext, Types_StringLength(Trees_Type(expression)), Trees_Integer(Types_ArrayLength(targetType))); + exit(EXIT_FAILURE); + } else if (Types_IsPredeclaredProcedure(Trees_Type(expression)) + && Types_IsProcedure(targetType)) { + Oberon_PrintError("error: non-predeclared procedure expected in %s", errorContext); + exit(EXIT_FAILURE); + } else { + Oberon_PrintError("error: incompatible types in %s: %s -> %s", + errorContext, TypeString(Trees_Type(expression)), TypeString(targetType)); + exit(EXIT_FAILURE); + } + } +} + + +static void ValidateActualParameter(Trees_Node actualParam, Trees_Node formalParam, int paramPos, Trees_Node procDesignator) +{ + Trees_Node formalType, actualType; + + formalType = Trees_Type(formalParam); + actualType = Trees_Type(actualParam); + + if ((Trees_Kind(formalParam) == TREES_VALUE_PARAM_KIND) + || (IsDesignator(actualParam) && Writable(actualParam))) { + if (Types_IsOpenArray(formalType)) { + if (! Types_ArrayCompatible(actualType, formalType)) { + Oberon_PrintError("error: array incompatible types in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } else if (Trees_Kind(formalParam) == TREES_VALUE_PARAM_KIND) { + if (! Types_AssignmentCompatible(actualParam, formalType)) { + if (Types_IsString(actualType) && Types_IsCharacterArray(formalType)) { + Oberon_PrintError("error: string too long in substitution of parameter %d: %" OBNC_INT_MOD "d + 1 > %" OBNC_INT_MOD "d", paramPos + 1, Types_StringLength(actualType), Trees_Integer(Types_ArrayLength(formalType))); + } else { + Oberon_PrintError("error: assignment incompatible types in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + } + exit(EXIT_FAILURE); + } + } else if (Trees_Kind(formalParam) == TREES_VAR_PARAM_KIND) { + if (Types_IsRecord(formalType)) { + if (Types_IsRecord(actualType)) { + if (! Types_Extends(formalType, actualType)) { + Oberon_PrintError("error: incompatible record types in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } else { + Oberon_PrintError("error: record expected in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } else { + if (! Types_Same(actualType, formalType)) { + Oberon_PrintError("error: same types expected in substitution of parameter %d in %s: %s -> %s", paramPos + 1, DesignatorString(procDesignator), TypeString(actualType), TypeString(formalType)); + exit(EXIT_FAILURE); + } + } + } + } else { + Oberon_PrintError("error: writable variable expected in substitution of parameter %d in %s", + paramPos + 1, DesignatorString(procDesignator)); + exit(EXIT_FAILURE); + } +} + + +static void ValidateProcedureCall(Trees_Node expList, Trees_Node fpList, Trees_Node procDesignator) +{ + Trees_Node exp, formalParam, fpType; + int pos; + + pos = 0; + while ((expList != NULL) && (fpList != NULL)) { + exp = Trees_Left(expList); + CheckIsValueExpression(exp); + formalParam = Trees_Left(fpList); + fpType = Trees_Type(formalParam); + ValidateActualParameter(exp, formalParam, pos, procDesignator); + + if (Types_IsChar(fpType) && (Trees_Symbol(exp) == STRING)) { + Trees_SetLeft(Trees_NewChar(Trees_String(exp)[0]), expList); + } + expList = Trees_Right(expList); + fpList = Trees_Right(fpList); + pos++; + } + if ((expList == NULL) && (fpList != NULL)) { + Oberon_PrintError("error: too few actual parameters in procedure call: %s", DesignatorString(procDesignator)); + exit(EXIT_FAILURE); + } else if ((expList != NULL) && (fpList == NULL)) { + Oberon_PrintError("error: too many actual parameters in procedure call: %s", DesignatorString(procDesignator)); + exit(EXIT_FAILURE); + } +} + + +static void ValidateProcedureKind(const char procName[], int functionCallExpected, int isFunctionCall) +{ + if (isFunctionCall && ! functionCallExpected) { + Oberon_PrintError("error: function procedure expected: %s", procName); + exit(EXIT_FAILURE); + } else if (! isFunctionCall && functionCallExpected) { + Oberon_PrintError("error: proper procedure expected: %s", procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateParameterCount(const char procName[], int min, int max, int actual) +{ + assert(min >= 0); + assert(min <= max); + assert(actual >= 0); + + if ((actual < min) || (actual > max)) { + if (min == max) { + Oberon_PrintError("error: %d parameter(s) expected: %s", min, procName); + } else { + Oberon_PrintError("error: %d or %d parameters expected: %s", min, max, procName); + } + exit(EXIT_FAILURE); + } +} + + +static void ValidateTypeParameter(const char procName[], Trees_Node param, int pos) +{ + if (! (IsDesignator(param) && (Trees_Kind(BaseIdent(param)) == TREES_TYPE_KIND))) { + Oberon_PrintError("error: type identifier expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateValueParameter(const char procName[], Trees_Node param, int pos) +{ + if (! IsValueExpression(param)) { + Oberon_PrintError("error: expression expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateVariableParameter(const char procName[], Trees_Node param, int pos) +{ + if (! IsDesignator(param)) { + Oberon_PrintError("error: variable expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } else if (! Writable(param)) { + Oberon_PrintError("error: writable variable expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateScalarParameter(const char procName[], Trees_Node paramType, int pos) +{ + assert(Types_IsType(paramType)); + + if (! Types_Scalar(paramType)) { + Oberon_PrintError("error: scalar type expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateIntegerParameter(const char procName[], Trees_Node param, int pos) +{ + if (! Types_IsInteger(Trees_Type(param))) { + Oberon_PrintError("error: integer expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static void ValidateRealParameter(const char procName[], Trees_Node param, int pos) +{ + if (! Types_IsReal(Trees_Type(param))) { + Oberon_PrintError("error: parameter of type REAL expected in substitution of parameter %d: %s", pos + 1, procName); + exit(EXIT_FAILURE); + } +} + + +static OBNC_INTEGER TypeSize(Trees_Node type) +{ + OBNC_INTEGER result = 0; + + switch (Trees_Symbol(Types_Structure(type))) { + case TREES_BOOLEAN_TYPE: + result = sizeof (int); + break; + case TREES_CHAR_TYPE: + result = sizeof (char); + break; + case TREES_INTEGER_TYPE: + result = sizeof (OBNC_INTEGER); + break; + case TREES_REAL_TYPE: + result = sizeof (OBNC_REAL); + break; + case TREES_BYTE_TYPE: + result = sizeof (unsigned char); + break; + case TREES_SET_TYPE: + result = sizeof (unsigned OBNC_INTEGER); + break; + case ARRAY: + result = Trees_Integer(Types_ArrayLength(type)) * TypeSize(Types_ElementType(type)); + break; + case RECORD: + case POINTER: + case PROCEDURE: + /*cannot be calculated in the Oberon-to-C translation*/ + break; + default: + assert(0); + } + return result; +} + + +static Trees_Node PredeclaredProcedureAST(const char procName[], Trees_Node expList, int isFunctionCall) +{ + static const struct { const char *name; int symbol; } symbols[] = { + {"ABS", TREES_ABS_PROC}, + {"ASR", TREES_ASR_PROC}, + {"ASSERT", TREES_ASSERT_PROC}, + {"CHR", TREES_CHR_PROC}, + {"DEC", TREES_DEC_PROC}, + {"EXCL", TREES_EXCL_PROC}, + {"FLOOR", TREES_FLOOR_PROC}, + {"FLT", TREES_FLT_PROC}, + {"INC", TREES_INC_PROC}, + {"INCL", TREES_INCL_PROC}, + {"LEN", TREES_LEN_PROC}, + {"LSL", TREES_LSL_PROC}, + {"NEW", TREES_NEW_PROC}, + {"ODD", TREES_ODD_PROC}, + {"ORD", TREES_ORD_PROC}, + {"PACK", TREES_PACK_PROC}, + {"ROR", TREES_ROR_PROC}, + {"UNPK", TREES_UNPK_PROC}, + + {"ADR", TREES_ADR_PROC}, + {"SIZE", TREES_SIZE_PROC}, + {"BIT", TREES_BIT_PROC}, + {"GET", TREES_GET_PROC}, + {"PUT", TREES_PUT_PROC}, + {"COPY", TREES_COPY_PROC}, + {"VAL", TREES_VAL_PROC}}; + + int paramCount, pos, symbol; + Trees_Node curr, resultType, result; + Trees_Node param[3], paramTypes[3]; + const char *unqualProcName; + + /*set actual parameters*/ + paramCount = 0; + curr = expList; + while ((paramCount < LEN(param)) && (curr != NULL)) { + param[paramCount] = Trees_Left(curr); + paramTypes[paramCount] = Trees_Type(Trees_Left(curr)); + paramCount++; + curr = Trees_Right(curr); + } + + /*find procedure symbol*/ + unqualProcName = strchr(procName, '.'); + if (unqualProcName != NULL) { + unqualProcName++; + } else { + unqualProcName = procName; + } + pos = 0; + while ((pos < LEN(symbols)) && (strcmp(symbols[pos].name, unqualProcName) != 0)) { + pos++; + } + assert(pos < LEN(symbols)); + symbol = symbols[pos].symbol; + + /*validate parameters and build syntax tree*/ + result = NULL; + resultType = NULL; + switch (symbol) { + case TREES_ABS_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + switch (Trees_Symbol(Types_Structure(paramTypes[0]))) { + case TREES_INTEGER_TYPE: + if (IsInteger(param[0])) { + result = Trees_NewInteger(OBNC_ABS_INT(Trees_Integer(param[0]))); + } + break; + case TREES_REAL_TYPE: + if (IsReal(param[0])) { + result = Trees_NewReal(OBNC_ABS_FLT(Trees_Real(param[0]))); + } + break; + case TREES_BYTE_TYPE: + /*do nothing*/ + break; + default: + Oberon_PrintError("error: numeric parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + if (result == NULL) { + resultType = paramTypes[0]; + } + break; + case TREES_ODD_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (IsInteger(param[0])) { + result = Trees_NewBoolean(OBNC_ODD(Trees_Integer(param[0]))); + } else { + resultType = Trees_NewLeaf(TREES_BOOLEAN_TYPE); + } + break; + case TREES_LEN_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + if (Types_IsArray(paramTypes[0])) { + if (! Types_IsOpenArray(paramTypes[0])) { + result = Types_ArrayLength(paramTypes[0]); + } else { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + } else { + Oberon_PrintError("error: array parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_LSL_PROC: /*fall through*/ + case TREES_ASR_PROC: /*fall through*/ + case TREES_ROR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + if (IsInteger(param[1])) { + switch (symbol) { + case TREES_LSL_PROC: + Range_CheckLSL(Trees_Integer(param[1])); + break; + case TREES_ASR_PROC: + Range_CheckASR(Trees_Integer(param[1])); + break; + case TREES_ROR_PROC: + Range_CheckROR(Trees_Integer(param[1])); + break; + default: + assert(0); + } + } + if (IsInteger(param[0]) && IsInteger(param[1])) { + switch (symbol) { + case TREES_LSL_PROC: + result = Trees_NewInteger(OBNC_LSL(Trees_Integer(param[0]), Trees_Integer(param[1]))); + break; + case TREES_ASR_PROC: + result = Trees_NewInteger(OBNC_ASR(Trees_Integer(param[0]), Trees_Integer(param[1]))); + break; + case TREES_ROR_PROC: + result = Trees_NewInteger(OBNC_ROR(Trees_Integer(param[0]), Trees_Integer(param[1]))); + break; + default: + assert(0); + } + } + if (result == NULL) { + resultType = paramTypes[0]; + } + break; + case TREES_FLOOR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateRealParameter(procName, param[0], 0); + if (IsReal(param[0])) { + OBNC_REAL x = Trees_Real(param[0]); + Range_CheckFLOOR(x); + result = Trees_NewInteger(OBNC_FLOOR(x)); + } else { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + break; + case TREES_FLT_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (IsInteger(param[0])) { + result = Trees_NewReal(OBNC_FLT(Trees_Integer(param[0]))); + } else { + resultType = Trees_NewLeaf(TREES_REAL_TYPE); + } + break; + case TREES_ORD_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + switch (Trees_Symbol(Types_Structure(paramTypes[0]))) { + case TREES_CHAR_TYPE: + /*do nothing*/ + break; + case TREES_STRING_TYPE: + if (Types_StringLength(paramTypes[0]) <= 1) { + result = Trees_NewInteger((unsigned char) Trees_String(param[0])[0]); + } else { + Oberon_PrintError("error: single-character string parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_BOOLEAN_TYPE: + if (Trees_Symbol(param[0]) == TRUE) { + result = Trees_NewInteger(1); + } else if (Trees_Symbol(param[0]) == FALSE) { + result = Trees_NewInteger(0); + } + break; + case TREES_SET_TYPE: + if (IsSet(param[0])) { + result = Trees_NewInteger((OBNC_INTEGER) Trees_Set(param[0])); + } + break; + default: + Oberon_PrintError("error: character parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + if (result == NULL) { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + break; + case TREES_CHR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (IsInteger(param[0])) { + OBNC_INTEGER i = Trees_Integer(param[0]); + Range_CheckCHR(i); + result = Trees_NewChar(OBNC_CHR(i)); + } else { + resultType = Trees_NewLeaf(TREES_CHAR_TYPE); + } + break; + case TREES_INC_PROC: /*fall through*/ + case TREES_DEC_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + if (paramCount == 2) { + ValidateIntegerParameter(procName, param[1], 1); + } + break; + case TREES_INCL_PROC: /*fall through*/ + case TREES_EXCL_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + if (Types_IsSet(paramTypes[0])) { + if (IsInteger(param[1])) { + Range_CheckSetElement(Trees_Integer(param[1])); + } else { + ValidateIntegerParameter(procName, param[1], 1); + } + } else { + Oberon_PrintError("error: set expected in substitution of parameter 1: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_ASSERT_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateValueParameter(procName, param[0], 0); + if (! Types_IsBoolean(paramTypes[0])) { + Oberon_PrintError("error: boolean parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_NEW_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateVariableParameter(procName, param[0], 0); + if (! Types_IsPointer(paramTypes[0])) { + Oberon_PrintError("error: pointer parameter expected: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_PACK_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateRealParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + break; + case TREES_UNPK_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateVariableParameter(procName, param[0], 0); + ValidateRealParameter(procName, param[0], 0); + ValidateVariableParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + break; + case TREES_ADR_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateVariableParameter(procName, param[0], 0); + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + break; + case TREES_SIZE_PROC: + { + OBNC_INTEGER size; + + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 1, 1, paramCount); + ValidateTypeParameter(procName, param[0], 0); + size = TypeSize(Trees_Type(BaseIdent(param[0]))); + if (size > 0) { + result = Trees_NewInteger(size); + } else { + resultType = Trees_NewLeaf(TREES_INTEGER_TYPE); + } + } + break; + case TREES_BIT_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + if (IsInteger(param[1])) { + Range_CheckBIT(Trees_Integer(param[1])); + } + resultType = Trees_NewLeaf(TREES_BOOLEAN_TYPE); + break; + case TREES_GET_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateVariableParameter(procName, param[1], 1); + if (! Types_Basic(paramTypes[1])) { + Oberon_PrintError("error: variable of basic type expected in substitution of parameter 2: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_PUT_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + if (! Types_Basic(paramTypes[1]) && ! Types_IsSingleCharString(paramTypes[1])) { + Oberon_PrintError("error: expression of basic type expected in substitution of parameter 2: %s", procName); + exit(EXIT_FAILURE); + } + break; + case TREES_COPY_PROC: + ValidateProcedureKind(procName, 0, isFunctionCall); + ValidateParameterCount(procName, 3, 3, paramCount); + ValidateValueParameter(procName, param[0], 0); + ValidateIntegerParameter(procName, param[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateIntegerParameter(procName, param[1], 1); + ValidateValueParameter(procName, param[2], 2); + ValidateIntegerParameter(procName, param[2], 2); + if (IsInteger(param[2]) && (Trees_Integer(param[2]) < 0)) { + Oberon_PrintError("warning: non-negative count expected in %s: %" OBNC_INT_MOD "d", procName, Trees_Integer(param[2])); + } + break; + case TREES_VAL_PROC: + ValidateProcedureKind(procName, 1, isFunctionCall); + ValidateParameterCount(procName, 2, 2, paramCount); + ValidateTypeParameter(procName, param[0], 0); + ValidateScalarParameter(procName, paramTypes[0], 0); + ValidateValueParameter(procName, param[1], 1); + ValidateScalarParameter(procName, paramTypes[1], 1); + resultType = paramTypes[0]; + if (IsConstExpression(param[1])) { + result = param[1]; + Trees_SetType(resultType, result); + } + break; + default: + assert(0); + } + + if (result == NULL) { + result = Trees_NewNode(symbol, expList, NULL); + if (isFunctionCall) { + assert(resultType != NULL); + Trees_SetType(resultType, result); + } + } + return result; +} + + +static void HandleProcedureCall(Trees_Node designator, Trees_Node expList, int isFunctionCall, Trees_Node *ast) +{ + Trees_Node ident, designatorTypeStruct, fpList, resultType; + + ident = BaseIdent(designator); + if (Types_IsPredeclaredProcedure(Trees_Type(ident))) { + *ast = PredeclaredProcedureAST(Trees_Name(ident), expList, isFunctionCall); + if (*ast == NULL) { + Oberon_PrintError("error: procedure expected"); + exit(EXIT_FAILURE); + } + } else { + /*handle non-predeclared procedure*/ + designatorTypeStruct = Types_Structure(Trees_Type(designator)); + if (Types_IsProcedure(designatorTypeStruct)) { + fpList =Types_Parameters(designatorTypeStruct); + resultType = Types_ResultType(designatorTypeStruct); + ValidateProcedureCall(expList, fpList, designator); + *ast = Trees_NewNode(TREES_PROCEDURE_CALL, designator, expList); + if (isFunctionCall) { + if (resultType != NULL) { + Trees_SetType(resultType, *ast); + } else { + Oberon_PrintError("error: function procedure expected: %s", Trees_Name(ident)); + exit(EXIT_FAILURE); + } + } else if (resultType != NULL) { + Oberon_PrintError("error: proper procedure expected: %s", Trees_Name(ident)); + exit(EXIT_FAILURE); + } + } + } + assert(*ast != NULL); +} + + +static void CheckIntegerLabelDisjointness(Trees_Node rangeA, Trees_Node rangeB) +{ + OBNC_INTEGER aMin, aMax, bMin, bMax; + + if (Trees_Symbol(rangeA) == DOTDOT) { + aMin = Trees_Integer(Trees_Left(rangeA)); + aMax = Trees_Integer(Trees_Right(rangeA)); + } else { + aMin = Trees_Integer(rangeA); + aMax = Trees_Integer(rangeA); + } + if (Trees_Symbol(rangeB) == DOTDOT) { + bMin = Trees_Integer(Trees_Left(rangeB)); + bMax = Trees_Integer(Trees_Right(rangeB)); + } else { + bMin = Trees_Integer(rangeB); + bMax = Trees_Integer(rangeB); + } + + if ((aMin >= bMin) && (aMin <= bMax)) { + Oberon_PrintError("error: case label defined twice: %" OBNC_INT_MOD "d", aMin); + exit(EXIT_FAILURE); + } else if ((bMin >= aMin) && (bMin <= aMax)) { + Oberon_PrintError("error: case label defined twice: %" OBNC_INT_MOD "d", bMin); + exit(EXIT_FAILURE); + } +} + + +static void CheckCharLabelDisjointness(Trees_Node rangeA, Trees_Node rangeB) +{ + char aMin, aMax, bMin, bMax; + int hasRepeatedLabel, repeatedLabel; + + if (Trees_Symbol(rangeA) == DOTDOT) { + aMin = Trees_Char(Trees_Left(rangeA)); + aMax = Trees_Char(Trees_Right(rangeA)); + } else { + aMin = Trees_Char(rangeA); + aMax = Trees_Char(rangeA); + } + if (Trees_Symbol(rangeB) == DOTDOT) { + bMin = Trees_Char(Trees_Left(rangeB)); + bMax = Trees_Char(Trees_Right(rangeB)); + } else { + bMin = Trees_Char(rangeB); + bMax = Trees_Char(rangeB); + } + + if ((aMin >= bMin) && (aMin <= bMax)) { + hasRepeatedLabel = 1; + repeatedLabel = aMin; + } else if ((bMin >= aMin) && (bMin <= aMax)) { + hasRepeatedLabel = 1; + repeatedLabel = bMin; + } else { + hasRepeatedLabel = 0; + } + if (hasRepeatedLabel) { + if (isprint(repeatedLabel)) { + Oberon_PrintError("error: case label defined twice: \"%c\"", repeatedLabel); + } else { + Oberon_PrintError("error: case label defined twice: 0%XX", repeatedLabel); + } + exit(EXIT_FAILURE); + } +} + + +static void CheckCaseLabelUniqueness(Trees_Node newLabelRange) +{ + int labelSymbol; + Trees_Node labelList, definedLabelRange; + + if (Trees_Symbol(newLabelRange) == DOTDOT) { + labelSymbol = Trees_Symbol(Trees_Left(newLabelRange)); + } else { + labelSymbol = Trees_Symbol(newLabelRange); + } + + labelList = Trees_Left(caseLabelsStack); + while (labelList != NULL) { + definedLabelRange = Trees_Left(labelList); + switch (labelSymbol) { + case INTEGER: + CheckIntegerLabelDisjointness(definedLabelRange, newLabelRange); + break; + case TREES_CHAR_CONSTANT: + CheckCharLabelDisjointness(definedLabelRange, newLabelRange); + break; + case IDENT: + if (Types_Same(definedLabelRange, newLabelRange)) { + Oberon_PrintError("error: type case label defined twice: %s", Trees_Name(newLabelRange)); + exit(EXIT_FAILURE); + } + break; + default: + assert(0); + } + labelList = Trees_Right(labelList); + } +} + + +/*functions for module productions*/ + +static void ExportSymbolTable(const char symfilePath[]) +{ + const char *tempSymfilePath; + + if (! Files_Exists(".obnc")) { + Files_CreateDir(".obnc"); + } + tempSymfilePath = Util_String(".obnc/%s.sym.%d", inputModuleName, getpid()); + Table_Export(tempSymfilePath); + Files_Move(tempSymfilePath, symfilePath); +} diff --git a/src/y.tab.h b/src/y.tab.h new file mode 100644 index 0000000..c709f39 --- /dev/null +++ b/src/y.tab.h @@ -0,0 +1,168 @@ +/* A Bison parser, made by GNU Bison 3.3.2. */ + +/* Bison interface for Yacc-like parsers in C + + Copyright (C) 1984, 1989-1990, 2000-2015, 2018-2019 Free Software Foundation, + Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* As a special exception, you may create a larger work that contains + part or all of the Bison parser skeleton and distribute that work + under terms of your choice, so long as that work isn't itself a + parser generator using the skeleton or a modified version thereof + as a parser skeleton. Alternatively, if you modify or redistribute + the parser skeleton itself, you may (at your option) remove this + special exception, which will cause the skeleton and the resulting + Bison output files to be licensed under the GNU General Public + License without this special exception. + + This special exception was added by the Free Software Foundation in + version 2.2 of Bison. */ + +/* Undocumented macros, especially those whose name start with YY_, + are private implementation details. Do not rely on them. */ + +#ifndef YY_YY_Y_TAB_H_INCLUDED +# define YY_YY_Y_TAB_H_INCLUDED +/* Debug traces. */ +#ifndef YYDEBUG +# define YYDEBUG 1 +#endif +#if YYDEBUG +extern int yydebug; +#endif + +/* Token type. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + enum yytokentype + { + TOKEN_START = 258, + ARRAY = 259, + BEGIN_ = 260, + BY = 261, + CASE = 262, + CONST = 263, + DIV = 264, + DO = 265, + ELSE = 266, + ELSIF = 267, + END = 268, + FALSE = 269, + FOR = 270, + IF = 271, + IMPORT = 272, + IN = 273, + IS = 274, + MOD = 275, + MODULE = 276, + NIL = 277, + OF = 278, + OR = 279, + POINTER = 280, + PROCEDURE = 281, + RECORD = 282, + REPEAT = 283, + RETURN = 284, + THEN = 285, + TO = 286, + TRUE = 287, + TYPE = 288, + UNTIL = 289, + VAR = 290, + WHILE = 291, + BECOMES = 292, + DOTDOT = 293, + GE = 294, + LE = 295, + IDENT = 296, + INTEGER = 297, + REAL = 298, + STRING = 299, + TOKEN_END = 300 + }; +#endif +/* Tokens. */ +#define TOKEN_START 258 +#define ARRAY 259 +#define BEGIN_ 260 +#define BY 261 +#define CASE 262 +#define CONST 263 +#define DIV 264 +#define DO 265 +#define ELSE 266 +#define ELSIF 267 +#define END 268 +#define FALSE 269 +#define FOR 270 +#define IF 271 +#define IMPORT 272 +#define IN 273 +#define IS 274 +#define MOD 275 +#define MODULE 276 +#define NIL 277 +#define OF 278 +#define OR 279 +#define POINTER 280 +#define PROCEDURE 281 +#define RECORD 282 +#define REPEAT 283 +#define RETURN 284 +#define THEN 285 +#define TO 286 +#define TRUE 287 +#define TYPE 288 +#define UNTIL 289 +#define VAR 290 +#define WHILE 291 +#define BECOMES 292 +#define DOTDOT 293 +#define GE 294 +#define LE 295 +#define IDENT 296 +#define INTEGER 297 +#define REAL 298 +#define STRING 299 +#define TOKEN_END 300 + +/* Value type. */ +#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED + +union YYSTYPE +{ +#line 107 "Oberon.y" /* yacc.c:1921 */ + + const char *ident; + OBNC_INTEGER integer; + OBNC_REAL real; + const char *string; + Trees_Node node; + +#line 156 "y.tab.h" /* yacc.c:1921 */ +}; + +typedef union YYSTYPE YYSTYPE; +# define YYSTYPE_IS_TRIVIAL 1 +# define YYSTYPE_IS_DECLARED 1 +#endif + + +extern YYSTYPE yylval; + +int yyparse (void); + +#endif /* !YY_YY_Y_TAB_H_INCLUDED */ diff --git a/test b/test new file mode 100755 index 0000000..44775ea --- /dev/null +++ b/test @@ -0,0 +1,95 @@ +#!/bin/sh + +# Copyright (C) 2017, 2018, 2019 Karl Landstrom +# +# This file is part of OBNC. +# +# OBNC is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# OBNC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with OBNC. If not, see . + +set -o errexit -o nounset + +readonly selfDirPath="$(cd "$(dirname "$0")"; pwd -P)" + +export OBNC_PREFIX="$selfDirPath" +export OBNC_LIBDIR="lib" +export CC="${CC:-}" +export CFLAGS="${CFLAGS:-} -I$selfDirPath/lib" +#export LDLIBS= +#if grep -q 'useGC=true' "$selfDirPath/CONFIG"; then +# LDLIBS="-lgc" +#fi + +EchoAndRun() +{ + echo "$@" + eval "$@" +} + + +Test() +{ + local test= + + #test compiler modules + EchoAndRun cd "$selfDirPath/src" + for test in ?*Test.c; do + "$selfDirPath/bin/micb" "$test" >/dev/null + EchoAndRun "./${test%.c}" + done + + #test core library module + EchoAndRun cd "$selfDirPath/lib/obnc" + "$selfDirPath/bin/micb" OBNCTest.c >/dev/null + EchoAndRun ./OBNCTest + + #test executables + EchoAndRun cd "$selfDirPath/bin" + for test in ?*-test; do + echo "./$test" + "./$test" >/dev/null + done + + #test basic library + EchoAndRun cd "$selfDirPath/lib/obnc" + rm -fr ".obnc" + local failure=false + for test in ?*Test.obn; do + #if-command prevents script from halting upon a missing non-required C library, like SDL + if "$selfDirPath/bin/obnc" "$test" >/dev/null; then + if { [ "$test" != "InputTest.obn" ] && [ "$test" != "XYplaneTest.obn" ] ; } || [ "${DEV_ENV:-}" = 1 ]; then + if [ -e "${test%.obn}.sh" ]; then + EchoAndRun "./${test%.obn}.sh" + else + EchoAndRun "./${test%.obn}" + fi + fi + else + failure=true + fi + done + + if ! "$failure"; then + printf "\nAll tests passed!\n\n" + else + printf "\nSome test(s) failed!\n\n" + exit 1 + fi +} + +if [ "$#" -eq 0 ]; then + Test +else + echo "usage: test" >&2 + exit 1 +fi diff --git a/tests/obnc/failing-at-compile-time/A.obn b/tests/obnc/failing-at-compile-time/A.obn new file mode 100644 index 0000000..fa4b1d5 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/A.obn @@ -0,0 +1,28 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE A; + + TYPE + P* = POINTER TO RECORD END; + + VAR + n*: INTEGER; + r*: RECORD f: INTEGER END; + p*: P; + +END A. diff --git a/tests/obnc/failing-at-compile-time/B.obn b/tests/obnc/failing-at-compile-time/B.obn new file mode 100644 index 0000000..4cd3ed2 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/B.obn @@ -0,0 +1,19 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE B; +END B. diff --git a/tests/obnc/failing-at-compile-time/T0UnterminatedComment.obn b/tests/obnc/failing-at-compile-time/T0UnterminatedComment.obn new file mode 100644 index 0000000..e67ff04 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T0UnterminatedComment.obn @@ -0,0 +1,22 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T0UnterminatedComment; + +(*(**) + +END T0UnterminatedComment. diff --git a/tests/obnc/failing-at-compile-time/T2PointerToNonRecord.obn b/tests/obnc/failing-at-compile-time/T2PointerToNonRecord.obn new file mode 100644 index 0000000..6ead4f8 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2PointerToNonRecord.obn @@ -0,0 +1,23 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2PointerToNonRecord; + + TYPE + P = POINTER TO ARRAY 10 OF INTEGER; + +END T2PointerToNonRecord. diff --git a/tests/obnc/failing-at-compile-time/T2RecursiveRecord.obn b/tests/obnc/failing-at-compile-time/T2RecursiveRecord.obn new file mode 100644 index 0000000..723fc09 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2RecursiveRecord.obn @@ -0,0 +1,25 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2RecursiveRecord; + + TYPE + T = RECORD + f: T + END; + +END T2RecursiveRecord. diff --git a/tests/obnc/failing-at-compile-time/T2RedeclaredField.obn b/tests/obnc/failing-at-compile-time/T2RedeclaredField.obn new file mode 100644 index 0000000..b0d3d4b --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2RedeclaredField.obn @@ -0,0 +1,29 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2RedeclaredField; + + TYPE + T = RECORD + f: INTEGER + END; + + T1 = RECORD (T) + f: INTEGER + END; + +END T2RedeclaredField. diff --git a/tests/obnc/failing-at-compile-time/T2RepeatedParameterIdent.obn b/tests/obnc/failing-at-compile-time/T2RepeatedParameterIdent.obn new file mode 100644 index 0000000..d118568 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2RepeatedParameterIdent.obn @@ -0,0 +1,23 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2RepeatedParameterIdent; + + TYPE + Proc = PROCEDURE (x: INTEGER; x: INTEGER); + +END T2RepeatedParameterIdent. diff --git a/tests/obnc/failing-at-compile-time/T2SelfDeclaration.obn b/tests/obnc/failing-at-compile-time/T2SelfDeclaration.obn new file mode 100644 index 0000000..d644138 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2SelfDeclaration.obn @@ -0,0 +1,22 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2SelfDeclaration; + + TYPE T = T; + +END T2SelfDeclaration. diff --git a/tests/obnc/failing-at-compile-time/T2SelfReferringBaseType.obn b/tests/obnc/failing-at-compile-time/T2SelfReferringBaseType.obn new file mode 100644 index 0000000..bb4d86d --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2SelfReferringBaseType.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2SelfReferringBaseType; + + TYPE + T = POINTER TO TDesc; + TDesc = RECORD (T) END; + +END T2SelfReferringBaseType. diff --git a/tests/obnc/failing-at-compile-time/T2UnresolvedAnonType.obn b/tests/obnc/failing-at-compile-time/T2UnresolvedAnonType.obn new file mode 100644 index 0000000..2eaee2a --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2UnresolvedAnonType.obn @@ -0,0 +1,23 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2UnresolvedAnonType; + + VAR + x: POINTER TO T; + +END T2UnresolvedAnonType. diff --git a/tests/obnc/failing-at-compile-time/T2UnresolvedType.obn b/tests/obnc/failing-at-compile-time/T2UnresolvedType.obn new file mode 100644 index 0000000..05ad221 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2UnresolvedType.obn @@ -0,0 +1,23 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2UnresolvedType; + + TYPE + P = POINTER TO T; + +END T2UnresolvedType. diff --git a/tests/obnc/failing-at-compile-time/T2WrongResolvedType.obn b/tests/obnc/failing-at-compile-time/T2WrongResolvedType.obn new file mode 100644 index 0000000..3c0a090 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T2WrongResolvedType.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2WrongResolvedType; + + TYPE + P = POINTER TO T; + T = INTEGER; + +END T2WrongResolvedType. diff --git a/tests/obnc/failing-at-compile-time/T3RepeatedField.obn b/tests/obnc/failing-at-compile-time/T3RepeatedField.obn new file mode 100644 index 0000000..fa7ef69 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T3RepeatedField.obn @@ -0,0 +1,25 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T3RepeatedField; + + VAR + x: RECORD + f, f: INTEGER + END; + +END T3RepeatedField. diff --git a/tests/obnc/failing-at-compile-time/T3RepeatedVar.obn b/tests/obnc/failing-at-compile-time/T3RepeatedVar.obn new file mode 100644 index 0000000..2eeeb0a --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T3RepeatedVar.obn @@ -0,0 +1,23 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T3RepeatedVar; + + VAR + x, x: INTEGER; + +END T3RepeatedVar. diff --git a/tests/obnc/failing-at-compile-time/T4InvalidPointerComparison.obn b/tests/obnc/failing-at-compile-time/T4InvalidPointerComparison.obn new file mode 100644 index 0000000..bb0ea25 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T4InvalidPointerComparison.obn @@ -0,0 +1,26 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T4InvalidPointerComparison; + + VAR + p: POINTER TO RECORD END; + q: POINTER TO RECORD END; + +BEGIN + IF p = q THEN END +END T4InvalidPointerComparison. diff --git a/tests/obnc/failing-at-compile-time/T4InvalidProcedureComparison.obn b/tests/obnc/failing-at-compile-time/T4InvalidProcedureComparison.obn new file mode 100644 index 0000000..cade3b0 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T4InvalidProcedureComparison.obn @@ -0,0 +1,28 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T4InvalidProcedureComparison; + + PROCEDURE P; + END P; + + PROCEDURE Q(x: INTEGER); + END Q; + +BEGIN + IF P = Q THEN END (*P and Q should have equal types*) +END T4InvalidProcedureComparison. diff --git a/tests/obnc/failing-at-compile-time/T4NegativeSetElement.obn b/tests/obnc/failing-at-compile-time/T4NegativeSetElement.obn new file mode 100644 index 0000000..55b1c93 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T4NegativeSetElement.obn @@ -0,0 +1,23 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T4NegativeSetElement; + + CONST + A = {-1}; + +END T4NegativeSetElement. diff --git a/tests/obnc/failing-at-compile-time/T4SelectorOnConstant.obn b/tests/obnc/failing-at-compile-time/T4SelectorOnConstant.obn new file mode 100644 index 0000000..ccd4601 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T4SelectorOnConstant.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T4SelectorOnConstant; + + CONST str = "abc"; + +BEGIN + str[0] := 0X +END T4SelectorOnConstant. diff --git a/tests/obnc/failing-at-compile-time/T4TypeGuardOnNonVarParamRecord.obn b/tests/obnc/failing-at-compile-time/T4TypeGuardOnNonVarParamRecord.obn new file mode 100644 index 0000000..ea6ac20 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T4TypeGuardOnNonVarParamRecord.obn @@ -0,0 +1,28 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T4TypeGuardOnNonVarParamRecord; + + TYPE + T = RECORD f: INTEGER END; + + VAR + x: T; + +BEGIN + IF x(T).f = 0 THEN END +END T4TypeGuardOnNonVarParamRecord. diff --git a/tests/obnc/failing-at-compile-time/T5AssignPredefinedProcedure.obn b/tests/obnc/failing-at-compile-time/T5AssignPredefinedProcedure.obn new file mode 100644 index 0000000..9879f28 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5AssignPredefinedProcedure.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5AssignPredefinedProcedure; + + VAR p: PROCEDURE (x: INTEGER): BOOLEAN; + +BEGIN + p := ODD +END T5AssignPredefinedProcedure. diff --git a/tests/obnc/failing-at-compile-time/T5AssignToImportedVariable.obn b/tests/obnc/failing-at-compile-time/T5AssignToImportedVariable.obn new file mode 100644 index 0000000..9c01c5b --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5AssignToImportedVariable.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5AssignToImportedVariable; + + IMPORT A; + +BEGIN + A.n := 0 +END T5AssignToImportedVariable. diff --git a/tests/obnc/failing-at-compile-time/T5FunctionProcedureStatement.obn b/tests/obnc/failing-at-compile-time/T5FunctionProcedureStatement.obn new file mode 100644 index 0000000..c2b28f8 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5FunctionProcedureStatement.obn @@ -0,0 +1,26 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5FunctionProcedureStatement; + + PROCEDURE F(): INTEGER; + RETURN 0 + END F; + +BEGIN + F +END T5FunctionProcedureStatement. diff --git a/tests/obnc/failing-at-compile-time/T5InvalidArrayAssignment.obn b/tests/obnc/failing-at-compile-time/T5InvalidArrayAssignment.obn new file mode 100644 index 0000000..915fd57 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5InvalidArrayAssignment.obn @@ -0,0 +1,27 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5InvalidArrayAssignment; + + VAR + s: ARRAY 32 OF CHAR; + t: ARRAY 32 OF CHAR; + +BEGIN + s := "test"; + t := s +END T5InvalidArrayAssignment. diff --git a/tests/obnc/failing-at-compile-time/T5NonConstForLoopInc.obn b/tests/obnc/failing-at-compile-time/T5NonConstForLoopInc.obn new file mode 100644 index 0000000..e3e03c5 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5NonConstForLoopInc.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5NonConstForLoopInc; + + VAR i: INTEGER; + +BEGIN + FOR i := 1 TO 10 BY i DO END +END T5NonConstForLoopInc. diff --git a/tests/obnc/failing-at-compile-time/T5PointerVarParamExt.obn b/tests/obnc/failing-at-compile-time/T5PointerVarParamExt.obn new file mode 100644 index 0000000..0cbe641 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5PointerVarParamExt.obn @@ -0,0 +1,32 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5PointerVarParamExt; + + TYPE + P0 = POINTER TO RECORD END; + P1 = POINTER TO RECORD (P0) END; + + VAR + x: P1; + + PROCEDURE P(VAR x: P0); + END P; + +BEGIN + P(x) (*variable pointer parameter cannot be an extended type*) +END T5PointerVarParamExt. diff --git a/tests/obnc/failing-at-compile-time/T5StringAssignment.obn b/tests/obnc/failing-at-compile-time/T5StringAssignment.obn new file mode 100644 index 0000000..5375922 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5StringAssignment.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5StringAssignment; + + VAR s: ARRAY 4 OF CHAR; + +BEGIN + s := "help" (*null character won't fit*) +END T5StringAssignment. diff --git a/tests/obnc/failing-at-compile-time/T5StructValueParamAssignment.obn b/tests/obnc/failing-at-compile-time/T5StructValueParamAssignment.obn new file mode 100644 index 0000000..4816c19 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T5StructValueParamAssignment.obn @@ -0,0 +1,28 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5StructValueParamAssignment; + + TYPE + String = ARRAY 32 OF CHAR; + + PROCEDURE P(s: String); + BEGIN + s := s + END P; + +END T5StructValueParamAssignment. diff --git a/tests/obnc/failing-at-compile-time/T6ExtendedPointerVarParam.obn b/tests/obnc/failing-at-compile-time/T6ExtendedPointerVarParam.obn new file mode 100644 index 0000000..754277e --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T6ExtendedPointerVarParam.obn @@ -0,0 +1,35 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T6ExtendedPointerVarParam; + + TYPE + Ta = RECORD a : INTEGER END; + Tb = RECORD (Ta) b : INTEGER END; + + Pa = POINTER TO Ta; + Pb = POINTER TO Tb; + + VAR + pb : Pb; + + PROCEDURE F(VAR pa : Pa); + END F; + +BEGIN + F(pb) +END T6ExtendedPointerVarParam. diff --git a/tests/obnc/failing-at-compile-time/T6ForgottenReturnType.obn b/tests/obnc/failing-at-compile-time/T6ForgottenReturnType.obn new file mode 100644 index 0000000..ef7ae25 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T6ForgottenReturnType.obn @@ -0,0 +1,27 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T6ForgottenReturnType; + + PROCEDURE F(m: INTEGER); + VAR n: INTEGER; + BEGIN + n := F(0) + RETURN n + END F; + +END T6ForgottenReturnType. diff --git a/tests/obnc/failing-at-compile-time/T6LocalParamTypeRef.obn b/tests/obnc/failing-at-compile-time/T6LocalParamTypeRef.obn new file mode 100644 index 0000000..bd4203a --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T6LocalParamTypeRef.obn @@ -0,0 +1,28 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T6LocalParamTypeRef; + + PROCEDURE P; + TYPE T = INTEGER; + + PROCEDURE Q(x: T): T; + RETURN 0 + END Q; + END P; + +END T6LocalParamTypeRef. diff --git a/tests/obnc/failing-at-compile-time/T6NonScalarResultType.obn b/tests/obnc/failing-at-compile-time/T6NonScalarResultType.obn new file mode 100644 index 0000000..df5a09e --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T6NonScalarResultType.obn @@ -0,0 +1,28 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T6NonScalarResultType; + + TYPE + String = ARRAY 60 OF CHAR; + + PROCEDURE P(): String; + VAR s: String; + RETURN s + END P; + +END T6NonScalarResultType. diff --git a/tests/obnc/failing-at-compile-time/T6ReadOnlyParam.obn b/tests/obnc/failing-at-compile-time/T6ReadOnlyParam.obn new file mode 100644 index 0000000..cdec90d --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T6ReadOnlyParam.obn @@ -0,0 +1,29 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T6ReadOnlyParam; + + PROCEDURE P(VAR a: ARRAY OF INTEGER); + END P; + + + PROCEDURE Q(a: ARRAY OF INTEGER); + BEGIN + P(a) + END Q; + +END T6ReadOnlyParam. diff --git a/tests/obnc/failing-at-compile-time/T7AccessNonExportedField.obn b/tests/obnc/failing-at-compile-time/T7AccessNonExportedField.obn new file mode 100644 index 0000000..007ab6f --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7AccessNonExportedField.obn @@ -0,0 +1,27 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7AccessNonExportedField; + + IMPORT A; + + VAR + n: INTEGER; + +BEGIN + n := A.r.f +END T7AccessNonExportedField. diff --git a/tests/obnc/failing-at-compile-time/T7ActualVarParamImported.obn b/tests/obnc/failing-at-compile-time/T7ActualVarParamImported.obn new file mode 100644 index 0000000..e21bd5d --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ActualVarParamImported.obn @@ -0,0 +1,27 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ActualVarParamImported; + + IMPORT A; + + PROCEDURE P(VAR x: A.P); + END P; + +BEGIN + P(A.p) +END T7ActualVarParamImported. diff --git a/tests/obnc/failing-at-compile-time/T7ActualVarParamImported1.obn b/tests/obnc/failing-at-compile-time/T7ActualVarParamImported1.obn new file mode 100644 index 0000000..04e6503 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ActualVarParamImported1.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ActualVarParamImported1; + + IMPORT A; + +BEGIN + NEW(A.p) +END T7ActualVarParamImported1. diff --git a/tests/obnc/failing-at-compile-time/T7ExportLocalIdent.obn b/tests/obnc/failing-at-compile-time/T7ExportLocalIdent.obn new file mode 100644 index 0000000..8a41a19 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ExportLocalIdent.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ExportLocalIdent; + + PROCEDURE P; + VAR x*: INTEGER; + END P; + +END T7ExportLocalIdent. diff --git a/tests/obnc/failing-at-compile-time/T7ImportDuplicate.obn b/tests/obnc/failing-at-compile-time/T7ImportDuplicate.obn new file mode 100644 index 0000000..2db0b15 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportDuplicate.obn @@ -0,0 +1,20 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportDuplicate; + IMPORT A, A; +END T7ImportDuplicate. diff --git a/tests/obnc/failing-at-compile-time/T7ImportDuplicateWithAlias.obn b/tests/obnc/failing-at-compile-time/T7ImportDuplicateWithAlias.obn new file mode 100644 index 0000000..7aa70b9 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportDuplicateWithAlias.obn @@ -0,0 +1,22 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportDuplicateWithAlias; + + IMPORT A := B, B; + +END T7ImportDuplicateWithAlias. diff --git a/tests/obnc/failing-at-compile-time/T7ImportLibraryLocal.obn b/tests/obnc/failing-at-compile-time/T7ImportLibraryLocal.obn new file mode 100644 index 0000000..b332682 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportLibraryLocal.obn @@ -0,0 +1,22 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportLibraryLocal; + + IMPORT Local; + +END T7ImportLibraryLocal. diff --git a/tests/obnc/failing-at-compile-time/T7ImportNonExisting.obn b/tests/obnc/failing-at-compile-time/T7ImportNonExisting.obn new file mode 100644 index 0000000..13668c9 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportNonExisting.obn @@ -0,0 +1,22 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportNonExisting; + + IMPORT NonExistingModule; + +END T7ImportNonExisting. diff --git a/tests/obnc/failing-at-compile-time/T7ImportRedeclaration.obn b/tests/obnc/failing-at-compile-time/T7ImportRedeclaration.obn new file mode 100644 index 0000000..28ccd14 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportRedeclaration.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportRedeclaration; + + IMPORT A; + + CONST A = 0; + +END T7ImportRedeclaration. diff --git a/tests/obnc/failing-at-compile-time/T7ImportRedeclarationAlias.obn b/tests/obnc/failing-at-compile-time/T7ImportRedeclarationAlias.obn new file mode 100644 index 0000000..ba17567 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportRedeclarationAlias.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportRedeclarationAlias; + + IMPORT B := A; + + CONST B = 0; + +END T7ImportRedeclarationAlias. diff --git a/tests/obnc/failing-at-compile-time/T7ImportSelf.obn b/tests/obnc/failing-at-compile-time/T7ImportSelf.obn new file mode 100644 index 0000000..ce5bc4c --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportSelf.obn @@ -0,0 +1,20 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportSelf; + IMPORT T7ImportSelf; +END T7ImportSelf. diff --git a/tests/obnc/failing-at-compile-time/T7ImportSelfWithAlias.obn b/tests/obnc/failing-at-compile-time/T7ImportSelfWithAlias.obn new file mode 100644 index 0000000..615fbe0 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportSelfWithAlias.obn @@ -0,0 +1,20 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportSelfWithAlias; + IMPORT M := T7ImportSelfWithAlias; +END T7ImportSelfWithAlias. diff --git a/tests/obnc/failing-at-compile-time/T7ImportWithDuplicateAlias.obn b/tests/obnc/failing-at-compile-time/T7ImportWithDuplicateAlias.obn new file mode 100644 index 0000000..814910f --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ImportWithDuplicateAlias.obn @@ -0,0 +1,20 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ImportWithDuplicateAlias; + IMPORT B := A, B; +END T7ImportWithDuplicateAlias. diff --git a/tests/obnc/failing-at-compile-time/T7ModuleIdentifierNonMatch.obn b/tests/obnc/failing-at-compile-time/T7ModuleIdentifierNonMatch.obn new file mode 100644 index 0000000..cbc7898 --- /dev/null +++ b/tests/obnc/failing-at-compile-time/T7ModuleIdentifierNonMatch.obn @@ -0,0 +1,19 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7ModuleIdentifierNonMatch; +END T7ModuleIdentifierNonMatchFoo. diff --git a/tests/obnc/failing-at-compile-time/lib/Local.obn b/tests/obnc/failing-at-compile-time/lib/Local.obn new file mode 100644 index 0000000..d9fef8d --- /dev/null +++ b/tests/obnc/failing-at-compile-time/lib/Local.obn @@ -0,0 +1,19 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE Local; +END Local. diff --git a/tests/obnc/failing-at-runtime/T4FailingTypeGuard.obn b/tests/obnc/failing-at-runtime/T4FailingTypeGuard.obn new file mode 100644 index 0000000..4c41943 --- /dev/null +++ b/tests/obnc/failing-at-runtime/T4FailingTypeGuard.obn @@ -0,0 +1,37 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T4FailingTypeGuard; + + TYPE + T = RECORD END; + + T1 = RECORD (T) + f: INTEGER + END; + + VAR + x: T; + + PROCEDURE P(VAR x: T); + BEGIN + x(T1).f := 0 + END P; + +BEGIN + P(x) +END T4FailingTypeGuard. diff --git a/tests/obnc/failing-at-runtime/T5AssignStringToOpenArray.obn b/tests/obnc/failing-at-runtime/T5AssignStringToOpenArray.obn new file mode 100644 index 0000000..8a59c34 --- /dev/null +++ b/tests/obnc/failing-at-runtime/T5AssignStringToOpenArray.obn @@ -0,0 +1,30 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5AssignStringToOpenArray; + + VAR + str: ARRAY 4 OF CHAR; + + PROCEDURE P(VAR s: ARRAY OF CHAR); + BEGIN + s := "test" + END P; + +BEGIN + P(str) +END T5AssignStringToOpenArray. diff --git a/tests/obnc/failing-at-runtime/T5CallNilProcedure.obn b/tests/obnc/failing-at-runtime/T5CallNilProcedure.obn new file mode 100644 index 0000000..0191479 --- /dev/null +++ b/tests/obnc/failing-at-runtime/T5CallNilProcedure.obn @@ -0,0 +1,26 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5CallNilProcedure; + + VAR + p: PROCEDURE; + +BEGIN + p := NIL; + p +END T5CallNilProcedure. diff --git a/tests/obnc/failing-at-runtime/T5OpenArrayAssignment.obn b/tests/obnc/failing-at-runtime/T5OpenArrayAssignment.obn new file mode 100644 index 0000000..4328ae0 --- /dev/null +++ b/tests/obnc/failing-at-runtime/T5OpenArrayAssignment.obn @@ -0,0 +1,30 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5OpenArrayAssignment; + + VAR + s1: ARRAY 8 OF CHAR; + + PROCEDURE P(s: ARRAY OF CHAR); + BEGIN + s1 := s + END P; + +BEGIN + P("testing, testing...") +END T5OpenArrayAssignment. diff --git a/tests/obnc/failing-at-runtime/T5RecordVarParamAssignment.obn b/tests/obnc/failing-at-runtime/T5RecordVarParamAssignment.obn new file mode 100644 index 0000000..a3353ec --- /dev/null +++ b/tests/obnc/failing-at-runtime/T5RecordVarParamAssignment.obn @@ -0,0 +1,35 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5RecordVarParamAssignment; + + TYPE + T = RECORD END; + T1 = RECORD (T) END; + + VAR + x: T; + y: T1; + + PROCEDURE P(VAR x, y: T); + BEGIN + y := x + END P; + +BEGIN + P(x, y) +END T5RecordVarParamAssignment. diff --git a/tests/obnc/passing/A.obn b/tests/obnc/passing/A.obn new file mode 100644 index 0000000..fcbdbd8 --- /dev/null +++ b/tests/obnc/passing/A.obn @@ -0,0 +1,105 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE A; + + IMPORT B; + + CONST + boolConst* = TRUE; + charConst* = CHR(22H); + intConst* = 1; + realConst* = 2.3; + strConst* = "hello there"; + nul* = 0X; + lf* = 0AX; + charMax* = 0FFX; + setConst* = {0, 2, 3, 5}; + + TYPE + Integer = INTEGER; + String = ARRAY 256 OF CHAR; + EmptyRecord* = RECORD END; + EmptyExtendedRecord* = RECORD (EmptyRecord) END; + EmptyPointer* = POINTER TO RECORD END; + EmptyExtendedPointer* = POINTER TO RECORD (EmptyPointer) END; + List* = POINTER TO Node; + Node = RECORD + key: String; + next: List + END; + Nested* = RECORD + f*: B.U + END; + Proc* = PROCEDURE; + Proc1* = PROCEDURE (n: Node); + Proc2* = PROCEDURE (): List; + Proc3* = PROCEDURE (n: Node): List; + Proc4* = PROCEDURE (n, n1: Node): List; + Proc5* = PROCEDURE (n: Node; i: INTEGER); + Proc6* = PROCEDURE (n, n1: Node; i: INTEGER); + T* = B.T; + P1* = B.P1; + + VAR + boolVar*: BOOLEAN; + charVar*: CHAR; + intVar*: Integer; + realVar* : REAL; + byteVar*: BYTE; + setVar*: SET; + strVar*: String; + recVar*, recVar1: RECORD + f*: INTEGER + END; + ptrVar*: POINTER TO Node; + procVar*: PROCEDURE (s: String); + alias: B.CTAlias; + + PROCEDURE P*(s: String); + END P; + + + PROCEDURE Q*(x: B.T); + END Q; + + + PROCEDURE R*(A: ARRAY OF ARRAY OF INTEGER); + END R; + + + PROCEDURE S*(x: T); + END S; + + + PROCEDURE S1*(VAR x: P1); + END S1; + +BEGIN + boolVar := boolConst; + charVar := charConst; + intVar := intConst; + realVar := realConst; + byteVar := intConst; + setVar := setConst; + strVar := strConst; + recVar.f := 1; + recVar1.f := 0; + ptrVar := NIL; + procVar := P; + B.P(alias) +END A. diff --git a/tests/obnc/passing/B.obn b/tests/obnc/passing/B.obn new file mode 100644 index 0000000..038b98f --- /dev/null +++ b/tests/obnc/passing/B.obn @@ -0,0 +1,32 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE B; + + IMPORT C1 := C; + + TYPE + T* = RECORD (C1.T) END; + P1* = POINTER TO RECORD (C1.P0) END; + U* = POINTER TO UDesc; + UDesc* = RECORD f*: INTEGER END; + CTAlias* = C1.T; + + PROCEDURE P*(VAR x: CTAlias); + END P; + +END B. diff --git a/tests/obnc/passing/C.obn b/tests/obnc/passing/C.obn new file mode 100644 index 0000000..d23fb66 --- /dev/null +++ b/tests/obnc/passing/C.obn @@ -0,0 +1,24 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE C; + + TYPE + T* = RECORD END; + P0* = POINTER TO RECORD END; + +END C. diff --git a/tests/obnc/passing/D.obn b/tests/obnc/passing/D.obn new file mode 100644 index 0000000..50b9f17 --- /dev/null +++ b/tests/obnc/passing/D.obn @@ -0,0 +1,22 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE D; + + CONST b* = TRUE; + +END D. diff --git a/tests/obnc/passing/OBNC.obn b/tests/obnc/passing/OBNC.obn new file mode 100644 index 0000000..8240354 --- /dev/null +++ b/tests/obnc/passing/OBNC.obn @@ -0,0 +1,37 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE OBNC; (*should not cause a conflict with system C module OBNC*) + + (*generated identifiers with suffixes should not conflict with identifiers declared in system module OBNC*) + + CONST b* = TRUE; + + TYPE + OBNC = RECORD f: INTEGER END; + + VAR + a: ARRAY 1 OF INTEGER; + x: OBNC; + + PROCEDURE Q(OBNC: ARRAY OF INTEGER); + END Q; + +BEGIN + Q(a); + x.f := 0 +END OBNC. diff --git a/tests/obnc/passing/T1ConstantDeclarations.obn b/tests/obnc/passing/T1ConstantDeclarations.obn new file mode 100644 index 0000000..b01778a --- /dev/null +++ b/tests/obnc/passing/T1ConstantDeclarations.obn @@ -0,0 +1,66 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T1ConstantDeclarations; + + CONST + null = NIL; + valid = FALSE; + singleCharStr = "x"; + lineFeed = 0AX; + quotes = 22X; + backslash = "\"; + nonAscii = 80X; + letterA = CHR(ORD("A")); + sevenDigits = "1234567"; + count = 37; + pi = 3.14; + (*inf = 1.0E+1000;*) + (*nan = 0.0 / 0.0;*) + lastDigits = {0, 2 .. 3, 5}; + + VAR + p: PROCEDURE; + b: BOOLEAN; + ch: CHAR; + s: ARRAY 8 OF CHAR; + i: INTEGER; + x: REAL; + j: BYTE; + A: SET; + +BEGIN + p := null; + b := valid; + ch := singleCharStr; + ch := lineFeed; + ch := quotes; + ch := backslash; + ch := nonAscii; + ch := letterA; + s := singleCharStr; + s := lineFeed; + s := quotes; + s := backslash; + s := sevenDigits; + i := count; + j := count; + x := pi; + (*x := inf;*) + (*x := nan;*) + A := lastDigits +END T1ConstantDeclarations. diff --git a/tests/obnc/passing/T2TypeDeclarations.obn b/tests/obnc/passing/T2TypeDeclarations.obn new file mode 100644 index 0000000..c60bfac --- /dev/null +++ b/tests/obnc/passing/T2TypeDeclarations.obn @@ -0,0 +1,140 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T2TypeDeclarations; + + CONST left = 0; + + TYPE + String = ARRAY 32 OF CHAR; + StringAlias = String; + + ProcTable = ARRAY 1 OF PROCEDURE; + + Element = POINTER TO RECORD END; + + Tree = POINTER TO RECORD + content: Element; + proc: PROCEDURE (t: Tree; VAR t1: Tree): Tree; + n: POINTER TO Node; + left, right: Tree + END; + + IntegerNode = POINTER TO RECORD (Element) + value: INTEGER + END; + + List = POINTER TO Node; + List1 = POINTER TO Node; + Node = RECORD + elem: INTEGER; + next: List; + next1: POINTER TO Node; + next2: List1; + p: PROCEDURE (n: Node; VAR n1: Node) + END; + + ArrayRecPtr = POINTER TO RECORD + f: ARRAY 10 OF ArrayRecPtr; + g: RECORD + f: ArrayRecPtr + END + END; + + ProcRecArray = ARRAY 10 OF RECORD + f: PROCEDURE (x: ArrayRecPtr): INTEGER + END; + + T = RECORD i: INTEGER END; + + VAR + s: String; + s1: StringAlias; + table: ProcTable; + t: Tree; + e: Element; + i: IntegerNode; + n: Node; + p: ArrayRecPtr; + a: ProcRecArray; + + PROCEDURE TestMemoryAllocation; + TYPE + Ta0 = RECORD + ptr: POINTER TO RECORD END + END; + Tb0 = RECORD + proc: PROCEDURE + END; + Ta1 = RECORD (Ta0) END; + Tb1 = RECORD (Tb0) END; + + VAR + x: POINTER TO Ta1; + y: POINTER TO Tb1; + z: POINTER TO RECORD + ptr: POINTER TO RECORD END; + proc: PROCEDURE + END; + BEGIN + NEW(x); + ASSERT(x.ptr = NIL); + NEW(y); + ASSERT(y.proc = NIL); + NEW(z); + ASSERT(z.ptr = NIL); + ASSERT(z.proc = NIL) + END TestMemoryAllocation; + + + PROCEDURE TreeProc(t: Tree; VAR t1: Tree): Tree; + RETURN NIL + END TreeProc; + + + PROCEDURE NodeProc(n: Node; VAR n1: Node); + END NodeProc; + + + PROCEDURE TestScope; + TYPE P = POINTER TO T; + T = RECORD f: INTEGER END; + VAR x: P; + y: T; + BEGIN + NEW(x); + x.i := 1; + y.f := 1 + END TestScope; + +BEGIN + TestMemoryAllocation; + s1 := s; + table[0] := NIL; + NEW(t); + NEW(i); + t.content := i; + t.content(IntegerNode).value := 1; + t.proc := TreeProc; + NEW(e); + n.elem := left; + n.next := NIL; + n.p := NodeProc; + NEW(p); + a[0].f := NIL; + TestScope +END T2TypeDeclarations. diff --git a/tests/obnc/passing/T3VariableDeclarations.obn b/tests/obnc/passing/T3VariableDeclarations.obn new file mode 100644 index 0000000..7522b7c --- /dev/null +++ b/tests/obnc/passing/T3VariableDeclarations.obn @@ -0,0 +1,60 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T3VariableDeclarations; + + TYPE + Vector = RECORD + x, y: REAL + END; + + ShapeDesc = RECORD + pos: Vector + END; + + Rectangle = POINTER TO RectangleDesc; + RectangleDesc = RECORD (ShapeDesc) + size: Vector + END; + + PROCEDURE TestInitialization; + VAR s: ShapeDesc; + r: RectangleDesc; + rs: ARRAY 10 OF RectangleDesc; + rp: Rectangle; + + PROCEDURE AssertVector(VAR v: Vector); + BEGIN + ASSERT(v IS Vector) + END AssertVector; + + BEGIN + AssertVector(s.pos); + AssertVector(r.pos); + AssertVector(r.size); + AssertVector(rs[0].pos); + AssertVector(rs[0].size); + + NEW(rp); + ASSERT(rp IS Rectangle); + AssertVector(rp.pos); + AssertVector(rp.size); + END TestInitialization; + +BEGIN + TestInitialization +END T3VariableDeclarations. diff --git a/tests/obnc/passing/T4Expressions.obn b/tests/obnc/passing/T4Expressions.obn new file mode 100644 index 0000000..a76ccff --- /dev/null +++ b/tests/obnc/passing/T4Expressions.obn @@ -0,0 +1,500 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T4Expressions; + + IMPORT Out, SYSTEM; + + PROCEDURE IncReturnZero(VAR x: INTEGER): INTEGER; + BEGIN + INC(x) + RETURN 0 + END IncReturnZero; + + + PROCEDURE IncReturnEmpty(VAR x: INTEGER): SET; + BEGIN + INC(x) + RETURN {} + END IncReturnEmpty; + + + PROCEDURE TestDesignators; + VAR s: ARRAY 32 OF CHAR; + A: ARRAY 3, 4 OF INTEGER; + i, j: INTEGER; + a: ARRAY 10 OF POINTER TO RECORD + a: ARRAY 10 OF INTEGER; + f: PROCEDURE (): INTEGER + END; + + PROCEDURE F(): INTEGER; + RETURN 1 + END F; + + BEGIN + s := "hello"; + ASSERT(s[1] = "e"); + + A[1, 2] := 1; + ASSERT(A[1, 2] = A[1][2]); + i := 0; + j := 0; + A[0, 0] := ABS(A[IncReturnZero(i), IncReturnZero(j)]); + ASSERT(i = 1); + ASSERT(j = 1); + + NEW(a[0]); + a[0].a[0] := 1; + ASSERT(a[0].a[0] = 1); + a[0]^.f := F; + ASSERT(a[0].f() = 1); + END TestDesignators; + + + PROCEDURE TestSetConstructors; + VAR + a, b, i, j: INTEGER; + A: SET; + BEGIN + a := 4; + b := 6; +Out.Int(ORD({1, 2, a, 5, b, 8}), 0); Out.Ln; +Out.Int(ORD({1, 2, a..b, 8}), 0); Out.Ln; +Out.Int(ORD({1, 2, a, 5, b, 8} = {1, 2, a..b, 8}), 0); Out.Ln; + ASSERT({1, 2, a, 5, b, 8} = {1, 2, a..b, 8}); + i := 0; + j := 0; + A := {IncReturnZero(i)..IncReturnZero(j)}; + ASSERT(A = {0}); + ASSERT(i = 1); + ASSERT(j = 1) + END TestSetConstructors; + + + PROCEDURE TestRelationalOperations; + TYPE + T = POINTER TO RECORD END; + T1 = POINTER TO RECORD (T) END; + + VAR b, b1: BOOLEAN; + ch, ch1: CHAR; + i, j, n: INTEGER; + x: REAL; + y: BYTE; + A, B: SET; + str: ARRAY 24 OF CHAR; + strs: ARRAY 2, 32 OF CHAR; + t: T; + t1: T1; + BEGIN + (*booleans*) + ASSERT(TRUE = TRUE); + ASSERT(TRUE # FALSE); + b := TRUE; + b1 := FALSE; + ASSERT(b = TRUE); + ASSERT(b1 # TRUE); + + (*characters / single-character strings*) + ch := 0X; + ch1 := "a"; + ASSERT(ch = 0X); + ASSERT(ch # "a"); + ASSERT(ch < ch1); + ASSERT(ch <= 0X); + ASSERT(ch <= "a"); + ASSERT(ch1 > ch); + (*ASSERT(ch >= 0X);*) + ASSERT("a" >= ch); + ch := 7FX; + ch1 := 80X; + ASSERT(ch < ch1); + + (*integers*) + ASSERT(0 = 0); + ASSERT(0 # 1); + ASSERT(0 < 1); + ASSERT(0 <= 0); + ASSERT(0 <= 1); + ASSERT(1 > 0); + ASSERT(0 >= 0); + ASSERT(1 >= 0); + ASSERT(0 IN {0}); + ASSERT(~(1 IN {0})); + n := 0; + ASSERT(n = 0); + ASSERT(n # 1); + ASSERT(n < 1); + ASSERT(n <= 0); + ASSERT(n <= 1); + ASSERT(n < 1); + ASSERT(n >= 0); + ASSERT(n >= -1); + ASSERT(n IN {0}); + ASSERT(~(1 IN {n})); + i := 0; + j := 0; + b := IncReturnZero(i) IN IncReturnEmpty(j); + ASSERT(i = 1); + ASSERT(j = 1); + + (*real numbers*) + ASSERT(0.0 = 0.0); + ASSERT(0.0 # 1.0); + ASSERT(0.0 < 1.0); + ASSERT(0.0 <= 0.0); + ASSERT(0.0 <= 1.0); + ASSERT(1.0 > 0.0); + ASSERT(0.0 >= 0.0); + ASSERT(1.0 >= 0.0); + x := 0.0; + ASSERT(x = 0.0); + ASSERT(x # 1.0); + ASSERT(x < 1.0); + ASSERT(x <= 0.0); + ASSERT(x <= 1.0); + ASSERT(1.0 > x); + ASSERT(x >= 0.0); + ASSERT(x >= -1.0); + + (*bytes*) + y := 0; + ASSERT(y = 0); + ASSERT(y < 1); + ASSERT(y <= 0); + ASSERT(y <= 1); + ASSERT(1 > y); + (*ASSERT(y >= 0);*) + ASSERT(y IN {0}); + ASSERT(~(1 IN {y})); + + (*sets*) + ASSERT({0, 1} = {1, 0}); + ASSERT({0} # {0, 1}); + ASSERT({1 .. 0} = {}); + n := 1; + ASSERT({n .. 0} = {}); + A := {0}; + B := {0, 1}; + ASSERT(A = {0}); + ASSERT(B # {0}); + ASSERT(A # B); + + (*strings / characters / character arrays*) + ASSERT("foo" = "foo"); + ASSERT("foo" # "bar"); + ASSERT("bar" < "foo"); + ASSERT("foo" <= "foo"); + ASSERT("bar" <= "foo"); + ASSERT("foo" > "bar"); + ASSERT("foo" >= "foo"); + ASSERT("foo" >= "bar"); + ch := "b"; + ASSERT("b" = ch); + ASSERT("f" # ch); + ASSERT(ch < "c"); + ASSERT("b" <= ch); + ASSERT("a" <= ch); + ASSERT("c" > ch); + ASSERT("b" >= ch); + ASSERT("c" >= ch); + str := "foo"; + ASSERT("foo" = str); + ASSERT("fool" # str); + ASSERT("fo" # str); + ASSERT("bar" # str); + ASSERT("bar" < str); + ASSERT("fo" < str); + ASSERT("foo" <= str); + ASSERT("bar" <= str); + ASSERT("qux" > str); + ASSERT("foo" >= str); + ASSERT("qux" >= str); + strs[0] := ""; + strs[1] := "bar"; + ASSERT(~(str = strs[1])); + ASSERT(str # strs[1]); + ASSERT(~(str < strs[1])); + ASSERT(~(str <= strs[1])); + ASSERT(str > strs[1]); + ASSERT(str >= strs[1]); + str[0] := 7FX; str[1] := 0X; + strs[1][0] := 80X; strs[1][1] := 0X; + ASSERT(str < strs[1]); + + (*pointers*) + NEW(t1); + t := t1; + ASSERT(t = t1); + ASSERT(t1 = t); + t := NIL; + ASSERT((t IS T) OR ~(t IS T)) (*The value of NIL IS T is undefined.*) + END TestRelationalOperations; + + + PROCEDURE TestAdditiveOperations; + CONST eps = 0.01; + VAR b: BOOLEAN; + n: INTEGER; + x: REAL; + y: BYTE; + A: SET; + BEGIN + (*booleans*) + ASSERT(TRUE OR TRUE); + ASSERT(TRUE OR FALSE); + ASSERT(FALSE OR TRUE); + b := TRUE; + ASSERT(b OR TRUE); + ASSERT(b OR FALSE); + ASSERT(FALSE OR b); + + (*integers*) + ASSERT(1 + 1 = 2); + ASSERT(1 - 1 = 0); + n := 1; + ASSERT(+n = +1); + ASSERT(-n = -1); + ASSERT(n + 1 = 2); + ASSERT(n - 1 = 0); + ASSERT(-n + 1 = 0); + ASSERT(-n - 1 = -2); + + (*reals*) + ASSERT(1.0 + 1.0 >= 2.0 - eps); + ASSERT(1.0 + 1.0 <= 2.0 + eps); + ASSERT(1.0 - 1.0 >= -eps); + ASSERT(1.0 - 1.0 <= eps); + x := 1.0; + ASSERT(+x = +1.0); + ASSERT(-x = -1.0); + ASSERT(x + 1.0 >= 2.0 - eps); + ASSERT(x + 1.0 <= 2.0 + eps); + ASSERT(x - 1.0 >= -eps); + ASSERT(x - 1.0 <= eps); + ASSERT(-x + 1.0 >= - eps); + ASSERT(-x + 1.0 <= eps); + ASSERT(-x - 1.0 >= -2.0 - eps); + ASSERT(-x - 1.0 <= -2.0 + eps); + IF SYSTEM.SIZE(REAL) > 8 THEN + x := 2.0E+308; (*greater than maximum value of binary64*) + ASSERT(x > 1.0E+308); + ASSERT(x < 3.0E+308) + END; + + (*bytes*) + y := 1; + ASSERT(+y = +1); + ASSERT(-y = -1); + ASSERT(y + 1= 2); + ASSERT(1 - y = 0); + + (*sets*) + ASSERT({0, 1} + (-{0, 1}) = -{}); + ASSERT({0, 1} + {0, 2} = {0 .. 2}); + ASSERT({0, 1} - {0, 2} = {1}); + A := {0, 1}; + ASSERT(A + (-{0, 1}) = -{}); + ASSERT(A + {0, 2} = {0 .. 2}); + ASSERT(A - {0, 2} = {1}) + END TestAdditiveOperations; + + + PROCEDURE TestMultiplicativeOperations; + CONST eps = 0.01; + VAR b: BOOLEAN; + i, j, n: INTEGER; + x: REAL; + y: BYTE; + A: SET; + BEGIN + (*booleans*) + ASSERT(TRUE & TRUE); + b := TRUE; + ASSERT(b & TRUE); + + (*integers*) + ASSERT(9 * 2 = 18); + ASSERT(9 DIV 4 = 2); + ASSERT((-9) DIV 4 = -3); + ASSERT(9 MOD 4 = 1); + ASSERT((-9) MOD 4 = 3); + n := -9; + y := 4; + ASSERT(n * y = -36); + ASSERT(n DIV y = -3); + ASSERT(n MOD y = 3); + i := 1; + j := 1; + n := (IncReturnZero(i) + 3) DIV (IncReturnZero(j) + 2); + ASSERT(n = 1); + ASSERT(i = 2); + ASSERT(j = 2); + n := IncReturnZero(i) MOD (IncReturnZero(j) + 1); + ASSERT(i = 3); + ASSERT(j = 3); + + (*reals*) + ASSERT(9.0 * 2.0 >= 18.0 - eps); + ASSERT(9.0 * 2.0 <= 18.0 + eps); + ASSERT(9.0 / 2.0 >= 4.5 - eps); + ASSERT(9.0 / 2.0 <= 4.5 + eps); + x := 9.0; + ASSERT(x * 2.0 >= 18.0 - eps); + ASSERT(x * 2.0 <= 18.0 + eps); + ASSERT(x / 2.0 >= 4.5 - eps); + ASSERT(x / 2.0 <= 4.5 + eps); + + (*bytes*) + y := 9; + ASSERT(y * 2 = 18); + (*ASSERT(y DIV 4 = 2); + ASSERT(y MOD 4 = 1);*) + + (*sets*) + ASSERT({0, 1} * {1, 2} = {1}); + ASSERT({0, 1} / {1, 2} = {0, 2}); + A := {0, 1}; + ASSERT(A * {1, 2} = {1}); + ASSERT(A / {1, 2} = {0, 2}) + END TestMultiplicativeOperations; + + + PROCEDURE TestPredeclaredFunctionProcedures; + CONST eps = 0.01; + (*make sure function procedures with constant parameters are constant expressions*) + absConst = ABS(0); + oddConst = ODD(0); + lslConst = LSL(0, 0); + asrConst = ASR(0, 0); + rorConst = ROR(0, 1); + floorConst = FLOOR(eps); + fltConst = FLT(0); + ordConst = ORD(TRUE); + chrConst = CHR(0); + + VAR a: ARRAY 10 OF CHAR; + b: BOOLEAN; + ch: CHAR; + i, j, k: INTEGER; + r: REAL; + x: BYTE; + s: SET; + BEGIN + ASSERT(ABS(-1) = 1); + ASSERT(ABS(0) = 0); + ASSERT(ABS(1) = 1); + ASSERT(ABS(-1.0) = 1.0); + ASSERT(ABS(0.0) = 0.0); + ASSERT(ABS(1.0) = 1.0); + i := 0; + j := ABS(IncReturnZero(i) - 1); + ASSERT(j = 1); + ASSERT(i = 1); + + ASSERT(~ODD(-2)); + ASSERT(ODD(-1)); + ASSERT(~ODD(0)); + ASSERT(ODD(1)); + ASSERT(~ODD(2)); + + a := ""; + ASSERT(LEN(a) = 10); + + ASSERT(LSL(0, 0) = 0); + ASSERT(LSL(0, 1) = 0); + ASSERT(LSL(1, 0) = 1); + ASSERT(LSL(1, 1) = 2); + + ASSERT(ASR(0, 0) = 0); + ASSERT(ASR(0, 1) = 0); + ASSERT(ASR(1, 0) = 1); + ASSERT(ASR(1, 1) = 0); + + ASSERT(ROR(0, 1) = 0); + ASSERT(ROR(2, 1) = 1); + i := 0; + j := 0; + k := ROR(IncReturnZero(i) + 2, IncReturnZero(j) + 1); + ASSERT(k = 1); + ASSERT(i = 1); + ASSERT(j = 1); + + ASSERT(FLOOR(-1.5) = -2); + ASSERT(FLOOR(0.0) = 0); + ASSERT(FLOOR(1.5) = 1); + i := 0; + j := FLOOR(FLT(IncReturnZero(i)) + 1.5); + ASSERT(j = 1); + ASSERT(i = 1); + + ASSERT(FLT(-1) = -1.0); + ASSERT(FLT(0) = 0.0); + ASSERT(FLT(1) = 1.0); + + ASSERT(ORD(0X) = 0); + ch := 0X; + ASSERT(ORD(ch) = 0); + ASSERT(ORD("A") = 41H); + ch := "A"; + ASSERT(ORD(ch) = 41H); + ASSERT(ORD(0FFX) = 0FFH); + ch := 0FFX; + ASSERT(ORD(ch) = 0FFH); + + ASSERT(ORD(FALSE) = 0); + b := FALSE; + ASSERT(ORD(b) = 0); + ASSERT(ORD(TRUE) = 1); + b := TRUE; + ASSERT(ORD(b) = 1); + + ASSERT(ORD({}) = 0); + s := {}; + ASSERT(ORD(s) = 0); + ASSERT(ORD({8}) = 256); + s := {8}; + ASSERT(ORD(s) = 256); + + ASSERT(CHR(0) = 0X); + ASSERT(CHR(1) = 1X); + ASSERT(CHR(7FH) = 7FX); + ch := 7FX; + ASSERT(CHR(7FH) = ch); + x := 1; + ASSERT(CHR(x) = 1X); + + i := absConst; + b := oddConst; + i := lslConst; + i := asrConst; + i := rorConst; + i := floorConst; + r := fltConst; + i := ordConst; + ch := chrConst + END TestPredeclaredFunctionProcedures; + +BEGIN + TestDesignators; + TestSetConstructors; + TestRelationalOperations; + TestAdditiveOperations; + TestMultiplicativeOperations; + TestPredeclaredFunctionProcedures; +END T4Expressions. diff --git a/tests/obnc/passing/T5Statements.obn b/tests/obnc/passing/T5Statements.obn new file mode 100644 index 0000000..8be76cd --- /dev/null +++ b/tests/obnc/passing/T5Statements.obn @@ -0,0 +1,550 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5Statements; + + TYPE + T0 = RECORD END; + T1 = RECORD (T0) END; + + Shape = POINTER TO ShapeDesc; + ShapeDesc = RECORD + x, y: REAL + END; + + Rectangle = POINTER TO RectangleDesc; + RectangleDesc = RECORD (ShapeDesc) + w, h: REAL + END; + + Circle = POINTER TO CircleDesc; + CircleDesc = RECORD (ShapeDesc) + r: REAL + END; + + String = ARRAY 256 OF CHAR; + + VAR + globalInteger: INTEGER; + + PROCEDURE TestBasicAssignments; + VAR b, b1: BOOLEAN; + ch, ch1: CHAR; + n, n1: INTEGER; + x, x1: REAL; + y, y1: BYTE; + A, A1: SET; + BEGIN + b := TRUE; + b1 := FALSE; + b := b1; + ASSERT(b = b1); + ch := "a"; + ch1 := 22X; + ch := ch1; + ASSERT(ch = ch1); + n := 0; + n1 := -1; + n := n1; + ASSERT(n = n1); + x := 0.0; + x1 := -1.0; + x := x1; + ASSERT(x = x1); + y := 0; + y1 := 255; + y := y1; + ASSERT(y = y1); + n := 0; + y := n; + ASSERT(y = n); + A := {}; + A1 := {0, 1}; + A := A1; + ASSERT(A = A1); + END TestBasicAssignments; + + + PROCEDURE TestArrayAssignments; + VAR str, str1: ARRAY 60 OF CHAR; + strs, strs1: ARRAY 2 OF String; + strs2: ARRAY 1, 2 OF String; + + PROCEDURE AssignString(VAR s: ARRAY OF CHAR); + BEGIN + s := "hello" + END AssignString; + + PROCEDURE AssignOpenArray(s: ARRAY OF CHAR); + VAR t: ARRAY 128 OF CHAR; + BEGIN + t := s; + ASSERT(t = s) + END AssignOpenArray; + + PROCEDURE AssignMultiDimOpenArray(s: ARRAY OF ARRAY OF String); + VAR t: ARRAY 2 OF String; + BEGIN + t := s[0]; + ASSERT(t[0] = s[0, 0]); + ASSERT(t[1] = s[0, 1]) + END AssignMultiDimOpenArray; + + BEGIN + str := "testing, testing..."; + str1 := "more testing..."; + str := str1; + ASSERT(str = str1); + AssignString(str); + ASSERT(str = "hello"); + AssignOpenArray("hello"); + + strs[0] := "foo"; + ASSERT(strs[0] = "foo"); + strs[1] := "bar"; + ASSERT(strs[1] = "bar"); + strs[1] := strs[0]; + ASSERT(strs[1] = "foo"); + + strs[0] := "foo"; + strs[1] := "bar"; + strs1 := strs; + ASSERT(strs1[0] = "foo"); + ASSERT(strs1[1] = "bar"); + + AssignMultiDimOpenArray(strs2) + END TestArrayAssignments; + + + PROCEDURE TestRecordAssignments; + CONST eps = 0.01; + VAR foo, bar: RECORD ch: CHAR; i: INTEGER END; + s: ShapeDesc; + r: RectangleDesc; + c: CircleDesc; + a: ARRAY 10 OF CircleDesc; + + PROCEDURE P(VAR s: ShapeDesc); + BEGIN + ASSERT(s IS CircleDesc); + s(CircleDesc) := s(CircleDesc); + s(CircleDesc).r := 1.0 + END P; + + PROCEDURE Copy(VAR source, target: ShapeDesc); + BEGIN + target := source + END Copy; + + BEGIN + foo.i := 37; + bar := foo; + ASSERT(bar.i = 37); + + s.x := 0.0; + s.y := 0.0; + r.x := 0.0; + P(c); + ASSERT(ABS(c.r - 1.0) < eps); + + r.x := 1.0; + s := r; + ASSERT(s.x = r.x); + + P(a[9]); + + Copy(r, r) + END TestRecordAssignments; + + + PROCEDURE TestPointerAssignments; + VAR x: Rectangle; + y: Shape; + s: POINTER TO ShapeDesc; + r: POINTER TO RectangleDesc; + r1: POINTER TO RectangleDesc; + BEGIN + NEW(x); + y := x; + ASSERT(y IS Rectangle); + NEW(r); + s := r; + ASSERT(s IS RectangleDesc); + r1 := r; + ASSERT(r1 IS RectangleDesc) + END TestPointerAssignments; + + + PROCEDURE P; + END P; + + PROCEDURE P1(n: INTEGER); + END P1; + + PROCEDURE P2(n: INTEGER; x: REAL); + END P2; + + PROCEDURE F(): INTEGER; + RETURN 0 + END F; + + PROCEDURE F1(n: INTEGER): INTEGER; + RETURN 0 + END F1; + + PROCEDURE F2(VAR n: INTEGER; x: REAL; s: ARRAY OF CHAR): INTEGER; + RETURN 0 + END F2; + + PROCEDURE TestProcedureAssignments; + TYPE + PT = PROCEDURE; + PT1 = PROCEDURE (n: INTEGER); + PT2 = PROCEDURE (n: INTEGER; x: REAL); + FT = PROCEDURE (): INTEGER; + FT1 = PROCEDURE (n: INTEGER): INTEGER; + FT2 = PROCEDURE (VAR n: INTEGER; x: REAL; s: ARRAY OF CHAR): INTEGER; + VAR p: PT; p1: PT1; p2: PT2; + f: FT; f1: FT1; f2, g2: FT2; + n: INTEGER; + + PROCEDURE Local; + END Local; + + BEGIN + p := NIL; + p := P; + p := Local; + p1 := P1; + p2 := P2; + f := F; + n := f(); + f1 := F1; + f2 := F2; + g2 := f2 + END TestProcedureAssignments; + + + PROCEDURE TestAssignments; + BEGIN + TestBasicAssignments; + TestArrayAssignments; + TestRecordAssignments; + TestPointerAssignments; + TestProcedureAssignments + END TestAssignments; + + + PROCEDURE TestProcedureCalls; + VAR s: ARRAY 16 OF CHAR; + p0: POINTER TO T0; + p1: POINTER TO T1; + + PROCEDURE P1; + END P1; + + PROCEDURE P2(n: INTEGER); + END P2; + + PROCEDURE P3(a, b: INTEGER); + END P3; + + PROCEDURE P4(a: INTEGER; b: INTEGER); + END P4; + + PROCEDURE P5(ch: CHAR); + END P5; + + PROCEDURE P6(s: ARRAY OF CHAR); + END P6; + + PROCEDURE P7(VAR t: T0); + BEGIN + ASSERT(t IS T1) + END P7; + + BEGIN + P1; + P2(0); + P3(0, 0); + P4(0, 0); + P5("x"); + P5(0X); + P6("test"); + s := "test"; + P6(s); + NEW(p1); + p0 := p1; + P7(p0^) + END TestProcedureCalls; + + + PROCEDURE TestPredeclaredProperProcedures; + CONST eps = 0.01; + VAR n, i, j: INTEGER; + A: SET; + x: REAL; + a: ARRAY 1 OF REAL; + b: ARRAY 1 OF INTEGER; + v: POINTER TO RECORD f: INTEGER END; + + PROCEDURE IncReturnZero(VAR x: INTEGER): INTEGER; + BEGIN + INC(x) + RETURN 0 + END IncReturnZero; + + BEGIN + n := 0; + INC(n); + ASSERT(n = 1); + + n := 0; + INC(n, 10); + ASSERT(n = 10); + + n := 0; + DEC(n); + ASSERT(n = -1); + + n := 0; + DEC(n, 10); + ASSERT(n = -10); + + A := {}; + INCL(A, 0); + ASSERT(A = {0}); + + A := {0}; + EXCL(A, 0); + ASSERT(A = {}); + + NEW(v); + ASSERT(v # NIL); + v.f := 1; + ASSERT(v.f = 1); + + x := 1.0; + PACK(x, 2); + ASSERT(x >= 4.0 - eps); + ASSERT(x <= 4.0 + eps); + a[0] := 1.0; + i := 0; + j := 0; + PACK(a[IncReturnZero(i)], IncReturnZero(j) + 2); + ASSERT(a[0] >= 4.0 - eps); + ASSERT(a[0] <= 4.0 + eps); + ASSERT(i = 1); + ASSERT(j = 1); + + x := 4.0; + UNPK(x, n); + ASSERT(x >= 1.0); + ASSERT(x < 2.0); + ASSERT(n = 2); + a[0] := 4.0; + i := 0; + j := 0; + UNPK(a[IncReturnZero(i)], b[IncReturnZero(j)]); + ASSERT(a[0] >= 1.0); + ASSERT(a[0] < 2.0); + ASSERT(b[0] = 2); + ASSERT(i = 1); + ASSERT(j = 1) + END TestPredeclaredProperProcedures; + + + PROCEDURE TestIfStatements; + VAR n: INTEGER; + BEGIN + n := 0; + IF n = 0 THEN + n := 1 + END; + ASSERT(n = 1); + n := 1; + IF n = 0 THEN + n := 1 + ELSE + n := 2 + END; + ASSERT(n = 2); + n := 2; + IF n = 0 THEN + n := 1 + ELSIF n = 1 THEN + n := 2 + ELSE + n := 3 + END; + ASSERT(n = 3) + END TestIfStatements; + + + PROCEDURE TestCaseStatements; + CONST + C = 0; + + VAR + n: INTEGER; + ch: CHAR; + sp: Shape; + rp: Rectangle; + c: CircleDesc; + + PROCEDURE P(VAR s: ShapeDesc); + BEGIN + CASE s OF + (*ShapeDesc: + s.x := 0.0; s.y := 0.0 + | *)RectangleDesc: + s.w := 1.0; s.h := 0.0 + | CircleDesc: + s.r := 1.0 + END; + END P; + + BEGIN + n := 15; + CASE n OF + C: + CASE 1 OF + 1: + END + | 1, 2: + CASE sp OF END + | 4, 5, 7: + | 8 .. 9: + | 10, 12 .. 20: + n := 0 + END; + ASSERT(n = 0); + ch := "u"; + CASE ch OF + | 0X: + | "a", "b": + | "d", "e", "f": + | "h" .. "k": + | "l", "m" .. "z": + ch := 0X + END; + ASSERT(ch = 0X); + NEW(rp); + sp := rp; + CASE sp OF + (*Shape: + sp.x := 0.0; sp.y := 0.0 + | *)Rectangle: + sp.w := 1.0; sp.h := 2.0; + sp := sp + | Circle: + sp.r := 1.0 + END; + ASSERT(sp(Rectangle).w = 1.0); + ASSERT(sp(Rectangle).h = 2.0); + P(c); + ASSERT(c.r = 1.0); + END TestCaseStatements; + + + PROCEDURE TestWhileStatements; + VAR n, n1, i: INTEGER; + BEGIN + n := 0; + i := 1; + WHILE i <= 10 DO + n := n + 1; + i := i + 1 + END; + ASSERT(n = 10); + n := 4; + n1 := 6; + WHILE n > n1 DO + n := n - n1 + ELSIF n1 > n DO + n1 := n1 - n + END; + ASSERT(n = 2); + ASSERT(n1 = 2); + n := 5; + n1 := 6; + WHILE n > n1 DO + n := n - n1 + ELSIF n1 > n DO + n1 := n1 - n + END; + ASSERT(n = 1); + ASSERT(n1 = 1); + END TestWhileStatements; + + + PROCEDURE TestRepeatStatements; + VAR n, i: INTEGER; + BEGIN + n:= 0; + i := 1; + REPEAT + INC(n); + INC(i) + UNTIL i = 11; + ASSERT(n = 10); + END TestRepeatStatements; + + + PROCEDURE IncGlobalIntegerReturnOne(): INTEGER; + BEGIN + INC(globalInteger) + RETURN 1 + END IncGlobalIntegerReturnOne; + + + PROCEDURE TestForStatements; + VAR n, i: INTEGER; + x: REAL; + BEGIN + n := 0; + FOR i := 1 TO 10 DO + n := n + 1 + END; + ASSERT(n = 10); + n := 0; + FOR i := 1 TO 20 BY 2 DO + n := n + 1 + END; + ASSERT(n = 10); + n := 0; + FOR i := 20 TO 1 BY -2 DO + n := n + 1 + END; + ASSERT(n = 10); + globalInteger := 0; + FOR i := 0 TO IncGlobalIntegerReturnOne() DO (*make sure the limit function is called three times*) + x := x + 1.0 + END; + ASSERT(globalInteger = 3) + END TestForStatements; + +BEGIN + TestAssignments; + TestProcedureCalls; + TestPredeclaredProperProcedures; + TestIfStatements; + TestCaseStatements; + TestWhileStatements; + TestRepeatStatements; + TestForStatements +END T5Statements. diff --git a/tests/obnc/passing/T5SystemStatements.obn b/tests/obnc/passing/T5SystemStatements.obn new file mode 100644 index 0000000..8610c0a --- /dev/null +++ b/tests/obnc/passing/T5SystemStatements.obn @@ -0,0 +1,98 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T5SystemStatements; + + IMPORT SYSTEM; + + PROCEDURE Test; + CONST byte = SYSTEM.VAL(BYTE, 100); + TYPE Array = ARRAY 2 OF INTEGER; + Pointer = POINTER TO RECORD END; + VAR b, b1: BOOLEAN; + ch, ch1: CHAR; + i, i1: INTEGER; + r, r1: REAL; + x, x1: BYTE; + xs: ARRAY 2 OF BYTE; + s, s1: SET; + a, a1: Array; + a2: ARRAY SYSTEM.SIZE(Array) + 1 OF INTEGER; + BEGIN + ASSERT(SYSTEM.SIZE(INTEGER) = SYSTEM.SIZE(Pointer)); + + (*ADR, PUT, GET*) + b := TRUE; + SYSTEM.GET(SYSTEM.ADR(b), b1); + ASSERT(b1 = b); + SYSTEM.PUT(SYSTEM.ADR(b), FALSE); + ASSERT(~b); + ch := "a"; + SYSTEM.GET(SYSTEM.ADR(ch), ch1); + ASSERT(ch1 = ch); + SYSTEM.PUT(SYSTEM.ADR(ch), "b"); + ASSERT(ch = "b"); + SYSTEM.PUT(SYSTEM.ADR(ch), ch1); + ASSERT(ch = ch1); + i := 1; + SYSTEM.GET(SYSTEM.ADR(i), i1); + ASSERT(i1 = i); + SYSTEM.PUT(SYSTEM.ADR(i), 0); + ASSERT(i = 0); + r := 1.0; + SYSTEM.GET(SYSTEM.ADR(r), r1); + ASSERT(r1 = r); + SYSTEM.PUT(SYSTEM.ADR(r), 0.0); + ASSERT(r = 0.0); + x := 1; + SYSTEM.GET(SYSTEM.ADR(x), x1); + ASSERT(x1 = x); + SYSTEM.PUT(SYSTEM.ADR(x), 0); + ASSERT(x = 0); + s := {0}; + SYSTEM.GET(SYSTEM.ADR(s), s1); + ASSERT(s1 = s); + SYSTEM.PUT(SYSTEM.ADR(s), {}); + ASSERT(s = {}); + + (*BIT*) + i := 1; + ASSERT(SYSTEM.BIT(SYSTEM.ADR(i), 0)); + i := 2; + ASSERT(~SYSTEM.BIT(SYSTEM.ADR(i), 0)); + ASSERT(SYSTEM.BIT(SYSTEM.ADR(i), 1)); + + (*COPY*) + a[0] := 1; a[1] := 2; + SYSTEM.COPY(SYSTEM.ADR(a), SYSTEM.ADR(a1), 2); + ASSERT(a1[0] = 1); + ASSERT(a1[1] = 2); + + (*VAL*) + xs[0] := 1; xs[1] := 2; + SYSTEM.PUT(SYSTEM.ADR(xs), SYSTEM.VAL(BYTE, 37)); + ASSERT(xs[0] = 37); + ASSERT(xs[1] = 2); + + (*silence "unused" compiler notifications*) + x := byte; + a2[0] := 0 + END Test; + +BEGIN + Test +END T5SystemStatements. diff --git a/tests/obnc/passing/T6ProcedureDeclarations.obn b/tests/obnc/passing/T6ProcedureDeclarations.obn new file mode 100644 index 0000000..a6a8adc --- /dev/null +++ b/tests/obnc/passing/T6ProcedureDeclarations.obn @@ -0,0 +1,259 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T6ProcedureDeclarations; + + TYPE + Row = ARRAY 20 OF INTEGER; + Matrix = ARRAY 10, 20 OF INTEGER; + Ptr = POINTER TO RECORD f: INTEGER END; + Proc = PROCEDURE; + T0 = RECORD END; + T1 = RECORD (T0) END; + T2 = RECORD (T1) + f: INTEGER + END; + + PROCEDURE TestValueParameters; + VAR ptr: Ptr; + proc: Proc; + A: Matrix; + B: ARRAY 10 OF Row; + + PROCEDURE P(x: INTEGER); + BEGIN + x := 0 + END P; + + PROCEDURE P1(x: Ptr); + BEGIN + x := NIL + END P1; + + PROCEDURE P2(x: Proc); + BEGIN + x := NIL + END P2; + + PROCEDURE P3(A: Matrix); + BEGIN + ASSERT(LEN(A) = 10); + ASSERT(LEN(A[0]) = 20) + END P3; + + PROCEDURE P4(A: ARRAY OF Row); + END P4; + + BEGIN + P(0); + NEW(ptr); + P1(ptr); + P2(proc); + P3(A); + P4(B) + END TestValueParameters; + + + PROCEDURE TestVarParameters; + VAR x: Ptr; + A: Matrix; + y: T2; + + PROCEDURE Alloc(VAR p: Ptr); + BEGIN + NEW(p); + p.f := 1 + END Alloc; + + PROCEDURE P(VAR A: Matrix); + BEGIN + ASSERT(LEN(A) = 10); + ASSERT(LEN(A[0]) = 20) + END P; + + PROCEDURE Q(VAR x: T0); + PROCEDURE R(VAR x: T1); + BEGIN + x(T2).f := 1 + END R; + BEGIN + R(x(T1)) + END Q; + + BEGIN + Alloc(x); + ASSERT(x.f = 1); + P(A); + y.f := 0; + Q(y) + END TestVarParameters; + + + PROCEDURE TestOpenArrayParameters; + VAR + a: ARRAY 2 OF INTEGER; + M: ARRAY 2, 3 OF INTEGER; + T: ARRAY 2, 3, 4 OF INTEGER; + c, i, j, k: INTEGER; + + PROCEDURE P(a: ARRAY OF INTEGER); + VAR i: INTEGER; + BEGIN + FOR i := 0 TO LEN(a) - 1 DO + ASSERT(a[i] = i + 1) + END + END P; + + PROCEDURE Q(M: ARRAY OF ARRAY OF INTEGER); + VAR a: ARRAY 3 OF INTEGER; + + PROCEDURE Inner(M: ARRAY OF ARRAY OF INTEGER); + VAR c, i, j: INTEGER; + BEGIN + c := 0; + FOR i := 0 TO LEN(M) - 1 DO + FOR j := 0 TO LEN(M[0]) - 1 DO + ASSERT(M[i, j] = c); + INC(c) + END + END; + END Inner; + + PROCEDURE Inner1(row: ARRAY OF INTEGER); + VAR c, j: INTEGER; + BEGIN + c := LEN(row); + FOR j := 0 TO LEN(row) - 1 DO + ASSERT(row[j] = c); + INC(c) + END + END Inner1; + + BEGIN + Inner(M); + Inner1(M[1]); + a := M[1] + END Q; + + PROCEDURE R(VAR T: ARRAY OF ARRAY OF ARRAY OF INTEGER); + VAR c, i, j, k: INTEGER; + BEGIN + c := 0; + FOR i := 0 TO LEN(T) - 1 DO + FOR j := 0 TO LEN(T[0]) - 1 DO + FOR k := 0 TO LEN(T[0, 0]) - 1 DO + ASSERT(T[i, j, k] = c); + INC(c) + END + END + END; + T[0, 0, 0] := 0 + END R; + + BEGIN + FOR i := 0 TO LEN(a) - 1 DO + a[i] := i + 1 + END; + P(a); + + c := 0; + FOR i := 0 TO LEN(M) - 1 DO + FOR j := 0 TO LEN(M[0]) - 1 DO + M[i, j] := c; + INC(c) + END + END; + Q(M); + + c := 0; + FOR i := 0 TO LEN(T) - 1 DO + FOR j := 0 TO LEN(T[0]) - 1 DO + FOR k := 0 TO LEN(T[0, 0]) - 1 DO + T[i, j, k] := c; + INC(c) + END + END + END; + R(T) + END TestOpenArrayParameters; + + + PROCEDURE TestResultExpressions; + VAR x: Ptr; + + PROCEDURE P(): Ptr; + TYPE PtrExt = POINTER TO RECORD (Ptr) END; + VAR y: PtrExt; + BEGIN + NEW(y) + RETURN y + END P; + + BEGIN + x := P() + END TestResultExpressions; + + + PROCEDURE TestLocalProcedures; + VAR s: INTEGER; + + PROCEDURE Sum(n: INTEGER): INTEGER; + + PROCEDURE Inner(i, acc: INTEGER): INTEGER; + VAR result: INTEGER; + BEGIN + IF i >= 1 THEN + result := Inner(i - 1, acc + i) + ELSE + result := acc + END + RETURN result + END Inner; + + RETURN Inner(n, 0) + END Sum; + + BEGIN + s := Sum(10); + ASSERT(s = 55) + END TestLocalProcedures; + + + PROCEDURE TestScope; + TYPE + List = POINTER TO Node; + Node = RECORD + item: INTEGER; + next: List + END; + Proc = PROCEDURE (x: List): List; + VAR + TestScope: PROCEDURE; + p: Proc; + BEGIN + TestScope := NIL; + p := NIL + END TestScope; + +BEGIN + TestValueParameters; + TestVarParameters; + TestOpenArrayParameters; + TestResultExpressions; + TestLocalProcedures; + TestScope +END T6ProcedureDeclarations. diff --git a/tests/obnc/passing/T7Modules.obn b/tests/obnc/passing/T7Modules.obn new file mode 100644 index 0000000..ae36312 --- /dev/null +++ b/tests/obnc/passing/T7Modules.obn @@ -0,0 +1,85 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE T7Modules; + + IMPORT + A, + B1 := B, + B := C, + D := D, + E, + T7Modules := libE, + lib1M, + OBNC; + + TYPE + ListExt = POINTER TO RECORD (A.List) END; + + VAR + intVar: INTEGER; + w: B.T; + x: B1.T; + y: A.Nested; + list: A.List; + matrix: ARRAY 2, 3 OF INTEGER; + x0: B.P0; + x1: B1.P1; + t: B1.T; + p: B1.P1; + p1: ListExt; + +BEGIN + ASSERT(A.boolConst); + ASSERT(A.charConst = CHR(22H)); + ASSERT(A.intConst = 1); + ASSERT(A.realConst = 2.3); + ASSERT(A.strConst = "hello there"); + ASSERT(A.nul = 0X); + ASSERT(A.lf = 0AX); + ASSERT(A.charMax = 0FFX); + ASSERT(A.setConst = {0, 2, 3, 5}); + + ASSERT(A.boolVar = A.boolConst); + ASSERT(A.charVar = A.charConst); + ASSERT(A.intVar = A.intConst); + ASSERT(ABS(A.realVar - A.realConst) < 1.0E-6); + ASSERT(A.strVar = A.strConst); + ASSERT(A.setVar = A.setConst); + ASSERT(A.recVar.f = 1); + + intVar := A.intVar; + A.procVar(A.strVar); + NEW(y.f); + y.f.f := 1; + w := x; + A.Q(x); + NEW(list); + A.R(matrix); + x0 := x1; + A.S(t); + A.S1(p); + + ASSERT(D.b); + ASSERT(E.b); + ASSERT(T7Modules.b); + ASSERT(lib1M.b); + ASSERT(OBNC.b); + p1 := NIL +END T7Modules. + +All text after a module should be ignored diff --git a/tests/obnc/passing/a dir/E.Mod b/tests/obnc/passing/a dir/E.Mod new file mode 100644 index 0000000..fb5f6a7 --- /dev/null +++ b/tests/obnc/passing/a dir/E.Mod @@ -0,0 +1,22 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE E; + + CONST b* = TRUE; + +END E. diff --git a/tests/obnc/passing/lib/Local.obn b/tests/obnc/passing/lib/Local.obn new file mode 100644 index 0000000..20f0e0e --- /dev/null +++ b/tests/obnc/passing/lib/Local.obn @@ -0,0 +1,29 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE Local; + + TYPE + T* = RECORD f*: INTEGER END; + + VAR + x*: INTEGER; + + PROCEDURE P*; + END P; + +END Local. diff --git a/tests/obnc/passing/lib/libE.obn b/tests/obnc/passing/lib/libE.obn new file mode 100644 index 0000000..1ce3cf5 --- /dev/null +++ b/tests/obnc/passing/lib/libE.obn @@ -0,0 +1,29 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE libE; + + IMPORT Local; + + CONST b* = TRUE; + + VAR + x: Local.T; + +BEGIN + x.f := 0 +END libE. diff --git a/tests/obnc/passing/lib1/Local.obn b/tests/obnc/passing/lib1/Local.obn new file mode 100644 index 0000000..20f0e0e --- /dev/null +++ b/tests/obnc/passing/lib1/Local.obn @@ -0,0 +1,29 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE Local; + + TYPE + T* = RECORD f*: INTEGER END; + + VAR + x*: INTEGER; + + PROCEDURE P*; + END P; + +END Local. diff --git a/tests/obnc/passing/lib1/lib1M.obn b/tests/obnc/passing/lib1/lib1M.obn new file mode 100644 index 0000000..1af45b2 --- /dev/null +++ b/tests/obnc/passing/lib1/lib1M.obn @@ -0,0 +1,29 @@ +(*Copyright (C) 2017, 2018, 2019 Karl Landstrom + +This file is part of OBNC. + +OBNC is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +OBNC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with OBNC. If not, see .*) + +MODULE lib1M; + + IMPORT Local; + + CONST b* = TRUE; + + VAR + x: Local.T; + +BEGIN + x.f := 0 +END lib1M. diff --git a/tests/obncdoc/ExportedFeatures.def b/tests/obncdoc/ExportedFeatures.def new file mode 100644 index 0000000..8a3fadc --- /dev/null +++ b/tests/obncdoc/ExportedFeatures.def @@ -0,0 +1,30 @@ +DEFINITION ExportedFeatures; (*documentation...*) + + IMPORT F := Files; + + CONST + s = "s* = 'foo'; (**"; (*(*"foo"*)*) + + TYPE + T = RECORD + f: RECORD (*documentation...*) + h: INTEGER + END; + END; + + T1 = RECORD (T) END; + + VAR + x: T; (*documentation...*) + u: F.File; + + PROCEDURE P(x: INTEGER; + y: REAL; + z: BYTE); +(*documentation, +documentation...*) + + PROCEDURE R((*in/out*) VAR x: INTEGER; (*out*) VAR y: REAL; VAR z: BYTE); +(*documentation...*) + +END ExportedFeatures. diff --git a/tests/obncdoc/ExportedFeatures.def.html b/tests/obncdoc/ExportedFeatures.def.html new file mode 100644 index 0000000..5f0c351 --- /dev/null +++ b/tests/obncdoc/ExportedFeatures.def.html @@ -0,0 +1,45 @@ + + + + + + DEFINITION ExportedFeatures + + + +

Index

+ + 
+DEFINITION ExportedFeatures; (*documentation...*)
+
+	IMPORT F := Files;
+
+	CONST
+		s = "s* = 'foo'; (**"; (*(*"foo"*)*)
+
+	TYPE
+		T = RECORD
+			f: RECORD (*documentation...*)
+				h: INTEGER
+			END;
+		END;
+
+		T1 = RECORD (T) END;
+
+	VAR
+		x: T; (*documentation...*)
+		u: F.File;
+
+	PROCEDURE P(x: INTEGER;
+		y: REAL;
+		z: BYTE);
+(*documentation,
+documentation...*)
+
+	PROCEDURE R((*in/out*) VAR x: INTEGER; (*out*) VAR y: REAL; VAR z: BYTE);
+(*documentation...*)
+
+END ExportedFeatures.
+
+ + diff --git a/tests/obncdoc/ExportedFeatures.obn b/tests/obncdoc/ExportedFeatures.obn new file mode 100644 index 0000000..9492aea --- /dev/null +++ b/tests/obncdoc/ExportedFeatures.obn @@ -0,0 +1,51 @@ +MODULE ExportedFeatures; (**documentation...*) + + IMPORT F := Files, Out; + + CONST + s* = "s* = 'foo'; (**"; (**(*"foo"*)*) + (*s* = "s* = 'foo'; (**"; (**(*"foo"*)*)*)*) + t = 37; + + TYPE + T0 = INTEGER; + + (*documentation...*) + T* = RECORD + f*: RECORD (**documentation...*) + g: INTEGER; + h*: INTEGER + END; + g: REAL + END; + + T1* = RECORD (T) (*documentation...*) + h: INTEGER + END; + + T2 = RECORD + (*f*: INTEGER*) + END; + + VAR + x*, y: T; (**documentation...*) + z, u*: F.File; + + PROCEDURE P*(x: INTEGER; + y: REAL; + z: BYTE); +(**documentation, +documentation...*) + END P; + + + PROCEDURE Q; +(*documentation...*) + END Q; + + + PROCEDURE R*((**in/out*) VAR x: INTEGER; (**out*) VAR y: REAL; (*out*) VAR z: BYTE); +(**documentation...*) + END R; + +END ExportedFeatures. diff --git a/tests/obncdoc/NoExportedFeatures.def b/tests/obncdoc/NoExportedFeatures.def new file mode 100644 index 0000000..58494c3 --- /dev/null +++ b/tests/obncdoc/NoExportedFeatures.def @@ -0,0 +1,2 @@ +DEFINITION NoExportedFeatures; +END NoExportedFeatures. diff --git a/tests/obncdoc/NoExportedFeatures.def.html b/tests/obncdoc/NoExportedFeatures.def.html new file mode 100644 index 0000000..2bd0805 --- /dev/null +++ b/tests/obncdoc/NoExportedFeatures.def.html @@ -0,0 +1,17 @@ + + + + + + DEFINITION NoExportedFeatures + + + +

Index

+ + 
+DEFINITION NoExportedFeatures;
+END NoExportedFeatures.
+
+ + diff --git a/tests/obncdoc/NoExportedFeatures.obn b/tests/obncdoc/NoExportedFeatures.obn new file mode 100644 index 0000000..65f87c5 --- /dev/null +++ b/tests/obncdoc/NoExportedFeatures.obn @@ -0,0 +1,17 @@ +MODULE NoExportedFeatures; + + IMPORT M := Math; + + CONST + alpha = M.pi; (*documentation*) + + TYPE + Int = INTEGER; + + VAR + x: INTEGER; + + PROCEDURE P; + END P; + +END NoExportedFeatures. diff --git a/tests/scanner/tokens.txt b/tests/scanner/tokens.txt new file mode 100644 index 0000000..9b7accf --- /dev/null +++ b/tests/scanner/tokens.txt @@ -0,0 +1,78 @@ +x +scan +Oberon +GetSymbol +firstLetter +32767 +100H +340282346638528859811704183484516925440.0 +4.567E+6 +4.567E-6 +179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.0 +1..10 +"" +0X +"*" +2AX +"Don't worry!" ++ +- +* +/ +~ +& +. +, +; +| +( +[ +{ +:= +^ += +# +< +> +<= +>= +.. +: +) +] +} +ARRAY +BEGIN +BY +CASE +CONST +DIV +DO +ELSE +ELSIF +END +FALSE +FOR +IF +IMPORT +IN +IS +MOD +MODULE +NIL +OF +OR +POINTER +PROCEDURE +RECORD +REPEAT +RETURN +THEN +TO +TRUE +TYPE +UNTIL +VAR +WHILE +(*a comment*) +(*a (*nested*) comment*) -- 2.49.0