From 02a3486a4adb7964c73018e2702ae19e0811e06e Mon Sep 17 00:00:00 2001 From: Alexander Shiryaev Date: Sat, 10 Nov 2012 22:58:33 +0400 Subject: [PATCH] =?utf8?q?=D0=94=D0=BE=D0=B1=D0=B0=D0=B2=D0=BB=D0=B5=D0=BD?= =?utf8?q?=D0=BE=20=D0=B4=D0=B5=D1=80=D0=B5=D0=B2=D0=BE=20BlackBox=20?= =?utf8?q?=D0=BD=D0=B0=20=D0=BE=D1=81=D0=BD=D0=BE=D0=B2=D0=B5=20=D0=BD?= =?utf8?q?=D0=B0=D1=80=D0=B0=D0=B1=D0=BE=D1=82=D0=BE=D0=BA=20Trurl-=D0=B0?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- Trurl-based/Cons/Mod/Compiler.odc | Bin 0 -> 3473 bytes Trurl-based/Cons/Mod/Interp.txt | 128 + Trurl-based/Cons/Mod/Log.txt | 193 + Trurl-based/Dev/Docu/ElfLinker.odc | Bin 0 -> 6795 bytes Trurl-based/Dev/Mod/CPB.txt | 2238 ++++++++++++ Trurl-based/Dev/Mod/CPC486.txt | 2333 ++++++++++++ Trurl-based/Dev/Mod/CPE.txt | 1105 ++++++ Trurl-based/Dev/Mod/CPH.txt | 291 ++ Trurl-based/Dev/Mod/CPL486.txt | 1057 ++++++ Trurl-based/Dev/Mod/CPM.txt | 853 +++++ Trurl-based/Dev/Mod/CPP.txt | 1650 +++++++++ Trurl-based/Dev/Mod/CPS.txt | 367 ++ Trurl-based/Dev/Mod/CPT.txt | 1890 ++++++++++ Trurl-based/Dev/Mod/CPV486.txt | 1774 +++++++++ Trurl-based/Dev/Mod/Commanders.txt | 361 ++ Trurl-based/Dev/Mod/Compiler.txt | 348 ++ Trurl-based/Dev/Mod/ElfLinker16.odc | Bin 0 -> 59458 bytes Trurl-based/Dev/Mod/Linker.odc | Bin 0 -> 57137 bytes Trurl-based/Dev/Mod/Markers.txt | 442 +++ Trurl-based/Dev/Mod/Selectors.txt | 411 +++ Trurl-based/Dev/Rsrc/Errors.odc | Bin 0 -> 10095 bytes Trurl-based/Dev/Rsrc/Strings.odc | Bin 0 -> 6103 bytes Trurl-based/Dev/Rsrc/ru/Strings.odc | Bin 0 -> 17048 bytes Trurl-based/Dev/Spec/ObjFile.odc | Bin 0 -> 6777 bytes Trurl-based/Dev/Spec/PackedFiles.odc | Bin 0 -> 26571 bytes Trurl-based/Dev/Spec/StoresFileFormat.odc | Bin 0 -> 2443 bytes Trurl-based/Dev/Spec/SymFile.odc | Bin 0 -> 3932 bytes Trurl-based/Dev0/Mod/CPB.odc | Bin 0 -> 85923 bytes Trurl-based/Dev0/Mod/CPB.txt | 2251 ++++++++++++ Trurl-based/Dev0/Mod/CPC486.odc | Bin 0 -> 85407 bytes Trurl-based/Dev0/Mod/CPC486.txt | 2347 ++++++++++++ Trurl-based/Dev0/Mod/CPE.odc | Bin 0 -> 40043 bytes Trurl-based/Dev0/Mod/CPE.txt | 1120 ++++++ Trurl-based/Dev0/Mod/CPH.odc | Bin 0 -> 12920 bytes Trurl-based/Dev0/Mod/CPH.txt | 304 ++ Trurl-based/Dev0/Mod/CPL486.odc | Bin 0 -> 37044 bytes Trurl-based/Dev0/Mod/CPL486.txt | 1070 ++++++ Trurl-based/Dev0/Mod/CPM.odc | Bin 0 -> 28285 bytes Trurl-based/Dev0/Mod/CPM.txt | 809 +++++ Trurl-based/Dev0/Mod/CPP.odc | Bin 0 -> 62670 bytes Trurl-based/Dev0/Mod/CPP.txt | 1662 +++++++++ Trurl-based/Dev0/Mod/CPS.odc | Bin 0 -> 15509 bytes Trurl-based/Dev0/Mod/CPS.txt | 379 ++ Trurl-based/Dev0/Mod/CPT.odc | Bin 0 -> 75987 bytes Trurl-based/Dev0/Mod/CPT.txt | 1904 ++++++++++ Trurl-based/Dev0/Mod/CPV486.odc | Bin 0 -> 67890 bytes Trurl-based/Dev0/Mod/CPV486.txt | 1788 ++++++++++ Trurl-based/Dev0/Mod/Compiler.odc | Bin 0 -> 5749 bytes Trurl-based/Dev0/Mod/Compiler.txt | 140 + Trurl-based/Dev0/Mod/ElfLinker16.odc | Bin 0 -> 63440 bytes Trurl-based/Dev0/Mod/ElfLinker16.txt | 1892 ++++++++++ Trurl-based/Dev0/Mod/Interp.txt | 56 + Trurl-based/Dev0/Mod/Linker.odc | Bin 0 -> 61632 bytes Trurl-based/Dev0/Mod/Linker.txt | 1779 +++++++++ Trurl-based/Dev0/Views.txt | 14 + Trurl-based/Docu/BB-Chars.odc | Bin 0 -> 9443 bytes Trurl-based/Docu/BB-Docu.odc | Bin 0 -> 10256 bytes Trurl-based/Docu/BB-License.odc | Bin 0 -> 3861 bytes Trurl-based/Docu/BB-Licensing-Policy.odc | Bin 0 -> 6010 bytes Trurl-based/Docu/BB-Open-Source-License.odc | Bin 0 -> 3861 bytes Trurl-based/Docu/BB-Road.odc | Bin 0 -> 16995 bytes Trurl-based/Docu/BB-Rules.odc | Bin 0 -> 16513 bytes Trurl-based/Docu/CP-Lang.odc | Bin 0 -> 81888 bytes Trurl-based/Docu/CP-New.odc | Bin 0 -> 30988 bytes Trurl-based/Docu/Contributors.odc | Bin 0 -> 2213 bytes Trurl-based/Docu/Help.odc | Bin 0 -> 7992 bytes Trurl-based/Docu/OpenBUGS-License.odc | Bin 0 -> 36151 bytes Trurl-based/Docu/Tut-1.odc | Bin 0 -> 24297 bytes Trurl-based/Docu/Tut-2.odc | Bin 0 -> 167019 bytes Trurl-based/Docu/Tut-3.odc | Bin 0 -> 70454 bytes Trurl-based/Docu/Tut-4.odc | Bin 0 -> 757985 bytes Trurl-based/Docu/Tut-5.odc | Bin 0 -> 249684 bytes Trurl-based/Docu/Tut-6.odc | Bin 0 -> 84332 bytes Trurl-based/Docu/Tut-A.odc | Bin 0 -> 11384 bytes Trurl-based/Docu/Tut-B.odc | Bin 0 -> 9108 bytes Trurl-based/Docu/Tut-TOC.odc | Bin 0 -> 3750 bytes Trurl-based/Docu/Tut-Tot.odc | Bin 0 -> 1369673 bytes Trurl-based/Obx/Mod/Hello0.odc | Bin 0 -> 3032 bytes Trurl-based/Obx/Mod/Pi.odc | Bin 0 -> 3790 bytes Trurl-based/Obx/Mod/Random.odc | Bin 0 -> 2951 bytes Trurl-based/Obx/Mod/Trap.odc | Bin 0 -> 3129 bytes Trurl-based/Sql/Database/Companies | 22 + Trurl-based/Sql/Database/Ownership | 19 + Trurl-based/Sql/Database/schema.ini | 15 + Trurl-based/Sql/Docu/Browser.odc | Bin 0 -> 1336 bytes Trurl-based/Sql/Docu/Controls.odc | Bin 0 -> 1337 bytes Trurl-based/Sql/Docu/Db.odc | Bin 0 -> 16309 bytes Trurl-based/Sql/Docu/Dev-Man.odc | Bin 0 -> 50922 bytes Trurl-based/Sql/Docu/Drivers.odc | Bin 0 -> 1336 bytes Trurl-based/Sql/Docu/ObxDB.odc | Bin 0 -> 1334 bytes Trurl-based/Sql/Docu/ObxDriv.odc | Bin 0 -> 1336 bytes Trurl-based/Sql/Docu/ObxExt.odc | Bin 0 -> 1335 bytes Trurl-based/Sql/Docu/ObxGen.odc | Bin 0 -> 1335 bytes Trurl-based/Sql/Docu/ObxInit.odc | Bin 0 -> 1336 bytes Trurl-based/Sql/Docu/ObxNets.odc | Bin 0 -> 1336 bytes Trurl-based/Sql/Docu/ObxTab.odc | Bin 0 -> 1335 bytes Trurl-based/Sql/Docu/ObxUI.odc | Bin 0 -> 1334 bytes Trurl-based/Sql/Docu/ObxViews.odc | Bin 0 -> 1337 bytes Trurl-based/Sql/Docu/Odbc.odc | Bin 0 -> 1388 bytes Trurl-based/Sql/Docu/Odbc3.odc | Bin 0 -> 1366 bytes Trurl-based/Sql/Docu/Sys-Map.odc | Bin 0 -> 4223 bytes Trurl-based/Sql/Mod/Browser.odc | Bin 0 -> 4833 bytes Trurl-based/Sql/Mod/Controls.odc | Bin 0 -> 36130 bytes Trurl-based/Sql/Mod/DB.odc | Bin 0 -> 31362 bytes Trurl-based/Sql/Mod/Drivers.odc | Bin 0 -> 8892 bytes Trurl-based/Sql/Mod/ObxDB.odc | Bin 0 -> 8333 bytes Trurl-based/Sql/Mod/ObxDriv.odc | Bin 0 -> 12344 bytes Trurl-based/Sql/Mod/ObxExt.odc | Bin 0 -> 4483 bytes Trurl-based/Sql/Mod/ObxGen.odc | Bin 0 -> 6572 bytes Trurl-based/Sql/Mod/ObxInit.odc | Bin 0 -> 6243 bytes Trurl-based/Sql/Mod/ObxNets.odc | Bin 0 -> 5712 bytes Trurl-based/Sql/Mod/ObxTab.odc | Bin 0 -> 4925 bytes Trurl-based/Sql/Mod/ObxUI.odc | Bin 0 -> 4621 bytes Trurl-based/Sql/Mod/ObxViews.odc | Bin 0 -> 8060 bytes Trurl-based/Sql/Rsrc/Browser.odc | Bin 0 -> 2213 bytes Trurl-based/Sql/Rsrc/Company.odc | Bin 0 -> 3302 bytes Trurl-based/Sql/Rsrc/Debug.odc | Bin 0 -> 1153 bytes Trurl-based/Sql/Rsrc/Menus.odc | Bin 0 -> 2038 bytes Trurl-based/Sql/Rsrc/Owner.odc | Bin 0 -> 2030 bytes Trurl-based/Sql/Rsrc/Strings.odc | Bin 0 -> 1437 bytes Trurl-based/Std/Mod/Api.txt | 229 ++ Trurl-based/Std/Mod/CFrames.txt | 243 ++ Trurl-based/Std/Mod/Clocks.txt | 183 + Trurl-based/Std/Mod/Cmds.txt | 1016 ++++++ Trurl-based/Std/Mod/Coder.txt | 682 ++++ Trurl-based/Std/Mod/Debug.txt | 621 ++++ Trurl-based/Std/Mod/Dialog.txt | 297 ++ Trurl-based/Std/Mod/ETHConv.txt | 223 ++ Trurl-based/Std/Mod/Folds.txt | 779 ++++ Trurl-based/Std/Mod/Headers.txt | 436 +++ Trurl-based/Std/Mod/Interpreter.txt | 234 ++ Trurl-based/Std/Mod/Links.txt | 893 +++++ Trurl-based/Std/Mod/Loader.txt | 336 ++ Trurl-based/Std/Mod/Log.txt | 373 ++ Trurl-based/Std/Mod/Logos.txt | 162 + Trurl-based/Std/Mod/Scrollers.txt | 853 +++++ Trurl-based/Std/Mod/Stamps.txt | 436 +++ Trurl-based/Std/Mod/ViewSizer.txt | 133 + Trurl-based/Std/Rsrc/Strings.odc | Bin 0 -> 2737 bytes Trurl-based/Std/Rsrc/ru/Strings.odc | Bin 0 -> 6974 bytes Trurl-based/System/Docu/Config.odc | Bin 0 -> 3336 bytes Trurl-based/System/Docu/Containers.odc | Bin 0 -> 38814 bytes Trurl-based/System/Docu/Controllers.odc | Bin 0 -> 32550 bytes Trurl-based/System/Docu/Controls.odc | Bin 0 -> 26524 bytes Trurl-based/System/Docu/Converters.odc | Bin 0 -> 7491 bytes Trurl-based/System/Docu/Dates.odc | Bin 0 -> 5337 bytes Trurl-based/System/Docu/Dialog.odc | Bin 0 -> 43683 bytes Trurl-based/System/Docu/Documents.odc | Bin 0 -> 1145 bytes Trurl-based/System/Docu/Files.odc | Bin 0 -> 31053 bytes Trurl-based/System/Docu/Fonts.odc | Bin 0 -> 14892 bytes Trurl-based/System/Docu/Init.odc | Bin 0 -> 1140 bytes Trurl-based/System/Docu/Integers.odc | Bin 0 -> 8586 bytes Trurl-based/System/Docu/Kernel.odc | Bin 0 -> 1142 bytes Trurl-based/System/Docu/Log.odc | Bin 0 -> 1127 bytes Trurl-based/System/Docu/Math.odc | Bin 0 -> 10947 bytes Trurl-based/System/Docu/Mechanisms.odc | Bin 0 -> 1146 bytes Trurl-based/System/Docu/Meta.odc | Bin 0 -> 21885 bytes Trurl-based/System/Docu/Models.odc | Bin 0 -> 16536 bytes Trurl-based/System/Docu/Ports.odc | Bin 0 -> 57435 bytes Trurl-based/System/Docu/Printers.odc | Bin 0 -> 1144 bytes Trurl-based/System/Docu/Printing.odc | Bin 0 -> 7056 bytes Trurl-based/System/Docu/Properties.odc | Bin 0 -> 29947 bytes Trurl-based/System/Docu/SMath.odc | Bin 0 -> 1503 bytes Trurl-based/System/Docu/Sequencers.odc | Bin 0 -> 1146 bytes Trurl-based/System/Docu/Services.odc | Bin 0 -> 6488 bytes Trurl-based/System/Docu/Stores.odc | Bin 0 -> 43779 bytes Trurl-based/System/Docu/Strings.odc | Bin 0 -> 14176 bytes Trurl-based/System/Docu/Sys-Map.odc | Bin 0 -> 5185 bytes Trurl-based/System/Docu/User-Man.odc | Bin 0 -> 47298 bytes Trurl-based/System/Docu/Views.odc | Bin 0 -> 49250 bytes Trurl-based/System/Docu/Windows.odc | Bin 0 -> 1143 bytes Trurl-based/System/Mod/Console.odc | Bin 0 -> 2167 bytes Trurl-based/System/Mod/Console.txt | 58 + Trurl-based/System/Mod/Containers.txt | 1381 +++++++ Trurl-based/System/Mod/Controllers.txt | 426 +++ Trurl-based/System/Mod/Controls.txt | 3163 +++++++++++++++++ Trurl-based/System/Mod/Converters.txt | 105 + Trurl-based/System/Mod/Dates.txt | 191 + Trurl-based/System/Mod/Dialog.txt | 1202 +++++++ Trurl-based/System/Mod/Documents.txt | 1286 +++++++ Trurl-based/System/Mod/Files.txt | 110 + Trurl-based/System/Mod/Fonts.txt | 59 + Trurl-based/System/Mod/In.txt | 87 + Trurl-based/System/Mod/Integers.txt | 848 +++++ Trurl-based/System/Mod/Log.txt | 144 + Trurl-based/System/Mod/Math.txt | 532 +++ Trurl-based/System/Mod/Mechanisms.txt | 129 + Trurl-based/System/Mod/Meta.txt | 1214 +++++++ Trurl-based/System/Mod/Models.txt | 258 ++ Trurl-based/System/Mod/Ports.txt | 318 ++ Trurl-based/System/Mod/Printers.txt | 63 + Trurl-based/System/Mod/Printing.txt | 226 ++ Trurl-based/System/Mod/Properties.txt | 425 +++ Trurl-based/System/Mod/SMath.txt | 392 ++ Trurl-based/System/Mod/Sequencers.txt | 86 + Trurl-based/System/Mod/Services.txt | 256 ++ Trurl-based/System/Mod/Stores.txt | 1313 +++++++ Trurl-based/System/Mod/Strings.txt | 565 +++ Trurl-based/System/Mod/Views.txt | 1347 +++++++ Trurl-based/System/Mod/Windows.txt | 855 +++++ Trurl-based/System/Rsrc/Strings.odc | Bin 0 -> 7592 bytes Trurl-based/System/Rsrc/ru/Strings.odc | Bin 0 -> 11240 bytes Trurl-based/Text/Docu/Cmds.odc | Bin 0 -> 17299 bytes Trurl-based/Text/Docu/Controllers.odc | Bin 0 -> 13437 bytes Trurl-based/Text/Docu/Dev-Man.odc | Bin 0 -> 1479 bytes Trurl-based/Text/Docu/Mappers.odc | Bin 0 -> 20206 bytes Trurl-based/Text/Docu/Models.odc | Bin 0 -> 30213 bytes Trurl-based/Text/Docu/Rulers.odc | Bin 0 -> 19955 bytes Trurl-based/Text/Docu/Setters.odc | Bin 0 -> 20616 bytes Trurl-based/Text/Docu/Sys-Map.odc | Bin 0 -> 3018 bytes Trurl-based/Text/Docu/User-Man.odc | Bin 0 -> 45776 bytes Trurl-based/Text/Docu/Views.odc | Bin 0 -> 12768 bytes Trurl-based/Text/Mod/Cmds.odc | Bin 0 -> 28777 bytes Trurl-based/Text/Mod/Cmds.txt | 860 +++++ Trurl-based/Text/Mod/Controllers.odc | Bin 0 -> 56105 bytes Trurl-based/Text/Mod/Controllers.txt | 1633 +++++++++ Trurl-based/Text/Mod/Mappers.odc | Bin 0 -> 20788 bytes Trurl-based/Text/Mod/Mappers.txt | 596 ++++ Trurl-based/Text/Mod/Models.odc | Bin 0 -> 70444 bytes Trurl-based/Text/Mod/Models.txt | 2085 +++++++++++ Trurl-based/Text/Mod/Rulers.odc | Bin 0 -> 59478 bytes Trurl-based/Text/Mod/Rulers.txt | 1676 +++++++++ Trurl-based/Text/Mod/Setters.odc | Bin 0 -> 47238 bytes Trurl-based/Text/Mod/Setters.txt | 1313 +++++++ Trurl-based/Text/Mod/Views.odc | Bin 0 -> 55895 bytes Trurl-based/Text/Mod/Views.txt | 1579 ++++++++ Trurl-based/Text/Rsrc/Cmds.odc | Bin 0 -> 2765 bytes Trurl-based/Text/Rsrc/Cmds1.odc | Bin 0 -> 1335 bytes Trurl-based/Text/Rsrc/Menus.odc | Bin 0 -> 3871 bytes Trurl-based/Text/Rsrc/Strings.odc | Bin 0 -> 2727 bytes Trurl-based/Xhtml/Docu/EntitySets.odc | Bin 0 -> 1151 bytes Trurl-based/Xhtml/Docu/Exporter.odc | Bin 0 -> 2002 bytes Trurl-based/Xhtml/Docu/StdFileWriters.odc | Bin 0 -> 1155 bytes Trurl-based/Xhtml/Docu/Sys-Map.odc | Bin 0 -> 1489 bytes Trurl-based/Xhtml/Docu/TextTableMarkers.odc | Bin 0 -> 1157 bytes Trurl-based/Xhtml/Docu/Writers.odc | Bin 0 -> 1148 bytes Trurl-based/Xhtml/Mod/EntitySets.odc | Bin 0 -> 10789 bytes Trurl-based/Xhtml/Mod/Exporter.odc | Bin 0 -> 17279 bytes Trurl-based/Xhtml/Mod/StdFileWriters.odc | Bin 0 -> 8293 bytes Trurl-based/Xhtml/Mod/TextTableMarkers.odc | Bin 0 -> 6150 bytes Trurl-based/Xhtml/Mod/Writers.odc | Bin 0 -> 3711 bytes Trurl-based/Xhtml/Rsrc/Strings.odc | Bin 0 -> 1189 bytes Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.odc | Bin 0 -> 3733 bytes Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.txt | 121 + .../_LinuxOpenBSD_/Host/Mod/TextConv.odc | Bin 0 -> 43972 bytes .../_LinuxOpenBSD_/Host/Mod/TextConv.txt | 1155 ++++++ .../Lin/Rsrc/loader/BlackBox-dl.c | 48 + .../_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox.c | 4 + .../Lin/Rsrc/loader/BlackBox1.c | 24 + .../_LinuxOpenBSD_/Lin/Rsrc/loader/dev0.c | 18 + .../_LinuxOpenBSD_/System/Mod/Config.odc | Bin 0 -> 2514 bytes .../_LinuxOpenBSD_/System/Mod/Config.txt | 27 + .../System/Mod/Kernel_so_init.odc | Bin 0 -> 2071 bytes .../System/Mod/Kernel_so_init.txt | 27 + Trurl-based/_LinuxOpenBSD_GUI/Build-Tool.odc | Bin 0 -> 1934 bytes .../Gtk2/Docu/ObjectHierarchy.odc | Bin 0 -> 8759 bytes .../_LinuxOpenBSD_GUI/Gtk2/Mod/Keysyms.odc | Bin 0 -> 35450 bytes .../_LinuxOpenBSD_GUI/Gtk2/Mod/Util.odc | Bin 0 -> 2178 bytes .../_LinuxOpenBSD_GUI/Host/Mod/CFrames.odc | Bin 0 -> 68632 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Clipboard.odc | Bin 0 -> 6010 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Cmds.odc | Bin 0 -> 17983 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Dialog.odc | Bin 0 -> 19634 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Fonts.odc | Bin 0 -> 16166 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Mechanisms.odc | Bin 0 -> 30457 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Menus.odc | Bin 0 -> 33294 bytes .../Host/Mod/PackedFiles.odc | Bin 0 -> 19279 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Ports.odc | Bin 0 -> 25962 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Registry.odc | Bin 0 -> 2133 bytes .../_LinuxOpenBSD_GUI/Host/Mod/TabFrames.odc | Bin 0 -> 16851 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Utf8.odc | Bin 0 -> 4867 bytes .../_LinuxOpenBSD_GUI/Host/Mod/Windows.odc | Bin 0 -> 42159 bytes Trurl-based/_LinuxOpenBSD_GUI/TODO.odc | Bin 0 -> 2196 bytes Trurl-based/_Linux_/BlackBox | 1 + Trurl-based/_Linux_/Host/Mod/Console.odc | Bin 0 -> 5060 bytes Trurl-based/_Linux_/Host/Mod/Console.txt | 156 + Trurl-based/_Linux_/Host/Mod/Dates.odc | Bin 0 -> 4755 bytes Trurl-based/_Linux_/Host/Mod/Dates.txt | 92 + Trurl-based/_Linux_/Host/Mod/Files.odc | Bin 0 -> 50860 bytes Trurl-based/_Linux_/Host/Mod/Files.txt | 1501 ++++++++ Trurl-based/_Linux_/Lin/Mod/Dl.odc | Bin 0 -> 3821 bytes Trurl-based/_Linux_/Lin/Mod/Dl.txt | 30 + Trurl-based/_Linux_/Lin/Mod/Iconv.odc | Bin 0 -> 1987 bytes Trurl-based/_Linux_/Lin/Mod/Iconv.txt | 22 + Trurl-based/_Linux_/Lin/Mod/Libc.odc | Bin 0 -> 24614 bytes Trurl-based/_Linux_/Lin/Mod/Libc.txt | 467 +++ Trurl-based/_Linux_/Lin/Rsrc/loader/BlackBox | Bin 0 -> 5336 bytes Trurl-based/_Linux_/Lin/Rsrc/loader/Makefile | 21 + Trurl-based/_Linux_/Lin/Rsrc/loader/dev0 | Bin 0 -> 5407 bytes Trurl-based/_Linux_/Lin/Rsrc/loader/libBB.so | 1 + Trurl-based/_Linux_/Lin/Rsrc/loader/libBB0.so | 1 + Trurl-based/_Linux_/System/Mod/Kernel.odc | Bin 0 -> 69239 bytes Trurl-based/_Linux_/System/Mod/Kernel.txt | 2074 +++++++++++ Trurl-based/_Linux_/dev0 | 1 + Trurl-based/_Linux_/libBB.so | Bin 0 -> 88188 bytes Trurl-based/_Linux_/libBB0.so | Bin 0 -> 832552 bytes Trurl-based/_Linux_GUI/Gtk2/Mod/GLib.odc | Bin 0 -> 93283 bytes Trurl-based/_Linux_GUI/Gtk2/Mod/GObject.odc | Bin 0 -> 24699 bytes Trurl-based/_Linux_GUI/Gtk2/Mod/Gdk.odc | Bin 0 -> 79807 bytes Trurl-based/_Linux_GUI/Gtk2/Mod/Gtk.odc | Bin 0 -> 42163 bytes Trurl-based/_Linux_GUI/Gtk2/Mod/Pango.odc | Bin 0 -> 42041 bytes Trurl-based/_OpenBSD_/BlackBox | 1 + Trurl-based/_OpenBSD_/Comm/Mod/V24.odc | Bin 0 -> 9471 bytes Trurl-based/_OpenBSD_/Host/Mod/Console.odc | Bin 0 -> 5199 bytes Trurl-based/_OpenBSD_/Host/Mod/Console.txt | 156 + Trurl-based/_OpenBSD_/Host/Mod/Dates.odc | Bin 0 -> 4839 bytes Trurl-based/_OpenBSD_/Host/Mod/Dates.txt | 92 + Trurl-based/_OpenBSD_/Host/Mod/Files.odc | Bin 0 -> 51038 bytes Trurl-based/_OpenBSD_/Host/Mod/Files.txt | 1501 ++++++++ Trurl-based/_OpenBSD_/Lin/Mod/Dl.txt | 35 + Trurl-based/_OpenBSD_/Lin/Mod/Iconv.txt | 22 + Trurl-based/_OpenBSD_/Lin/Mod/Ioctl.txt | 48 + Trurl-based/_OpenBSD_/Lin/Mod/Libc.txt | 785 ++++ Trurl-based/_OpenBSD_/Lin/Mod/Termios.txt | 153 + .../_OpenBSD_/Lin/Rsrc/loader/BlackBox | Bin 0 -> 8163 bytes .../_OpenBSD_/Lin/Rsrc/loader/Makefile | 33 + Trurl-based/_OpenBSD_/Lin/Rsrc/loader/dev0 | Bin 0 -> 8140 bytes .../_OpenBSD_/Lin/Rsrc/loader/libBB.so | 1 + .../_OpenBSD_/Lin/Rsrc/loader/libBB0.so | 1 + .../_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.c | 21 + .../Lin/Rsrc/loader/libdlobsdwrap.so | Bin 0 -> 8002 bytes Trurl-based/_OpenBSD_/System/Mod/Kernel.odc | Bin 0 -> 71440 bytes Trurl-based/_OpenBSD_/System/Mod/Kernel.txt | 2153 +++++++++++ Trurl-based/_OpenBSD_/dev0 | 1 + Trurl-based/_OpenBSD_/libBB.so | Bin 0 -> 89540 bytes Trurl-based/_OpenBSD_/libBB0.so | Bin 0 -> 833928 bytes Trurl-based/_OpenBSD_/libdlobsdwrap.so | 1 + Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GLib.odc | Bin 0 -> 93291 bytes Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GObject.odc | Bin 0 -> 24755 bytes Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gdk.odc | Bin 0 -> 79815 bytes Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gtk.odc | Bin 0 -> 42171 bytes Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Pango.odc | Bin 0 -> 42049 bytes Trurl-based/_Windows_/BlackBox.exe | Bin 0 -> 89088 bytes Trurl-based/_Windows_/BlackBox.exe.manifest | 18 + Trurl-based/_Windows_/Comm/Docu/TCP.odc | Bin 0 -> 3447 bytes Trurl-based/_Windows_/Comm/Docu/V24.odc | Bin 0 -> 5066 bytes Trurl-based/_Windows_/Comm/Mod/TCP.odc | Bin 0 -> 16982 bytes Trurl-based/_Windows_/Comm/Mod/V24.odc | Bin 0 -> 8948 bytes Trurl-based/_Windows_/Host/Mod/Console.odc | Bin 0 -> 3987 bytes Trurl-based/_Windows_/Host/Mod/Console.txt | 120 + Trurl-based/_Windows_/Win/Docu/Api.odc | Bin 0 -> 2659 bytes Trurl-based/_Windows_/Win/Mod/Api.odc | Bin 0 -> 717592 bytes Trurl-based/_Windows_/Win/Rsrc/Applogo.ico | Bin 0 -> 1078 bytes Trurl-based/_Windows_/Win/Rsrc/CFLogo.ico | Bin 0 -> 1078 bytes Trurl-based/_Windows_/Win/Rsrc/Copy.cur | Bin 0 -> 326 bytes Trurl-based/_Windows_/Win/Rsrc/Doclogo.ico | Bin 0 -> 1078 bytes Trurl-based/_Windows_/Win/Rsrc/DtyLogo.ico | Bin 0 -> 1078 bytes Trurl-based/_Windows_/Win/Rsrc/Hand.cur | Bin 0 -> 326 bytes Trurl-based/_Windows_/Win/Rsrc/Link.cur | Bin 0 -> 326 bytes Trurl-based/_Windows_/Win/Rsrc/Move.cur | Bin 0 -> 326 bytes Trurl-based/_Windows_/Win/Rsrc/Pick.cur | Bin 0 -> 326 bytes Trurl-based/_Windows_/Win/Rsrc/SFLogo.ico | Bin 0 -> 1078 bytes Trurl-based/_Windows_/Win/Rsrc/Stop.cur | Bin 0 -> 326 bytes Trurl-based/_Windows_/Win/Rsrc/Table.cur | Bin 0 -> 326 bytes Trurl-based/_Windows_/Win/Rsrc/folderimg.ico | Bin 0 -> 318 bytes Trurl-based/_Windows_/Win/Rsrc/leafimg.ico | Bin 0 -> 318 bytes Trurl-based/_Windows_/Win/Rsrc/openimg.ico | Bin 0 -> 318 bytes Trurl-based/_Windows_/dev0.exe | Bin 0 -> 793600 bytes .../__GUI/Comm/Docu/ObxStreamsClient.odc | Bin 0 -> 2223 bytes .../__GUI/Comm/Docu/ObxStreamsServer.odc | Bin 0 -> 2425 bytes Trurl-based/__GUI/Comm/Docu/Sys-Map.odc | Bin 0 -> 2235 bytes .../__GUI/Comm/Mod/ObxStreamsClient.odc | Bin 0 -> 6289 bytes .../__GUI/Comm/Mod/ObxStreamsServer.odc | Bin 0 -> 5774 bytes Trurl-based/__GUI/Dev/Mod/AlienTool.odc | Bin 0 -> 7443 bytes Trurl-based/__GUI/Dev/Mod/Analyzer.odc | Bin 0 -> 82061 bytes Trurl-based/__GUI/Dev/Mod/Browser.odc | Bin 0 -> 43803 bytes Trurl-based/__GUI/Dev/Mod/Cmds.odc | Bin 0 -> 11008 bytes Trurl-based/__GUI/Dev/Mod/Debug.odc | Bin 0 -> 49673 bytes Trurl-based/__GUI/Dev/Mod/Dependencies.odc | Bin 0 -> 52693 bytes Trurl-based/__GUI/Dev/Mod/HeapSpy.odc | Bin 0 -> 23322 bytes Trurl-based/__GUI/Dev/Mod/Inspector.odc | Bin 0 -> 11230 bytes Trurl-based/__GUI/Dev/Mod/LinkChk.odc | Bin 0 -> 12013 bytes Trurl-based/__GUI/Dev/Mod/MsgSpy.odc | Bin 0 -> 16546 bytes Trurl-based/__GUI/Dev/Mod/RBrowser.odc | Bin 0 -> 17127 bytes Trurl-based/__GUI/Dev/Mod/References.odc | Bin 0 -> 8123 bytes Trurl-based/__GUI/Dev/Mod/Search.odc | Bin 0 -> 12382 bytes Trurl-based/__GUI/Dev/Mod/SubTool.odc | Bin 0 -> 8905 bytes Trurl-based/__GUI/Dev/Rsrc/AnaOpt.opt | Bin 0 -> 7 bytes Trurl-based/__GUI/Dev/Rsrc/Analyzer.odc | Bin 0 -> 2623 bytes Trurl-based/__GUI/Dev/Rsrc/BrowOpt.opt | 1 + Trurl-based/__GUI/Dev/Rsrc/Browser.odc | Bin 0 -> 2053 bytes .../__GUI/Dev/Rsrc/ComInterfaceGen.odc | Bin 0 -> 2114 bytes Trurl-based/__GUI/Dev/Rsrc/Create.odc | Bin 0 -> 1925 bytes Trurl-based/__GUI/Dev/Rsrc/HeapSpy.odc | Bin 0 -> 1824 bytes Trurl-based/__GUI/Dev/Rsrc/Inspect.odc | Bin 0 -> 4521 bytes Trurl-based/__GUI/Dev/Rsrc/LinkChk.odc | Bin 0 -> 1756 bytes Trurl-based/__GUI/Dev/Rsrc/Menus.odc | Bin 0 -> 9642 bytes Trurl-based/__GUI/Dev/Rsrc/MsgSpy.odc | Bin 0 -> 2302 bytes Trurl-based/__GUI/Dev/Rsrc/New/Cmds0.odc | Bin 0 -> 2023 bytes Trurl-based/__GUI/Dev/Rsrc/New/Cmds1.odc | Bin 0 -> 2027 bytes Trurl-based/__GUI/Dev/Rsrc/New/Cmds5.odc | Bin 0 -> 1919 bytes Trurl-based/__GUI/Dev/Rsrc/New/Models5.odc | Bin 0 -> 4252 bytes Trurl-based/__GUI/Dev/Rsrc/New/Views3.odc | Bin 0 -> 4919 bytes Trurl-based/__GUI/Dev/Rsrc/New/Views4.odc | Bin 0 -> 8021 bytes Trurl-based/__GUI/Dev/Rsrc/New/Views5.odc | Bin 0 -> 7870 bytes Trurl-based/__GUI/Empty.odc | Bin 0 -> 951 bytes Trurl-based/__GUI/Form/Docu/Cmds.odc | Bin 0 -> 6732 bytes Trurl-based/__GUI/Form/Docu/Controllers.odc | Bin 0 -> 5079 bytes Trurl-based/__GUI/Form/Docu/Dev-Man.odc | Bin 0 -> 1360 bytes Trurl-based/__GUI/Form/Docu/Gen.odc | Bin 0 -> 3359 bytes Trurl-based/__GUI/Form/Docu/Models.odc | Bin 0 -> 8868 bytes Trurl-based/__GUI/Form/Docu/Sys-Map.odc | Bin 0 -> 2394 bytes Trurl-based/__GUI/Form/Docu/User-Man.odc | Bin 0 -> 19508 bytes Trurl-based/__GUI/Form/Docu/Views.odc | Bin 0 -> 5498 bytes Trurl-based/__GUI/Form/Mod/Cmds.odc | Bin 0 -> 14962 bytes Trurl-based/__GUI/Form/Mod/Controllers.odc | Bin 0 -> 26275 bytes Trurl-based/__GUI/Form/Mod/Gen.odc | Bin 0 -> 10406 bytes Trurl-based/__GUI/Form/Mod/Models.odc | Bin 0 -> 18734 bytes Trurl-based/__GUI/Form/Mod/Views.odc | Bin 0 -> 14396 bytes Trurl-based/__GUI/Form/Rsrc/Cmds.odc | Bin 0 -> 1478 bytes Trurl-based/__GUI/Form/Rsrc/Cmds2.odc | Bin 0 -> 2049 bytes Trurl-based/__GUI/Form/Rsrc/Gen.odc | Bin 0 -> 1128 bytes Trurl-based/__GUI/Form/Rsrc/Menus.odc | Bin 0 -> 2356 bytes Trurl-based/__GUI/Form/Rsrc/Strings.odc | Bin 0 -> 1733 bytes Trurl-based/__GUI/Host/Rsrc/Imptype.odc | Bin 0 -> 1246 bytes Trurl-based/__GUI/Host/Rsrc/Prefs.odc | Bin 0 -> 2571 bytes Trurl-based/__GUI/Host/Rsrc/Printing.odc | Bin 0 -> 977 bytes Trurl-based/__GUI/Host/Rsrc/Setup.odc | Bin 0 -> 2933 bytes Trurl-based/__GUI/Host/Rsrc/Strings.odc | Bin 0 -> 2963 bytes Trurl-based/__GUI/Host/Rsrc/ru/Strings.odc | Bin 0 -> 3705 bytes Trurl-based/__GUI/Obx/Docu/Actions.odc | Bin 0 -> 2871 bytes Trurl-based/__GUI/Obx/Docu/Address0.odc | Bin 0 -> 6351 bytes Trurl-based/__GUI/Obx/Docu/Address1.odc | Bin 0 -> 3585 bytes Trurl-based/__GUI/Obx/Docu/Address2.odc | Bin 0 -> 3227 bytes Trurl-based/__GUI/Obx/Docu/Ascii.odc | Bin 0 -> 6206 bytes Trurl-based/__GUI/Obx/Docu/BB-Rules.odc | Bin 0 -> 10951 bytes Trurl-based/__GUI/Obx/Docu/BlackBox.odc | Bin 0 -> 4316 bytes Trurl-based/__GUI/Obx/Docu/Buttons.odc | Bin 0 -> 9078 bytes Trurl-based/__GUI/Obx/Docu/Calc.odc | Bin 0 -> 3996 bytes Trurl-based/__GUI/Obx/Docu/Caps.odc | Bin 0 -> 4357 bytes Trurl-based/__GUI/Obx/Docu/ContIter.odc | Bin 0 -> 3313 bytes Trurl-based/__GUI/Obx/Docu/ControlShifter.odc | Bin 0 -> 1394 bytes Trurl-based/__GUI/Obx/Docu/Controls.odc | Bin 0 -> 6555 bytes Trurl-based/__GUI/Obx/Docu/Conv.odc | Bin 0 -> 4589 bytes Trurl-based/__GUI/Obx/Docu/Count0.odc | Bin 0 -> 1386 bytes Trurl-based/__GUI/Obx/Docu/Count1.odc | Bin 0 -> 1386 bytes Trurl-based/__GUI/Obx/Docu/Ctrls.odc | Bin 0 -> 1136 bytes Trurl-based/__GUI/Obx/Docu/Cubes.odc | Bin 0 -> 3517 bytes Trurl-based/__GUI/Obx/Docu/Db.odc | Bin 0 -> 2510 bytes Trurl-based/__GUI/Obx/Docu/Dialog.odc | Bin 0 -> 1632 bytes Trurl-based/__GUI/Obx/Docu/Fact.odc | Bin 0 -> 1924 bytes Trurl-based/__GUI/Obx/Docu/FileTree.odc | Bin 0 -> 4334 bytes Trurl-based/__GUI/Obx/Docu/FldCtrls.odc | Bin 0 -> 1139 bytes Trurl-based/__GUI/Obx/Docu/Graphs.odc | Bin 0 -> 5074 bytes Trurl-based/__GUI/Obx/Docu/Hello0.odc | Bin 0 -> 6514 bytes Trurl-based/__GUI/Obx/Docu/Hello1.odc | Bin 0 -> 4211 bytes Trurl-based/__GUI/Obx/Docu/LabelLister.odc | Bin 0 -> 1391 bytes Trurl-based/__GUI/Obx/Docu/Lines.odc | Bin 0 -> 5031 bytes Trurl-based/__GUI/Obx/Docu/Links.odc | Bin 0 -> 1781 bytes Trurl-based/__GUI/Obx/Docu/Lookup0.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Lookup1.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/MMerge.odc | Bin 0 -> 6986 bytes Trurl-based/__GUI/Obx/Docu/Omosi.odc | Bin 0 -> 3286 bytes Trurl-based/__GUI/Obx/Docu/Open0.odc | Bin 0 -> 4081 bytes Trurl-based/__GUI/Obx/Docu/Open1.odc | Bin 0 -> 2491 bytes Trurl-based/__GUI/Obx/Docu/Orders.odc | Bin 0 -> 3978 bytes Trurl-based/__GUI/Obx/Docu/PDBRep0.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/PDBRep1.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/PDBRep2.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/PDBRep3.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/PDBRep4.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/ParCmd.odc | Bin 0 -> 2490 bytes Trurl-based/__GUI/Obx/Docu/Patterns.odc | Bin 0 -> 3409 bytes Trurl-based/__GUI/Obx/Docu/PhoneDB.odc | Bin 0 -> 2985 bytes Trurl-based/__GUI/Obx/Docu/PhoneUI.odc | Bin 0 -> 1388 bytes Trurl-based/__GUI/Obx/Docu/PhoneUI1.odc | Bin 0 -> 1389 bytes Trurl-based/__GUI/Obx/Docu/Pi.odc | Bin 0 -> 3871 bytes Trurl-based/__GUI/Obx/Docu/Random.odc | Bin 0 -> 1181 bytes Trurl-based/__GUI/Obx/Docu/RatCalc.odc | Bin 0 -> 3330 bytes Trurl-based/__GUI/Obx/Docu/Sample.odc | Bin 0 -> 1382 bytes Trurl-based/__GUI/Obx/Docu/Scroll.odc | Bin 0 -> 7409 bytes Trurl-based/__GUI/Obx/Docu/Stores.odc | Bin 0 -> 1137 bytes Trurl-based/__GUI/Obx/Docu/Sys-Map.odc | Bin 0 -> 17656 bytes Trurl-based/__GUI/Obx/Docu/TabViews.odc | Bin 0 -> 3015 bytes Trurl-based/__GUI/Obx/Docu/Tabs.odc | Bin 0 -> 2335 bytes Trurl-based/__GUI/Obx/Docu/Tickers.odc | Bin 0 -> 4337 bytes Trurl-based/__GUI/Obx/Docu/Trap.odc | Bin 0 -> 1609 bytes Trurl-based/__GUI/Obx/Docu/Twins.odc | Bin 0 -> 6240 bytes Trurl-based/__GUI/Obx/Docu/UnitConv.odc | Bin 0 -> 2728 bytes Trurl-based/__GUI/Obx/Docu/Views0.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Views1.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Views10.odc | Bin 0 -> 1388 bytes Trurl-based/__GUI/Obx/Docu/Views11.odc | Bin 0 -> 1388 bytes Trurl-based/__GUI/Obx/Docu/Views12.odc | Bin 0 -> 1388 bytes Trurl-based/__GUI/Obx/Docu/Views13.odc | Bin 0 -> 1388 bytes Trurl-based/__GUI/Obx/Docu/Views14.odc | Bin 0 -> 1388 bytes Trurl-based/__GUI/Obx/Docu/Views2.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Views3.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Views4.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Views5.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Views6.odc | Bin 0 -> 1387 bytes Trurl-based/__GUI/Obx/Docu/Wrappers.odc | Bin 0 -> 4002 bytes Trurl-based/__GUI/Obx/Mod/Actions.odc | Bin 0 -> 4080 bytes Trurl-based/__GUI/Obx/Mod/Address0.odc | Bin 0 -> 3115 bytes Trurl-based/__GUI/Obx/Mod/Address1.odc | Bin 0 -> 3800 bytes Trurl-based/__GUI/Obx/Mod/Address2.odc | Bin 0 -> 3935 bytes Trurl-based/__GUI/Obx/Mod/Ascii.odc | Bin 0 -> 5940 bytes Trurl-based/__GUI/Obx/Mod/BlackBox.odc | Bin 0 -> 15434 bytes Trurl-based/__GUI/Obx/Mod/Buttons.odc | Bin 0 -> 8468 bytes Trurl-based/__GUI/Obx/Mod/Calc.odc | Bin 0 -> 8909 bytes Trurl-based/__GUI/Obx/Mod/Caps.odc | Bin 0 -> 3583 bytes Trurl-based/__GUI/Obx/Mod/ContIter.odc | Bin 0 -> 3197 bytes Trurl-based/__GUI/Obx/Mod/ControlShifter.odc | Bin 0 -> 3189 bytes Trurl-based/__GUI/Obx/Mod/Controls.odc | Bin 0 -> 6722 bytes Trurl-based/__GUI/Obx/Mod/Conv.odc | Bin 0 -> 3966 bytes Trurl-based/__GUI/Obx/Mod/Count0.odc | Bin 0 -> 4082 bytes Trurl-based/__GUI/Obx/Mod/Count1.odc | Bin 0 -> 4149 bytes Trurl-based/__GUI/Obx/Mod/Ctrls.odc | Bin 0 -> 7292 bytes Trurl-based/__GUI/Obx/Mod/Cubes.odc | Bin 0 -> 13229 bytes Trurl-based/__GUI/Obx/Mod/Db.odc | Bin 0 -> 5185 bytes Trurl-based/__GUI/Obx/Mod/Dialog.odc | Bin 0 -> 5426 bytes Trurl-based/__GUI/Obx/Mod/Fact.odc | Bin 0 -> 4771 bytes Trurl-based/__GUI/Obx/Mod/FileTree.odc | Bin 0 -> 5424 bytes Trurl-based/__GUI/Obx/Mod/FldCtrls.odc | Bin 0 -> 9464 bytes Trurl-based/__GUI/Obx/Mod/Graphs.odc | Bin 0 -> 8014 bytes Trurl-based/__GUI/Obx/Mod/Hello1.odc | Bin 0 -> 3429 bytes Trurl-based/__GUI/Obx/Mod/LabelLister.odc | Bin 0 -> 3171 bytes Trurl-based/__GUI/Obx/Mod/Lines.odc | Bin 0 -> 8351 bytes Trurl-based/__GUI/Obx/Mod/Links.odc | Bin 0 -> 6260 bytes Trurl-based/__GUI/Obx/Mod/Lookup0.odc | Bin 0 -> 3757 bytes Trurl-based/__GUI/Obx/Mod/Lookup1.odc | Bin 0 -> 3895 bytes Trurl-based/__GUI/Obx/Mod/MMerge.odc | Bin 0 -> 7779 bytes Trurl-based/__GUI/Obx/Mod/Omosi.odc | Bin 0 -> 12805 bytes Trurl-based/__GUI/Obx/Mod/Open0.odc | Bin 0 -> 3572 bytes Trurl-based/__GUI/Obx/Mod/Open1.odc | Bin 0 -> 3354 bytes Trurl-based/__GUI/Obx/Mod/Orders.odc | Bin 0 -> 11364 bytes Trurl-based/__GUI/Obx/Mod/PDBRep0.odc | Bin 0 -> 3624 bytes Trurl-based/__GUI/Obx/Mod/PDBRep1.odc | Bin 0 -> 4023 bytes Trurl-based/__GUI/Obx/Mod/PDBRep2.odc | Bin 0 -> 4129 bytes Trurl-based/__GUI/Obx/Mod/PDBRep3.odc | Bin 0 -> 4735 bytes Trurl-based/__GUI/Obx/Mod/PDBRep4.odc | Bin 0 -> 3949 bytes Trurl-based/__GUI/Obx/Mod/ParCmd.odc | Bin 0 -> 3739 bytes Trurl-based/__GUI/Obx/Mod/Patterns.odc | Bin 0 -> 4242 bytes Trurl-based/__GUI/Obx/Mod/PhoneDB.odc | Bin 0 -> 4568 bytes Trurl-based/__GUI/Obx/Mod/PhoneUI.odc | Bin 0 -> 3787 bytes Trurl-based/__GUI/Obx/Mod/PhoneUI1.odc | Bin 0 -> 3165 bytes Trurl-based/__GUI/Obx/Mod/Ratcalc.odc | Bin 0 -> 12852 bytes Trurl-based/__GUI/Obx/Mod/Sample.odc | Bin 0 -> 3467 bytes Trurl-based/__GUI/Obx/Mod/Scroll.odc | Bin 0 -> 7356 bytes Trurl-based/__GUI/Obx/Mod/Stores.odc | Bin 0 -> 16776 bytes Trurl-based/__GUI/Obx/Mod/TabViews.odc | Bin 0 -> 3871 bytes Trurl-based/__GUI/Obx/Mod/Tabs.odc | Bin 0 -> 4566 bytes Trurl-based/__GUI/Obx/Mod/Tickers.odc | Bin 0 -> 6671 bytes Trurl-based/__GUI/Obx/Mod/Twins.odc | Bin 0 -> 10683 bytes Trurl-based/__GUI/Obx/Mod/UnitConv.odc | Bin 0 -> 3977 bytes Trurl-based/__GUI/Obx/Mod/Views0.odc | Bin 0 -> 2972 bytes Trurl-based/__GUI/Obx/Mod/Views1.odc | Bin 0 -> 3347 bytes Trurl-based/__GUI/Obx/Mod/Views10.odc | Bin 0 -> 4015 bytes Trurl-based/__GUI/Obx/Mod/Views11.odc | Bin 0 -> 4783 bytes Trurl-based/__GUI/Obx/Mod/Views12.odc | Bin 0 -> 5894 bytes Trurl-based/__GUI/Obx/Mod/Views13.odc | Bin 0 -> 6515 bytes Trurl-based/__GUI/Obx/Mod/Views14.odc | Bin 0 -> 8836 bytes Trurl-based/__GUI/Obx/Mod/Views2.odc | Bin 0 -> 3628 bytes Trurl-based/__GUI/Obx/Mod/Views3.odc | Bin 0 -> 3706 bytes Trurl-based/__GUI/Obx/Mod/Views4.odc | Bin 0 -> 4107 bytes Trurl-based/__GUI/Obx/Mod/Views5.odc | Bin 0 -> 5025 bytes Trurl-based/__GUI/Obx/Mod/Views6.odc | Bin 0 -> 5572 bytes Trurl-based/__GUI/Obx/Mod/Wrappers.odc | Bin 0 -> 6210 bytes Trurl-based/__GUI/Obx/Rsrc/Actions.odc | Bin 0 -> 1246 bytes Trurl-based/__GUI/Obx/Rsrc/BlackBox.odc | Bin 0 -> 1288 bytes Trurl-based/__GUI/Obx/Rsrc/Controls.odc | Bin 0 -> 2375 bytes Trurl-based/__GUI/Obx/Rsrc/Cubes.odc | Bin 0 -> 1657 bytes Trurl-based/__GUI/Obx/Rsrc/Dialog.odc | Bin 0 -> 2279 bytes Trurl-based/__GUI/Obx/Rsrc/FileTree.odc | Bin 0 -> 1510 bytes Trurl-based/__GUI/Obx/Rsrc/Menus.odc | Bin 0 -> 5332 bytes Trurl-based/__GUI/Obx/Rsrc/Orders.odc | Bin 0 -> 6609 bytes Trurl-based/__GUI/Obx/Rsrc/Orders1.odc | Bin 0 -> 965 bytes Trurl-based/__GUI/Obx/Rsrc/PhoneUI.odc | Bin 0 -> 1703 bytes Trurl-based/__GUI/Obx/Rsrc/PhoneUI1.odc | Bin 0 -> 1279 bytes Trurl-based/__GUI/Obx/Rsrc/Strings.odc | Bin 0 -> 1477 bytes Trurl-based/__GUI/Obx/Samples/MMData.odc | Bin 0 -> 1489 bytes Trurl-based/__GUI/Obx/Samples/MMTmpl.odc | Bin 0 -> 1260 bytes Trurl-based/__GUI/Obx/Samples/OData.dat | Bin 0 -> 622 bytes Trurl-based/__GUI/Obx/Samples/Omosi1.odc | Bin 0 -> 881 bytes Trurl-based/__GUI/Obx/Samples/Omosi2.odc | Bin 0 -> 881 bytes Trurl-based/__GUI/Obx/Samples/Omosi3.odc | Bin 0 -> 881 bytes Trurl-based/__GUI/Obx/Samples/Omosi4.odc | Bin 0 -> 881 bytes Trurl-based/__GUI/Obx/Samples/Omosi5.odc | Bin 0 -> 881 bytes Trurl-based/__GUI/Obx/Samples/Omosi6.odc | Bin 0 -> 881 bytes Trurl-based/__GUI/Std/Docu/Api.odc | Bin 0 -> 5940 bytes Trurl-based/__GUI/Std/Docu/CFrames.odc | Bin 0 -> 1355 bytes Trurl-based/__GUI/Std/Docu/Clocks.odc | Bin 0 -> 1534 bytes Trurl-based/__GUI/Std/Docu/Cmds.odc | Bin 0 -> 17213 bytes Trurl-based/__GUI/Std/Docu/Coder.odc | Bin 0 -> 7829 bytes Trurl-based/__GUI/Std/Docu/Debug.odc | Bin 0 -> 1752 bytes Trurl-based/__GUI/Std/Docu/Dialog.odc | Bin 0 -> 1354 bytes Trurl-based/__GUI/Std/Docu/ETHConv.odc | Bin 0 -> 2154 bytes Trurl-based/__GUI/Std/Docu/Folds.odc | Bin 0 -> 213272 bytes Trurl-based/__GUI/Std/Docu/Headers.odc | Bin 0 -> 6591 bytes Trurl-based/__GUI/Std/Docu/Interpreter.odc | Bin 0 -> 2440 bytes Trurl-based/__GUI/Std/Docu/Links.odc | Bin 0 -> 8585 bytes Trurl-based/__GUI/Std/Docu/Loader.odc | Bin 0 -> 1145 bytes Trurl-based/__GUI/Std/Docu/Log.odc | Bin 0 -> 8749 bytes Trurl-based/__GUI/Std/Docu/Logos.odc | Bin 0 -> 1325 bytes Trurl-based/__GUI/Std/Docu/MenuTool.odc | Bin 0 -> 2939 bytes Trurl-based/__GUI/Std/Docu/Scrollers.odc | Bin 0 -> 5073 bytes Trurl-based/__GUI/Std/Docu/Stamps.odc | Bin 0 -> 1656 bytes Trurl-based/__GUI/Std/Docu/Sys-Map.odc | Bin 0 -> 3884 bytes Trurl-based/__GUI/Std/Docu/TabViews.odc | Bin 0 -> 207056 bytes Trurl-based/__GUI/Std/Docu/Tables.odc | Bin 0 -> 10155 bytes Trurl-based/__GUI/Std/Docu/ViewSizer.odc | Bin 0 -> 2969 bytes Trurl-based/__GUI/Std/Mod/MenuTool.odc | Bin 0 -> 12949 bytes Trurl-based/__GUI/Std/Mod/TabViews.odc | Bin 0 -> 26337 bytes Trurl-based/__GUI/Std/Mod/Tables.odc | Bin 0 -> 48721 bytes Trurl-based/__GUI/Std/Rsrc/Cmds.odc | Bin 0 -> 1178 bytes Trurl-based/__GUI/Std/Rsrc/Cmds1.odc | Bin 0 -> 2394 bytes Trurl-based/__GUI/Std/Rsrc/Coder.odc | Bin 0 -> 1798 bytes Trurl-based/__GUI/Std/Rsrc/Folds.odc | Bin 0 -> 2551 bytes Trurl-based/__GUI/Std/Rsrc/Headers.odc | Bin 0 -> 4151 bytes Trurl-based/__GUI/Std/Rsrc/Links.odc | Bin 0 -> 1850 bytes Trurl-based/__GUI/Std/Rsrc/Scroller.odc | Bin 0 -> 3679 bytes Trurl-based/__GUI/Std/Rsrc/Stamps.odc | Bin 0 -> 1214 bytes Trurl-based/__GUI/Std/Rsrc/TabViews.odc | Bin 0 -> 2786 bytes Trurl-based/__GUI/Std/Rsrc/Tables.odc | Bin 0 -> 1979 bytes Trurl-based/__GUI/Std/Rsrc/ViewSizer.odc | Bin 0 -> 2775 bytes Trurl-based/__GUI/System/Docu/In.odc | Bin 0 -> 3919 bytes Trurl-based/__GUI/System/Docu/Out.odc | Bin 0 -> 2364 bytes Trurl-based/__GUI/System/Mod/In.odc | Bin 0 -> 4293 bytes Trurl-based/__GUI/System/Mod/Init.odc | Bin 0 -> 3202 bytes Trurl-based/__GUI/System/Mod/Out.odc | Bin 0 -> 3897 bytes Trurl-based/__GUI/System/Rsrc/About.odc | Bin 0 -> 95535 bytes Trurl-based/__GUI/System/Rsrc/Menus.odc | Bin 0 -> 7346 bytes Trurl-based/__GUI/Tour.odc | Bin 0 -> 49379 bytes Trurl-based/__Interp/Host/Mod/Dialog.txt | 52 + Trurl-based/__Interp/Host/Mod/Fonts.txt | 75 + Trurl-based/__Interp/Host/Mod/Windows.txt | 143 + Trurl-based/__Interp/System/Mod/Init.txt | 28 + Trurl-based/build | 131 + Trurl-based/build-dev0 | 43 + Trurl-based/build-gui | 32 + Trurl-based/clean | 4 + Trurl-based/run-BlackBox | 12 + Trurl-based/run-dev0 | 4 + Trurl-based/switch-target | 64 + 633 files changed, 79444 insertions(+) create mode 100644 Trurl-based/Cons/Mod/Compiler.odc create mode 100644 Trurl-based/Cons/Mod/Interp.txt create mode 100644 Trurl-based/Cons/Mod/Log.txt create mode 100644 Trurl-based/Dev/Docu/ElfLinker.odc create mode 100644 Trurl-based/Dev/Mod/CPB.txt create mode 100644 Trurl-based/Dev/Mod/CPC486.txt create mode 100644 Trurl-based/Dev/Mod/CPE.txt create mode 100644 Trurl-based/Dev/Mod/CPH.txt create mode 100644 Trurl-based/Dev/Mod/CPL486.txt create mode 100644 Trurl-based/Dev/Mod/CPM.txt create mode 100644 Trurl-based/Dev/Mod/CPP.txt create mode 100644 Trurl-based/Dev/Mod/CPS.txt create mode 100644 Trurl-based/Dev/Mod/CPT.txt create mode 100644 Trurl-based/Dev/Mod/CPV486.txt create mode 100644 Trurl-based/Dev/Mod/Commanders.txt create mode 100644 Trurl-based/Dev/Mod/Compiler.txt create mode 100644 Trurl-based/Dev/Mod/ElfLinker16.odc create mode 100644 Trurl-based/Dev/Mod/Linker.odc create mode 100644 Trurl-based/Dev/Mod/Markers.txt create mode 100644 Trurl-based/Dev/Mod/Selectors.txt create mode 100644 Trurl-based/Dev/Rsrc/Errors.odc create mode 100644 Trurl-based/Dev/Rsrc/Strings.odc create mode 100644 Trurl-based/Dev/Rsrc/ru/Strings.odc create mode 100644 Trurl-based/Dev/Spec/ObjFile.odc create mode 100644 Trurl-based/Dev/Spec/PackedFiles.odc create mode 100644 Trurl-based/Dev/Spec/StoresFileFormat.odc create mode 100644 Trurl-based/Dev/Spec/SymFile.odc create mode 100644 Trurl-based/Dev0/Mod/CPB.odc create mode 100644 Trurl-based/Dev0/Mod/CPB.txt create mode 100644 Trurl-based/Dev0/Mod/CPC486.odc create mode 100644 Trurl-based/Dev0/Mod/CPC486.txt create mode 100644 Trurl-based/Dev0/Mod/CPE.odc create mode 100644 Trurl-based/Dev0/Mod/CPE.txt create mode 100644 Trurl-based/Dev0/Mod/CPH.odc create mode 100644 Trurl-based/Dev0/Mod/CPH.txt create mode 100644 Trurl-based/Dev0/Mod/CPL486.odc create mode 100644 Trurl-based/Dev0/Mod/CPL486.txt create mode 100644 Trurl-based/Dev0/Mod/CPM.odc create mode 100644 Trurl-based/Dev0/Mod/CPM.txt create mode 100644 Trurl-based/Dev0/Mod/CPP.odc create mode 100644 Trurl-based/Dev0/Mod/CPP.txt create mode 100644 Trurl-based/Dev0/Mod/CPS.odc create mode 100644 Trurl-based/Dev0/Mod/CPS.txt create mode 100644 Trurl-based/Dev0/Mod/CPT.odc create mode 100644 Trurl-based/Dev0/Mod/CPT.txt create mode 100644 Trurl-based/Dev0/Mod/CPV486.odc create mode 100644 Trurl-based/Dev0/Mod/CPV486.txt create mode 100644 Trurl-based/Dev0/Mod/Compiler.odc create mode 100644 Trurl-based/Dev0/Mod/Compiler.txt create mode 100644 Trurl-based/Dev0/Mod/ElfLinker16.odc create mode 100644 Trurl-based/Dev0/Mod/ElfLinker16.txt create mode 100644 Trurl-based/Dev0/Mod/Interp.txt create mode 100644 Trurl-based/Dev0/Mod/Linker.odc create mode 100644 Trurl-based/Dev0/Mod/Linker.txt create mode 100644 Trurl-based/Dev0/Views.txt create mode 100644 Trurl-based/Docu/BB-Chars.odc create mode 100644 Trurl-based/Docu/BB-Docu.odc create mode 100644 Trurl-based/Docu/BB-License.odc create mode 100644 Trurl-based/Docu/BB-Licensing-Policy.odc create mode 100644 Trurl-based/Docu/BB-Open-Source-License.odc create mode 100644 Trurl-based/Docu/BB-Road.odc create mode 100644 Trurl-based/Docu/BB-Rules.odc create mode 100644 Trurl-based/Docu/CP-Lang.odc create mode 100644 Trurl-based/Docu/CP-New.odc create mode 100644 Trurl-based/Docu/Contributors.odc create mode 100644 Trurl-based/Docu/Help.odc create mode 100644 Trurl-based/Docu/OpenBUGS-License.odc create mode 100644 Trurl-based/Docu/Tut-1.odc create mode 100644 Trurl-based/Docu/Tut-2.odc create mode 100644 Trurl-based/Docu/Tut-3.odc create mode 100644 Trurl-based/Docu/Tut-4.odc create mode 100644 Trurl-based/Docu/Tut-5.odc create mode 100644 Trurl-based/Docu/Tut-6.odc create mode 100644 Trurl-based/Docu/Tut-A.odc create mode 100644 Trurl-based/Docu/Tut-B.odc create mode 100644 Trurl-based/Docu/Tut-TOC.odc create mode 100644 Trurl-based/Docu/Tut-Tot.odc create mode 100644 Trurl-based/Obx/Mod/Hello0.odc create mode 100644 Trurl-based/Obx/Mod/Pi.odc create mode 100644 Trurl-based/Obx/Mod/Random.odc create mode 100644 Trurl-based/Obx/Mod/Trap.odc create mode 100644 Trurl-based/Sql/Database/Companies create mode 100644 Trurl-based/Sql/Database/Ownership create mode 100644 Trurl-based/Sql/Database/schema.ini create mode 100644 Trurl-based/Sql/Docu/Browser.odc create mode 100644 Trurl-based/Sql/Docu/Controls.odc create mode 100644 Trurl-based/Sql/Docu/Db.odc create mode 100644 Trurl-based/Sql/Docu/Dev-Man.odc create mode 100644 Trurl-based/Sql/Docu/Drivers.odc create mode 100644 Trurl-based/Sql/Docu/ObxDB.odc create mode 100644 Trurl-based/Sql/Docu/ObxDriv.odc create mode 100644 Trurl-based/Sql/Docu/ObxExt.odc create mode 100644 Trurl-based/Sql/Docu/ObxGen.odc create mode 100644 Trurl-based/Sql/Docu/ObxInit.odc create mode 100644 Trurl-based/Sql/Docu/ObxNets.odc create mode 100644 Trurl-based/Sql/Docu/ObxTab.odc create mode 100644 Trurl-based/Sql/Docu/ObxUI.odc create mode 100644 Trurl-based/Sql/Docu/ObxViews.odc create mode 100644 Trurl-based/Sql/Docu/Odbc.odc create mode 100644 Trurl-based/Sql/Docu/Odbc3.odc create mode 100644 Trurl-based/Sql/Docu/Sys-Map.odc create mode 100644 Trurl-based/Sql/Mod/Browser.odc create mode 100644 Trurl-based/Sql/Mod/Controls.odc create mode 100644 Trurl-based/Sql/Mod/DB.odc create mode 100644 Trurl-based/Sql/Mod/Drivers.odc create mode 100644 Trurl-based/Sql/Mod/ObxDB.odc create mode 100644 Trurl-based/Sql/Mod/ObxDriv.odc create mode 100644 Trurl-based/Sql/Mod/ObxExt.odc create mode 100644 Trurl-based/Sql/Mod/ObxGen.odc create mode 100644 Trurl-based/Sql/Mod/ObxInit.odc create mode 100644 Trurl-based/Sql/Mod/ObxNets.odc create mode 100644 Trurl-based/Sql/Mod/ObxTab.odc create mode 100644 Trurl-based/Sql/Mod/ObxUI.odc create mode 100644 Trurl-based/Sql/Mod/ObxViews.odc create mode 100644 Trurl-based/Sql/Rsrc/Browser.odc create mode 100644 Trurl-based/Sql/Rsrc/Company.odc create mode 100644 Trurl-based/Sql/Rsrc/Debug.odc create mode 100644 Trurl-based/Sql/Rsrc/Menus.odc create mode 100644 Trurl-based/Sql/Rsrc/Owner.odc create mode 100644 Trurl-based/Sql/Rsrc/Strings.odc create mode 100644 Trurl-based/Std/Mod/Api.txt create mode 100644 Trurl-based/Std/Mod/CFrames.txt create mode 100644 Trurl-based/Std/Mod/Clocks.txt create mode 100644 Trurl-based/Std/Mod/Cmds.txt create mode 100644 Trurl-based/Std/Mod/Coder.txt create mode 100644 Trurl-based/Std/Mod/Debug.txt create mode 100644 Trurl-based/Std/Mod/Dialog.txt create mode 100644 Trurl-based/Std/Mod/ETHConv.txt create mode 100644 Trurl-based/Std/Mod/Folds.txt create mode 100644 Trurl-based/Std/Mod/Headers.txt create mode 100644 Trurl-based/Std/Mod/Interpreter.txt create mode 100644 Trurl-based/Std/Mod/Links.txt create mode 100644 Trurl-based/Std/Mod/Loader.txt create mode 100644 Trurl-based/Std/Mod/Log.txt create mode 100644 Trurl-based/Std/Mod/Logos.txt create mode 100644 Trurl-based/Std/Mod/Scrollers.txt create mode 100644 Trurl-based/Std/Mod/Stamps.txt create mode 100644 Trurl-based/Std/Mod/ViewSizer.txt create mode 100644 Trurl-based/Std/Rsrc/Strings.odc create mode 100644 Trurl-based/Std/Rsrc/ru/Strings.odc create mode 100644 Trurl-based/System/Docu/Config.odc create mode 100644 Trurl-based/System/Docu/Containers.odc create mode 100644 Trurl-based/System/Docu/Controllers.odc create mode 100644 Trurl-based/System/Docu/Controls.odc create mode 100644 Trurl-based/System/Docu/Converters.odc create mode 100644 Trurl-based/System/Docu/Dates.odc create mode 100644 Trurl-based/System/Docu/Dialog.odc create mode 100644 Trurl-based/System/Docu/Documents.odc create mode 100644 Trurl-based/System/Docu/Files.odc create mode 100644 Trurl-based/System/Docu/Fonts.odc create mode 100644 Trurl-based/System/Docu/Init.odc create mode 100644 Trurl-based/System/Docu/Integers.odc create mode 100644 Trurl-based/System/Docu/Kernel.odc create mode 100644 Trurl-based/System/Docu/Log.odc create mode 100644 Trurl-based/System/Docu/Math.odc create mode 100644 Trurl-based/System/Docu/Mechanisms.odc create mode 100644 Trurl-based/System/Docu/Meta.odc create mode 100644 Trurl-based/System/Docu/Models.odc create mode 100644 Trurl-based/System/Docu/Ports.odc create mode 100644 Trurl-based/System/Docu/Printers.odc create mode 100644 Trurl-based/System/Docu/Printing.odc create mode 100644 Trurl-based/System/Docu/Properties.odc create mode 100644 Trurl-based/System/Docu/SMath.odc create mode 100644 Trurl-based/System/Docu/Sequencers.odc create mode 100644 Trurl-based/System/Docu/Services.odc create mode 100644 Trurl-based/System/Docu/Stores.odc create mode 100644 Trurl-based/System/Docu/Strings.odc create mode 100644 Trurl-based/System/Docu/Sys-Map.odc create mode 100644 Trurl-based/System/Docu/User-Man.odc create mode 100644 Trurl-based/System/Docu/Views.odc create mode 100644 Trurl-based/System/Docu/Windows.odc create mode 100644 Trurl-based/System/Mod/Console.odc create mode 100644 Trurl-based/System/Mod/Console.txt create mode 100644 Trurl-based/System/Mod/Containers.txt create mode 100644 Trurl-based/System/Mod/Controllers.txt create mode 100644 Trurl-based/System/Mod/Controls.txt create mode 100644 Trurl-based/System/Mod/Converters.txt create mode 100644 Trurl-based/System/Mod/Dates.txt create mode 100644 Trurl-based/System/Mod/Dialog.txt create mode 100644 Trurl-based/System/Mod/Documents.txt create mode 100644 Trurl-based/System/Mod/Files.txt create mode 100644 Trurl-based/System/Mod/Fonts.txt create mode 100644 Trurl-based/System/Mod/In.txt create mode 100644 Trurl-based/System/Mod/Integers.txt create mode 100644 Trurl-based/System/Mod/Log.txt create mode 100644 Trurl-based/System/Mod/Math.txt create mode 100644 Trurl-based/System/Mod/Mechanisms.txt create mode 100644 Trurl-based/System/Mod/Meta.txt create mode 100644 Trurl-based/System/Mod/Models.txt create mode 100644 Trurl-based/System/Mod/Ports.txt create mode 100644 Trurl-based/System/Mod/Printers.txt create mode 100644 Trurl-based/System/Mod/Printing.txt create mode 100644 Trurl-based/System/Mod/Properties.txt create mode 100644 Trurl-based/System/Mod/SMath.txt create mode 100644 Trurl-based/System/Mod/Sequencers.txt create mode 100644 Trurl-based/System/Mod/Services.txt create mode 100644 Trurl-based/System/Mod/Stores.txt create mode 100644 Trurl-based/System/Mod/Strings.txt create mode 100644 Trurl-based/System/Mod/Views.txt create mode 100644 Trurl-based/System/Mod/Windows.txt create mode 100644 Trurl-based/System/Rsrc/Strings.odc create mode 100644 Trurl-based/System/Rsrc/ru/Strings.odc create mode 100644 Trurl-based/Text/Docu/Cmds.odc create mode 100644 Trurl-based/Text/Docu/Controllers.odc create mode 100644 Trurl-based/Text/Docu/Dev-Man.odc create mode 100644 Trurl-based/Text/Docu/Mappers.odc create mode 100644 Trurl-based/Text/Docu/Models.odc create mode 100644 Trurl-based/Text/Docu/Rulers.odc create mode 100644 Trurl-based/Text/Docu/Setters.odc create mode 100644 Trurl-based/Text/Docu/Sys-Map.odc create mode 100644 Trurl-based/Text/Docu/User-Man.odc create mode 100644 Trurl-based/Text/Docu/Views.odc create mode 100644 Trurl-based/Text/Mod/Cmds.odc create mode 100644 Trurl-based/Text/Mod/Cmds.txt create mode 100644 Trurl-based/Text/Mod/Controllers.odc create mode 100644 Trurl-based/Text/Mod/Controllers.txt create mode 100644 Trurl-based/Text/Mod/Mappers.odc create mode 100644 Trurl-based/Text/Mod/Mappers.txt create mode 100644 Trurl-based/Text/Mod/Models.odc create mode 100644 Trurl-based/Text/Mod/Models.txt create mode 100644 Trurl-based/Text/Mod/Rulers.odc create mode 100644 Trurl-based/Text/Mod/Rulers.txt create mode 100644 Trurl-based/Text/Mod/Setters.odc create mode 100644 Trurl-based/Text/Mod/Setters.txt create mode 100644 Trurl-based/Text/Mod/Views.odc create mode 100644 Trurl-based/Text/Mod/Views.txt create mode 100644 Trurl-based/Text/Rsrc/Cmds.odc create mode 100644 Trurl-based/Text/Rsrc/Cmds1.odc create mode 100644 Trurl-based/Text/Rsrc/Menus.odc create mode 100644 Trurl-based/Text/Rsrc/Strings.odc create mode 100644 Trurl-based/Xhtml/Docu/EntitySets.odc create mode 100644 Trurl-based/Xhtml/Docu/Exporter.odc create mode 100644 Trurl-based/Xhtml/Docu/StdFileWriters.odc create mode 100644 Trurl-based/Xhtml/Docu/Sys-Map.odc create mode 100644 Trurl-based/Xhtml/Docu/TextTableMarkers.odc create mode 100644 Trurl-based/Xhtml/Docu/Writers.odc create mode 100644 Trurl-based/Xhtml/Mod/EntitySets.odc create mode 100644 Trurl-based/Xhtml/Mod/Exporter.odc create mode 100644 Trurl-based/Xhtml/Mod/StdFileWriters.odc create mode 100644 Trurl-based/Xhtml/Mod/TextTableMarkers.odc create mode 100644 Trurl-based/Xhtml/Mod/Writers.odc create mode 100644 Trurl-based/Xhtml/Rsrc/Strings.odc create mode 100644 Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.odc create mode 100644 Trurl-based/_LinuxOpenBSD_/Host/Mod/Lang.txt create mode 100644 Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.odc create mode 100644 Trurl-based/_LinuxOpenBSD_/Host/Mod/TextConv.txt create mode 100644 Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox-dl.c create mode 100644 Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox.c create mode 100644 Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/BlackBox1.c create mode 100644 Trurl-based/_LinuxOpenBSD_/Lin/Rsrc/loader/dev0.c create mode 100644 Trurl-based/_LinuxOpenBSD_/System/Mod/Config.odc create mode 100644 Trurl-based/_LinuxOpenBSD_/System/Mod/Config.txt create mode 100644 Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.odc create mode 100644 Trurl-based/_LinuxOpenBSD_/System/Mod/Kernel_so_init.txt create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Build-Tool.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Docu/ObjectHierarchy.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Keysyms.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Gtk2/Mod/Util.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/CFrames.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Clipboard.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Cmds.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Dialog.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Fonts.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Mechanisms.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Menus.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/PackedFiles.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Ports.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Registry.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/TabFrames.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Utf8.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/Host/Mod/Windows.odc create mode 100644 Trurl-based/_LinuxOpenBSD_GUI/TODO.odc create mode 120000 Trurl-based/_Linux_/BlackBox create mode 100644 Trurl-based/_Linux_/Host/Mod/Console.odc create mode 100644 Trurl-based/_Linux_/Host/Mod/Console.txt create mode 100644 Trurl-based/_Linux_/Host/Mod/Dates.odc create mode 100644 Trurl-based/_Linux_/Host/Mod/Dates.txt create mode 100644 Trurl-based/_Linux_/Host/Mod/Files.odc create mode 100644 Trurl-based/_Linux_/Host/Mod/Files.txt create mode 100644 Trurl-based/_Linux_/Lin/Mod/Dl.odc create mode 100644 Trurl-based/_Linux_/Lin/Mod/Dl.txt create mode 100644 Trurl-based/_Linux_/Lin/Mod/Iconv.odc create mode 100644 Trurl-based/_Linux_/Lin/Mod/Iconv.txt create mode 100644 Trurl-based/_Linux_/Lin/Mod/Libc.odc create mode 100644 Trurl-based/_Linux_/Lin/Mod/Libc.txt create mode 100755 Trurl-based/_Linux_/Lin/Rsrc/loader/BlackBox create mode 100644 Trurl-based/_Linux_/Lin/Rsrc/loader/Makefile create mode 100755 Trurl-based/_Linux_/Lin/Rsrc/loader/dev0 create mode 120000 Trurl-based/_Linux_/Lin/Rsrc/loader/libBB.so create mode 120000 Trurl-based/_Linux_/Lin/Rsrc/loader/libBB0.so create mode 100644 Trurl-based/_Linux_/System/Mod/Kernel.odc create mode 100644 Trurl-based/_Linux_/System/Mod/Kernel.txt create mode 120000 Trurl-based/_Linux_/dev0 create mode 100644 Trurl-based/_Linux_/libBB.so create mode 100644 Trurl-based/_Linux_/libBB0.so create mode 100644 Trurl-based/_Linux_GUI/Gtk2/Mod/GLib.odc create mode 100644 Trurl-based/_Linux_GUI/Gtk2/Mod/GObject.odc create mode 100644 Trurl-based/_Linux_GUI/Gtk2/Mod/Gdk.odc create mode 100644 Trurl-based/_Linux_GUI/Gtk2/Mod/Gtk.odc create mode 100644 Trurl-based/_Linux_GUI/Gtk2/Mod/Pango.odc create mode 120000 Trurl-based/_OpenBSD_/BlackBox create mode 100644 Trurl-based/_OpenBSD_/Comm/Mod/V24.odc create mode 100644 Trurl-based/_OpenBSD_/Host/Mod/Console.odc create mode 100644 Trurl-based/_OpenBSD_/Host/Mod/Console.txt create mode 100644 Trurl-based/_OpenBSD_/Host/Mod/Dates.odc create mode 100644 Trurl-based/_OpenBSD_/Host/Mod/Dates.txt create mode 100644 Trurl-based/_OpenBSD_/Host/Mod/Files.odc create mode 100644 Trurl-based/_OpenBSD_/Host/Mod/Files.txt create mode 100644 Trurl-based/_OpenBSD_/Lin/Mod/Dl.txt create mode 100644 Trurl-based/_OpenBSD_/Lin/Mod/Iconv.txt create mode 100644 Trurl-based/_OpenBSD_/Lin/Mod/Ioctl.txt create mode 100644 Trurl-based/_OpenBSD_/Lin/Mod/Libc.txt create mode 100644 Trurl-based/_OpenBSD_/Lin/Mod/Termios.txt create mode 100755 Trurl-based/_OpenBSD_/Lin/Rsrc/loader/BlackBox create mode 100644 Trurl-based/_OpenBSD_/Lin/Rsrc/loader/Makefile create mode 100755 Trurl-based/_OpenBSD_/Lin/Rsrc/loader/dev0 create mode 120000 Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB.so create mode 120000 Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libBB0.so create mode 100644 Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.c create mode 100755 Trurl-based/_OpenBSD_/Lin/Rsrc/loader/libdlobsdwrap.so create mode 100644 Trurl-based/_OpenBSD_/System/Mod/Kernel.odc create mode 100644 Trurl-based/_OpenBSD_/System/Mod/Kernel.txt create mode 120000 Trurl-based/_OpenBSD_/dev0 create mode 100644 Trurl-based/_OpenBSD_/libBB.so create mode 100644 Trurl-based/_OpenBSD_/libBB0.so create mode 120000 Trurl-based/_OpenBSD_/libdlobsdwrap.so create mode 100644 Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GLib.odc create mode 100644 Trurl-based/_OpenBSD_GUI/Gtk2/Mod/GObject.odc create mode 100644 Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gdk.odc create mode 100644 Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Gtk.odc create mode 100644 Trurl-based/_OpenBSD_GUI/Gtk2/Mod/Pango.odc create mode 100755 Trurl-based/_Windows_/BlackBox.exe create mode 100644 Trurl-based/_Windows_/BlackBox.exe.manifest create mode 100644 Trurl-based/_Windows_/Comm/Docu/TCP.odc create mode 100644 Trurl-based/_Windows_/Comm/Docu/V24.odc create mode 100644 Trurl-based/_Windows_/Comm/Mod/TCP.odc create mode 100644 Trurl-based/_Windows_/Comm/Mod/V24.odc create mode 100644 Trurl-based/_Windows_/Host/Mod/Console.odc create mode 100644 Trurl-based/_Windows_/Host/Mod/Console.txt create mode 100644 Trurl-based/_Windows_/Win/Docu/Api.odc create mode 100644 Trurl-based/_Windows_/Win/Mod/Api.odc create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Applogo.ico create mode 100644 Trurl-based/_Windows_/Win/Rsrc/CFLogo.ico create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Copy.cur create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Doclogo.ico create mode 100644 Trurl-based/_Windows_/Win/Rsrc/DtyLogo.ico create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Hand.cur create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Link.cur create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Move.cur create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Pick.cur create mode 100644 Trurl-based/_Windows_/Win/Rsrc/SFLogo.ico create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Stop.cur create mode 100644 Trurl-based/_Windows_/Win/Rsrc/Table.cur create mode 100644 Trurl-based/_Windows_/Win/Rsrc/folderimg.ico create mode 100644 Trurl-based/_Windows_/Win/Rsrc/leafimg.ico create mode 100644 Trurl-based/_Windows_/Win/Rsrc/openimg.ico create mode 100644 Trurl-based/_Windows_/dev0.exe create mode 100644 Trurl-based/__GUI/Comm/Docu/ObxStreamsClient.odc create mode 100644 Trurl-based/__GUI/Comm/Docu/ObxStreamsServer.odc create mode 100644 Trurl-based/__GUI/Comm/Docu/Sys-Map.odc create mode 100644 Trurl-based/__GUI/Comm/Mod/ObxStreamsClient.odc create mode 100644 Trurl-based/__GUI/Comm/Mod/ObxStreamsServer.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/AlienTool.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/Analyzer.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/Browser.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/Cmds.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/Debug.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/Dependencies.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/HeapSpy.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/Inspector.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/LinkChk.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/MsgSpy.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/RBrowser.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/References.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/Search.odc create mode 100644 Trurl-based/__GUI/Dev/Mod/SubTool.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/AnaOpt.opt create mode 100644 Trurl-based/__GUI/Dev/Rsrc/Analyzer.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/BrowOpt.opt create mode 100644 Trurl-based/__GUI/Dev/Rsrc/Browser.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/ComInterfaceGen.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/Create.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/HeapSpy.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/Inspect.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/LinkChk.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/Menus.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/MsgSpy.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/New/Cmds0.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/New/Cmds1.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/New/Cmds5.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/New/Models5.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/New/Views3.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/New/Views4.odc create mode 100644 Trurl-based/__GUI/Dev/Rsrc/New/Views5.odc create mode 100644 Trurl-based/__GUI/Empty.odc create mode 100644 Trurl-based/__GUI/Form/Docu/Cmds.odc create mode 100644 Trurl-based/__GUI/Form/Docu/Controllers.odc create mode 100644 Trurl-based/__GUI/Form/Docu/Dev-Man.odc create mode 100644 Trurl-based/__GUI/Form/Docu/Gen.odc create mode 100644 Trurl-based/__GUI/Form/Docu/Models.odc create mode 100644 Trurl-based/__GUI/Form/Docu/Sys-Map.odc create mode 100644 Trurl-based/__GUI/Form/Docu/User-Man.odc create mode 100644 Trurl-based/__GUI/Form/Docu/Views.odc create mode 100644 Trurl-based/__GUI/Form/Mod/Cmds.odc create mode 100644 Trurl-based/__GUI/Form/Mod/Controllers.odc create mode 100644 Trurl-based/__GUI/Form/Mod/Gen.odc create mode 100644 Trurl-based/__GUI/Form/Mod/Models.odc create mode 100644 Trurl-based/__GUI/Form/Mod/Views.odc create mode 100644 Trurl-based/__GUI/Form/Rsrc/Cmds.odc create mode 100644 Trurl-based/__GUI/Form/Rsrc/Cmds2.odc create mode 100644 Trurl-based/__GUI/Form/Rsrc/Gen.odc create mode 100644 Trurl-based/__GUI/Form/Rsrc/Menus.odc create mode 100644 Trurl-based/__GUI/Form/Rsrc/Strings.odc create mode 100644 Trurl-based/__GUI/Host/Rsrc/Imptype.odc create mode 100644 Trurl-based/__GUI/Host/Rsrc/Prefs.odc create mode 100644 Trurl-based/__GUI/Host/Rsrc/Printing.odc create mode 100644 Trurl-based/__GUI/Host/Rsrc/Setup.odc create mode 100644 Trurl-based/__GUI/Host/Rsrc/Strings.odc create mode 100644 Trurl-based/__GUI/Host/Rsrc/ru/Strings.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Actions.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Address0.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Address1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Address2.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Ascii.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/BB-Rules.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/BlackBox.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Buttons.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Calc.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Caps.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/ContIter.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/ControlShifter.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Controls.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Conv.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Count0.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Count1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Ctrls.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Cubes.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Db.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Dialog.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Fact.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/FileTree.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/FldCtrls.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Graphs.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Hello0.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Hello1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/LabelLister.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Lines.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Links.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Lookup0.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Lookup1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/MMerge.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Omosi.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Open0.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Open1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Orders.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PDBRep0.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PDBRep1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PDBRep2.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PDBRep3.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PDBRep4.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/ParCmd.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Patterns.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PhoneDB.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PhoneUI.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/PhoneUI1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Pi.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Random.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/RatCalc.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Sample.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Scroll.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Stores.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Sys-Map.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/TabViews.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Tabs.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Tickers.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Trap.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Twins.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/UnitConv.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views0.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views1.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views10.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views11.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views12.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views13.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views14.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views2.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views3.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views4.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views5.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Views6.odc create mode 100644 Trurl-based/__GUI/Obx/Docu/Wrappers.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Actions.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Address0.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Address1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Address2.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Ascii.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/BlackBox.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Buttons.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Calc.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Caps.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/ContIter.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/ControlShifter.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Controls.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Conv.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Count0.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Count1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Ctrls.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Cubes.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Db.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Dialog.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Fact.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/FileTree.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/FldCtrls.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Graphs.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Hello1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/LabelLister.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Lines.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Links.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Lookup0.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Lookup1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/MMerge.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Omosi.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Open0.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Open1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Orders.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PDBRep0.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PDBRep1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PDBRep2.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PDBRep3.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PDBRep4.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/ParCmd.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Patterns.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PhoneDB.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PhoneUI.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/PhoneUI1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Ratcalc.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Sample.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Scroll.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Stores.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/TabViews.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Tabs.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Tickers.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Twins.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/UnitConv.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views0.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views1.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views10.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views11.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views12.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views13.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views14.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views2.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views3.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views4.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views5.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Views6.odc create mode 100644 Trurl-based/__GUI/Obx/Mod/Wrappers.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Actions.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/BlackBox.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Controls.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Cubes.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Dialog.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/FileTree.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Menus.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Orders.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Orders1.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/PhoneUI.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/PhoneUI1.odc create mode 100644 Trurl-based/__GUI/Obx/Rsrc/Strings.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/MMData.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/MMTmpl.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/OData.dat create mode 100644 Trurl-based/__GUI/Obx/Samples/Omosi1.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/Omosi2.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/Omosi3.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/Omosi4.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/Omosi5.odc create mode 100644 Trurl-based/__GUI/Obx/Samples/Omosi6.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Api.odc create mode 100644 Trurl-based/__GUI/Std/Docu/CFrames.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Clocks.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Cmds.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Coder.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Debug.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Dialog.odc create mode 100644 Trurl-based/__GUI/Std/Docu/ETHConv.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Folds.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Headers.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Interpreter.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Links.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Loader.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Log.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Logos.odc create mode 100644 Trurl-based/__GUI/Std/Docu/MenuTool.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Scrollers.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Stamps.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Sys-Map.odc create mode 100644 Trurl-based/__GUI/Std/Docu/TabViews.odc create mode 100644 Trurl-based/__GUI/Std/Docu/Tables.odc create mode 100644 Trurl-based/__GUI/Std/Docu/ViewSizer.odc create mode 100644 Trurl-based/__GUI/Std/Mod/MenuTool.odc create mode 100644 Trurl-based/__GUI/Std/Mod/TabViews.odc create mode 100644 Trurl-based/__GUI/Std/Mod/Tables.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Cmds.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Cmds1.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Coder.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Folds.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Headers.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Links.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Scroller.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Stamps.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/TabViews.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/Tables.odc create mode 100644 Trurl-based/__GUI/Std/Rsrc/ViewSizer.odc create mode 100644 Trurl-based/__GUI/System/Docu/In.odc create mode 100644 Trurl-based/__GUI/System/Docu/Out.odc create mode 100644 Trurl-based/__GUI/System/Mod/In.odc create mode 100644 Trurl-based/__GUI/System/Mod/Init.odc create mode 100644 Trurl-based/__GUI/System/Mod/Out.odc create mode 100644 Trurl-based/__GUI/System/Rsrc/About.odc create mode 100644 Trurl-based/__GUI/System/Rsrc/Menus.odc create mode 100644 Trurl-based/__GUI/Tour.odc create mode 100644 Trurl-based/__Interp/Host/Mod/Dialog.txt create mode 100644 Trurl-based/__Interp/Host/Mod/Fonts.txt create mode 100644 Trurl-based/__Interp/Host/Mod/Windows.txt create mode 100644 Trurl-based/__Interp/System/Mod/Init.txt create mode 100755 Trurl-based/build create mode 100755 Trurl-based/build-dev0 create mode 100755 Trurl-based/build-gui create mode 100755 Trurl-based/clean create mode 100755 Trurl-based/run-BlackBox create mode 100755 Trurl-based/run-dev0 create mode 100755 Trurl-based/switch-target diff --git a/Trurl-based/Cons/Mod/Compiler.odc b/Trurl-based/Cons/Mod/Compiler.odc new file mode 100644 index 0000000000000000000000000000000000000000..35ade6f71af0eaddf6d8dda7df58774474b89106 GIT binary patch literal 3473 zcmbtX&2Jk;6rZFBx@`>{DyR^LAyn!nGApMy996>cZm@-8M{6f(fs2X9v4!o8W;aeE zA%xO@fCGn096032i96!YK;q0l(E3y%1iX*gFWZPnjI^HFH}CWJ-poE%-BuuAT)uFF zqtmgPM4{7;dhv^^!XuH{%G0aCB+fkquDuszS&>W7};Ca13 z%cmI=yFpKlSXD-UhDyuO$xw_5Z=}W~ID3V(3i0_JAuL#TV5V{TqNC0ub`io%y-vvq zZMJHJa6)JQx=n`((r_QKW}ooJK0l zNAkc(yklm8l43*Ldrk}SElqC&ZRK*tpbAkm%*%w3pM@lH?ZLB}N_LP2V_x#BU$W+Q z5usn<{^@3QI;RcsXb?v z^x-a=#50v;7^^Vs9xKDcNwe3aJPAViNUp7KVJ;9=?Vz{oOn`LRYelKF4m7YmFnmY` zGvn|$!xnEM#ujFm(8&c18$eG|KzPq*q1!7-yI+=6Y7YLc=kh_9MVt*t74vbH$l_U! z{ZJ1hJS5=KIJc4Lv7pelpL9InNs@;6_MN6WW4(5>-XP@0xRD+ar#IBdWz*&vZjSMt zjV4lz!S+R@pk~pPOw#*l($4|mQl*yW`OG0j)j?O=8KWck>_F)QmW{TDvz2A6)_kzS z`?(w#`yjx%@x9Kz-<0Dx9RPej7j8hO`lK5TigMB&t0l*q&crAPhrN}*34>80Hs01$&zSt~ag5|)~iDl9m3_}~SBvW7sIo_90SxLgD zC_y)^(;CqS+6E@Z{(j=&bWX}Ttaoa7FJV+HjlZU@EDJnGy;Jgl@a1xax&fatFp4Ct zCM&)j`f&JUaH1wLym0&>S{#Oj<1yDbTql|P0Skt22fh&a~!C$j)G8`5UvyZ1n%U1a60Lg zF|z+3I^KN=&N0e}p7vIHZ z3I_JZnX$rN`KPf%v|@|sk=aP8vl~YGN0_l!yW)3lkyAbG=wigpKlRSZMogVipJ#O4 zg!xmm&N=jNy|LjH_i@4fDJ i THEN + m := TextModels.dir.New(); + w := m.NewWriter(NIL); + WHILE i < j DO + w.WriteChar(s[i]); + INC(i) + END; + NEW(par); par.text := m; par.beg := 0; par.end := m.Length() - 1; + DevCommanders.par := par + END; + Dialog.Call(s, " ", res); + DevCommanders.par := NIL; + ShowStdLog; + RETURN res = 0 + END Call1; + + PROCEDURE Call0 (VAR s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + res: BOOLEAN; + inStr: BOOLEAN; + BEGIN + (* ASSERT s is 0X terminated and not empty *) + i := 0; + WHILE (s[i] # 0X) & (s[i] # ' ') & (s[i] # '(') DO + INC(i) + END; + IF s[i] = 0X THEN + res := Call1(s, i) + ELSIF s[i] = ' ' THEN + s[i] := 0X; + res := Call1(s, i + 1) + ELSE (* s[i] = '(' *) + INC(i); + inStr := FALSE; + WHILE (s[i] # 0X) & ~(~inStr & (s[i] = ')')) DO + IF s[i] = "'" THEN inStr := ~inStr END; + INC(i) + END; + IF s[i] # 0X THEN + INC(i); + IF s[i] = 0X THEN + res := Call1(s, i) + ELSE + s[i] := 0X; + res := Call1(s, i + 1) + END + ELSE + res := FALSE + END + END; + RETURN res + END Call0; + + PROCEDURE Call (VAR s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; + res: BOOLEAN; + BEGIN + i := 0; + WHILE (i < LEN(s)) & (s[i] # 0AX) & (s[i] # 0DX) & (s[i] # 0X) DO + INC(i) + END; + IF (i < LEN(s)) & (s[i] # 0X) THEN + IF (i > 0) & (s[0] # '#') THEN + s[i] := 0X; + res := Call0(s) + ELSE (* skip empty strings and comments *) + res := TRUE + END + ELSE (* end of input *) + res := FALSE + END; + RETURN res + END Call; + + PROCEDURE Run*; + VAR s: ARRAY 1024 OF CHAR; + BEGIN + Console.ReadLn(s); + WHILE Call(s) DO + Console.ReadLn(s) + END + END Run; + +BEGIN + textR := StdLog.text.NewReader(NIL) +END ConsInterp. diff --git a/Trurl-based/Cons/Mod/Log.txt b/Trurl-based/Cons/Mod/Log.txt new file mode 100644 index 0000000..87f4fd6 --- /dev/null +++ b/Trurl-based/Cons/Mod/Log.txt @@ -0,0 +1,193 @@ +MODULE ConsLog; + + (* + A. V. Shiryaev, 2012.10 + + Log.Hook implementation + based on StdLog + *) + + IMPORT + Log, Views, Dialog, + TextModels, TextMappers, + Console; + + TYPE + LogHook = POINTER TO RECORD (Log.Hook) END; + + VAR + logAlerts: BOOLEAN; + subOut: TextMappers.Formatter; + + buf: TextModels.Model; + textR: TextModels.Reader; + + (* Sub support *) + + PROCEDURE* Guard (o: ANYPTR): BOOLEAN; + BEGIN + RETURN o # NIL + END Guard; + + PROCEDURE* ClearBuf; + VAR subBuf: TextModels.Model; + BEGIN + subBuf := subOut.rider.Base(); subBuf.Delete(0, subBuf.Length()) + END ClearBuf; + + PROCEDURE* FlushBuf; + VAR c: CHAR; + BEGIN + IF buf.Length() > 0 THEN + textR.SetPos(0); + textR.ReadChar(c); + WHILE ~textR.eot DO + IF c = 0DX THEN + Console.WriteLn + ELSE + Console.WriteChar(c) + END; + textR.ReadChar(c) + END; + buf.Delete(0, buf.Length()) + END + END FlushBuf; + + PROCEDURE* SubFlush; + BEGIN + IF Log.synch THEN + FlushBuf; + (* IF Log.force THEN Views.RestoreDomain(text.Domain()) END *) + END; + END SubFlush; + + PROCEDURE (log: LogHook) Guard* (o: ANYPTR): BOOLEAN; + BEGIN RETURN Guard(o) + END Guard; + + PROCEDURE (log: LogHook) ClearBuf*; + BEGIN ClearBuf + END ClearBuf; + + PROCEDURE (log: LogHook) FlushBuf*; + BEGIN FlushBuf + END FlushBuf; + + PROCEDURE (log: LogHook) Beep*; + BEGIN Dialog.Beep + END Beep; + + PROCEDURE (log: LogHook) Char* (ch: CHAR); + BEGIN + subOut.WriteChar(ch); SubFlush + END Char; + + PROCEDURE (log: LogHook) Int* (n: INTEGER); + BEGIN + subOut.WriteChar(" "); subOut.WriteInt(n); SubFlush + END Int; + + PROCEDURE (log: LogHook) Real* (x: REAL); + BEGIN + subOut.WriteChar(" "); subOut.WriteReal(x); SubFlush + END Real; + + PROCEDURE (log: LogHook) String* (IN str: ARRAY OF CHAR); + BEGIN + subOut.WriteString(str); SubFlush + END String; + + PROCEDURE (log: LogHook) Bool* (x: BOOLEAN); + BEGIN + subOut.WriteChar(" "); subOut.WriteBool(x); SubFlush + END Bool; + + PROCEDURE (log: LogHook) Set* (x: SET); + BEGIN + subOut.WriteChar(" "); subOut.WriteSet(x); SubFlush + END Set; + + PROCEDURE (log: LogHook) IntForm* (x: INTEGER; base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN); + BEGIN + subOut.WriteIntForm(x, base, minWidth, fillCh, showBase); SubFlush + END IntForm; + + PROCEDURE (log: LogHook) RealForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR); + BEGIN + subOut.WriteRealForm(x, precision, minW, expW, fillCh); SubFlush + END RealForm; + + PROCEDURE (log: LogHook) Tab*; + BEGIN + subOut.WriteTab; SubFlush + END Tab; + + PROCEDURE (log: LogHook) Ln*; + BEGIN + subOut.WriteLn; SubFlush; + (* IF Log.synch THEN Views.RestoreDomain(text.Domain()) END *) + END Ln; + + PROCEDURE (log: LogHook) Para*; + BEGIN + subOut.WritePara; SubFlush; + (* IF Log.synch THEN Views.RestoreDomain(text.Domain()) END *) + END Para; + + PROCEDURE (log: LogHook) View* (v: ANYPTR); + BEGIN + IF (v # NIL) & (v IS Views.View) THEN + subOut.WriteView(v(Views.View)); SubFlush + END + END View; + + PROCEDURE (log: LogHook) ViewForm* (v: ANYPTR; w, h: INTEGER); + BEGIN + ASSERT(v # NIL, 20); + IF (v # NIL) & (v IS Views.View) THEN + subOut.WriteViewForm(v(Views.View), w, h); SubFlush + END + END ViewForm; + + PROCEDURE (log: LogHook) ParamMsg* (IN s, p0, p1, p2: ARRAY OF CHAR); + VAR msg: ARRAY 256 OF CHAR; i: INTEGER; ch: CHAR; + BEGIN + IF logAlerts THEN + (* IF Log.synch THEN Open END; *) + Dialog.MapParamString(s, p0, p1, p2, msg); + i := 0; ch := msg[0]; + WHILE ch # 0X DO + IF ch = TextModels.line THEN subOut.WriteLn + ELSIF ch = TextModels.para THEN subOut.WritePara + ELSIF ch = TextModels.tab THEN subOut.WriteTab + ELSIF ch >= " " THEN subOut.WriteChar(ch) + END; + INC(i); ch := msg[i]; + END; + subOut.WriteLn; SubFlush + (* ELSE + HostDialog.ShowParamMsg(s, p0, p1, p2) *) + END + END ParamMsg; + + + PROCEDURE AttachSubLog; + VAR h: LogHook; + BEGIN + subOut.ConnectTo(TextModels.dir.New()); + buf := subOut.rider.Base(); + textR := buf.NewReader(NIL); + NEW(h); + Log.SetHook(h); + END AttachSubLog; + + PROCEDURE DetachSubLog; + BEGIN + Log.SetHook(NIL) + END DetachSubLog; + +BEGIN + AttachSubLog +CLOSE + DetachSubLog; +END ConsLog. diff --git a/Trurl-based/Dev/Docu/ElfLinker.odc b/Trurl-based/Dev/Docu/ElfLinker.odc new file mode 100644 index 0000000000000000000000000000000000000000..7ce87b4f8ffa90d40d6c89887de8e223850ff13f GIT binary patch literal 6795 zcmb_hU2hy$8J@KZ)U?w|e701o4o*OJ;!F?{6|&ocN0)WP-sN8L0iCpsx|Z@&nuPFLrF)4DZ3zLh40A0;}=y*rUUHj~+E^&jjPX{IR@ zKQe>rczq6^r@to64_YdA(on}nR7-wqRGPWh8nG&Rv7X4n)2BqL#@@XyNEwD_Tv|1-~*9it$>i0A(Zlvd8eP1WsbA(RmXWA?SFs8 z4mf|I3S*O9wpkQeG%O39&wFy&E_u0H+F@fei~QL6$BTv~XG=HlBlu480{E(7x zSzvq_ve(gFcnx2jFR(>joiE~RQNl7|OG3I_kA0&admF8J<4&K$5U(n5Elq#I@S-^X z9ArP$1X~v1%akMdT@&i9nL#?thQO8j+R%xPDIuf~oNmZ^wFd8ZhCJc3)9($_i2bg(g zR-$#7D_>3h%%A8&XR1JH8>zG=pMm*K)?N2i$SbbH;MdjqYwDd>Cuvx+^G-S~qBME; zU07I6slt*#WTi1T;Ydw5#PcGh6G5i^LWiDfByz2<0JtffN(yz$&jUYJ=H{ApF+|uH zJIsw!KZK8?ES=b!8CV#LLk2I5GDJVkW}a*85m^ACI+3tI6}MvCMOqE~_YnE76GQXHbEoM8}@mv@JC$^MbLM z!gM+vnJnc6iq6mAU6}-ovfAz4rRXw;P8gV{2(U56Q^bdnY~<;aX_^(HaGIro4ogT^ zyZU&b0|misZe|$_yZ~A7eB=j}G~=_809CE^0-z=Yz_{{5W&qiwZ&qs@<%Pwp4Hidg zM{`()HF*h07GuAFJt{)VWz;Sp5KDx2#<0MA8@wv^GMkx;3i=L{G5}Kfah@uFI*ldR z#wJLPqaZ4(@EA=dX=P3sh%2n!DuJD(h-U_8EKyrM7sD@T#9x+ui-(A&a1xM8+N>z}d4Fq9cGoKy#2 z5+R8eHsEp-Jh(L@wQHZnE;HtjEo9zXv0v~=h4ar;SS{{#fP~(&gd5TZ3=@t3 zU?Ax7WKGS|64;*!x6nzOZ6&z?g^;SqX%*CyG`Yf!!6%*9M?s@?&FpbLDA^)`_`I2# zvs5lA1n;#2;UD=?EV8VVFbh(K^+6DQBWv9r7A;7EN`;Z;seP>_O8Ugd4v50zL6DA) z@dL*g47+_cCP<->R%NL*TI$zso7hKz#WKg<%q*g;fNG4i{7X`qQyYrJpj~^tE@u^t z;GkRE&P`hLx!lkUb_5nsTh(ay|4ax~va?Nx+LKDb? zhx{E~_}Cy-ZQZI!&BtjOa|h%}mN^5Q4ojRk;fls#)?K=yqehCPP6-_Jm!}6qlAH#MU5EyWWnRubsS=tg*NbA_on4yvgD9- zSn*A56WGH#Wa|S*bF0jFVFY8ShDu{CxS(fnpS$k9pzGXcvKd0O(0-_^&TGul&TK#R z-~k?a*u0>A3b8wT-P`@13~ab7msD=5%h+gh%3uqTA--qNbXE2*ts*(wJGb@*2WtP# z{e#}l1_o{o_O^Q6+k>9E7m#P)Qa6I|l3MZC)NoyG?;iAS^aiVSYr|c-*1NI2>n<(b zy}1pue04z$Rd){qOWW7ceI4C{o4s8$;fAlSpx^7`Y&K+nh`z6SyIsu3H^eOsdIz@$ znC^0b+A(;ZUHxG4M0Qp3)Fo)^Zr`Cuac9+NfE;R|GKn`rY#*NO(_$4csWLqK%yEri z;A#zk^Rp?ZI+M`uEU9w}9v>N2BZS*(P4BP7(2rntdYbx~d zEChn#NR(hR(>Ml)wKghSO3KNaN=xvqvGv>Ed4)!beGNF_4B@uC3|nwILGxQ&4ZGNu zBzkyS_sH2R%U5*~EQ>FIFy?rCbj1<@GL_Qy`GpkG$1~;%rproO4=XbDg4*5guc~h< z>3Z^J;(}V9`gwjFF0a~psl{@Q$EP&vvSq<)YGl=xELmW9+evYdnvPKdLXe}ICs9O% zj9E{xz(yaDUEN@4=_!7ABwqHG@r^qdCHPMu%p~;Fk!7H8t}OLQ?E;|i`ge`KJnZHA zyfjm#-ZibKk`d4sf0t}*mYIA-&|Ebc#UZu8mRKg?vdtiVNP6sH5s|o^9N}pZ4-3^h zB2KlrwrG_?TfuzEoW*Uwx67f6mc8n#MLsNt8HzElyZLHA!`^J)oo*GGedo_t=8mCG*U^`X2$lC+5W$pslN8tQz1|iFuhTEu)bZ*&EI1>7rfzJN)vs z@rR~w{v2rJ>=(1x{OuwC8q_zc(NnIiF1~91f$hv0^r(LYs)ZNXFmGwmP#+p0H-6o5 zev7x>yiwi!q_2A^nAfu(o6p*B?m5qV?0modf6>`k^9^?UqFZuF(BHe8JKufjL+8E! Rd|p1zy|MG>mw)9r{{tA$5kmj~ literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Mod/CPB.txt b/Trurl-based/Dev/Mod/CPB.txt new file mode 100644 index 0000000..56a840a --- /dev/null +++ b/Trurl-based/Dev/Mod/CPB.txt @@ -0,0 +1,2238 @@ +MODULE DevCPB; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPB.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPT, DevCPM; + + CONST + (* symbol values or ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + (*SYSTEM*) + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; size = 37; + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; + + (* Structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; charSet = {Char8, Char16}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; + + (*function number*) + assign = 0; + haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; + entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; + shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; + lchrfn = 33; lentierfcn = 34; bitsfn = 37; bytesfn = 38; + + (*SYSTEM function number*) + adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; + bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; + thisrecfn = 45; thisarrfn = 46; + + (* COM function number *) + validfn = 40; iidfn = 41; queryfn = 42; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* sysflags *) + nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; jint = -11; jstr = -13; + + AssertTrap = 0; (* default trap number *) + + covarOut = FALSE; + + + VAR + typSize*: PROCEDURE(typ: DevCPT.Struct); + zero, one, two, dummy, quot: DevCPT.Const; + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE NewLeaf*(obj: DevCPT.Object): DevCPT.Node; + VAR node: DevCPT.Node; typ: DevCPT.Struct; + BEGIN + typ := obj.typ; + CASE obj.mode OF + Var: + node := DevCPT.NewNode(Nvar); node.readonly := (obj.vis = externalR) & (obj.mnolev < 0) + | VarPar: + node := DevCPT.NewNode(Nvarpar); node.readonly := obj.vis = inPar; + | Con: + node := DevCPT.NewNode(Nconst); node.conval := DevCPT.NewConst(); + node.conval^ := obj.conval^ (* string is not copied, only its ref *) + | Typ: + node := DevCPT.NewNode(Ntype) + | LProc..IProc, TProc: + node := DevCPT.NewNode(Nproc) + ELSE err(127); node := DevCPT.NewNode(Nvar); typ := DevCPT.notyp + END ; + node.obj := obj; node.typ := typ; + RETURN node + END NewLeaf; + + PROCEDURE Construct*(class: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.typ := DevCPT.notyp; + node.left := x; node.right := y; x := node + END Construct; + + PROCEDURE Link*(VAR x, last: DevCPT.Node; y: DevCPT.Node); + BEGIN + IF x = NIL THEN x := y ELSE last.link := y END ; + WHILE y.link # NIL DO y := y.link END ; + last := y + END Link; + + PROCEDURE BoolToInt(b: BOOLEAN): INTEGER; + BEGIN + IF b THEN RETURN 1 ELSE RETURN 0 END + END BoolToInt; + + PROCEDURE IntToBool(i: INTEGER): BOOLEAN; + BEGIN + IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END + END IntToBool; + + PROCEDURE NewBoolConst*(boolval: BOOLEAN): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.booltyp; + x.conval := DevCPT.NewConst(); x.conval.intval := BoolToInt(boolval); RETURN x + END NewBoolConst; + + PROCEDURE OptIf*(VAR x: DevCPT.Node); (* x.link = NIL *) + VAR if, pred: DevCPT.Node; + BEGIN + if := x.left; + WHILE if.left.class = Nconst DO + IF IntToBool(if.left.conval.intval) THEN x := if.right; RETURN + ELSIF if.link = NIL THEN x := x.right; RETURN + ELSE if := if.link; x.left := if + END + END ; + pred := if; if := if.link; + WHILE if # NIL DO + IF if.left.class = Nconst THEN + IF IntToBool(if.left.conval.intval) THEN + pred.link := NIL; x.right := if.right; RETURN + ELSE if := if.link; pred.link := if + END + ELSE pred := if; if := if.link + END + END + END OptIf; + + PROCEDURE Nil*(): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.niltyp; + x.conval := DevCPT.NewConst(); x.conval.intval := 0; RETURN x + END Nil; + + PROCEDURE EmptySet*(): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.typ := DevCPT.settyp; + x.conval := DevCPT.NewConst(); x.conval.setval := {}; RETURN x + END EmptySet; + + PROCEDURE MarkAsUsed (node: DevCPT.Node); + VAR c: BYTE; + BEGIN + c := node.class; + WHILE (c = Nfield) OR (c = Nindex) OR (c = Nguard) OR (c = Neguard) DO node := node.left; c := node.class END; + IF (c = Nvar) & (node.obj.mnolev > 0) THEN node.obj.used := TRUE END + END MarkAsUsed; + + + PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object); + VAR n: DevCPT.Name; o: DevCPT.Object; + BEGIN + n := "@@ "; DevCPT.Insert(n, obj); obj.name^ := name$; (* avoid err 1 *) + obj.mode := Var; obj.typ := typ; + o := DevCPT.topScope.scope; + IF o = NIL THEN DevCPT.topScope.scope := obj + ELSE + WHILE o.link # NIL DO o := o.link END; + o.link := obj + END + END GetTempVar; + + + (* ---------- constant operations ---------- *) + + PROCEDURE Log (x: DevCPT.Node): INTEGER; + VAR val, exp: INTEGER; + BEGIN + exp := 0; + IF x.typ.form = Int64 THEN + RETURN -1 + ELSE + val := x.conval.intval; + IF val > 0 THEN + WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END + END; + IF val # 1 THEN exp := -1 END + END; + RETURN exp + END Log; + + PROCEDURE Floor (x: REAL): REAL; + VAR y: REAL; + BEGIN + IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x + ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN + y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0); + RETURN SHORT(ENTIER(x - y)) + y + ELSE RETURN SHORT(ENTIER(x)) + END + END Floor; + + PROCEDURE SetToInt (s: SET): INTEGER; + VAR x, i: INTEGER; + BEGIN + i := 31; x := 0; + IF 31 IN s THEN x := -1 END; + WHILE i > 0 DO + x := x * 2; DEC(i); + IF i IN s THEN INC(x) END + END; + RETURN x + END SetToInt; + + PROCEDURE IntToSet (x: INTEGER): SET; + VAR i: INTEGER; s: SET; + BEGIN + i := 0; s := {}; + WHILE i < 32 DO + IF ODD(x) THEN INCL(s, i) END; + x := x DIV 2; INC(i) + END; + RETURN s + END IntToSet; + + PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct); + CONST MAXL = 9223372036854775808.0; (* 2^63 *) + BEGIN + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF form IN intSet THEN + IF x.realval = 0 THEN typ := DevCPT.int32typ + ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ + ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ + END + ELSIF form IN realSet THEN (* SR *) + typ := DevCPT.real64typ + ELSIF form IN charSet THEN + IF x.intval <= 255 THEN typ := DevCPT.char8typ + ELSE typ := DevCPT.char16typ + END + ELSE typ := DevCPT.undftyp + END + END GetConstType; + + PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT); + VAR type: DevCPT.Struct; + BEGIN + GetConstType(x, form, errno, type); + IF ~DevCPT.Includes(form, type.form) + & ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + & ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + & ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN + err(errno); x.intval := 1; x.realval := 0 + END +(* + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval)) + OR (form = Int32) & (x.realval # 0) + OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535)) + OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255)) + OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN + err(errno); x.intval := 1; x.realval := 0 + END +*) + END CheckConstType; + + PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER); + VAR sr: SHORTREAL; + BEGIN + IF from = Set THEN + x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {}; + ELSIF from IN intSet + charSet THEN + IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval) + ELSIF to IN intSet THEN CheckConstType(x, to, 203) + ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc + ELSE (*to IN charSet*) CheckConstType(x, to, 220) + END + ELSIF from IN realSet THEN + IF to IN realSet THEN CheckConstType(x, to, 203); + IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END (* reduce precision *) + ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203) + END + END + END ConvConst; + + PROCEDURE Prepare (x: DevCPT.Const); + VAR r: REAL; + BEGIN + x.realval := x.realval + x.intval DIV 32768 * 32768; + x.intval := x.intval MOD 32768; + r := Floor(x.realval / 4096) * 4096; + x.intval := x.intval + SHORT(ENTIER(x.realval - r)); + x.realval := r + (* ABS(x.intval) < 2^15 & ABS(x.realval) MOD 2^12 = 0 *) + END Prepare; + + PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x + y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval + y.intval; z.realval := x.realval + y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = - y.realval) THEN err(212) + ELSE z.realval := x.realval + y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 206, type) + END AddConst; + + PROCEDURE NegateConst (y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := - y *) + BEGIN + IF type.form IN intSet THEN Prepare(y); z.intval := -y.intval; z.realval := -y.realval + ELSIF type.form IN realSet THEN z.realval := -y.realval + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END NegateConst; + + PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x - y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval - y.intval; z.realval := x.realval - y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = y.realval) THEN err(212) + ELSE z.realval := x.realval - y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END SubConst; + + PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x * y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval; + z.intval := x.intval * y.intval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & ( y.realval = 0.0) THEN err(212) + ELSIF (ABS(y.realval) = DevCPM.InfReal) & (x.realval = 0.0) THEN err(212) + ELSE z.realval := x.realval * y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END MulConst; + + PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x / y *) + BEGIN + IF type.form IN realSet THEN + IF (x.realval = 0.0) & (y.realval = 0.0) THEN err(212) + ELSIF (ABS(x.realval) = DevCPM.InfReal) & (ABS(y.realval) = DevCPM.InfReal) THEN err(212) + ELSE z.realval := x.realval / y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END DivConst; + + PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct); + (* x := x DIV y | x MOD y *) + BEGIN + IF type.form IN intSet THEN + IF y.realval + y.intval # 0 THEN + Prepare(x); Prepare(y); + quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval)); + quot.intval := 0; Prepare(quot); + x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval; + x.intval := x.intval - quot.intval * y.intval; + IF y.realval + y.intval > 0 THEN + WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + ELSE + WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + END; + IF div THEN x.realval := quot.realval; x.intval := quot.intval END; + GetConstType(x, type.form, 204, type) + ELSE err(205) + END + ELSE HALT(100) + END + END DivModConst; + + PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x = y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0 + | Real32, Real64: res := x.realval = y.realval + | Set: res := x.setval = y.setval + | String8, String16, Comp (* guid *): res := x.ext^ = y.ext^ + | NilTyp, Pointer, ProcTyp: res := x.intval = y.intval + END; + RETURN res + END EqualConst; + + PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Byte, Char8..Int32, Char16: res := x.intval < y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0 + | Real32, Real64: res := x.realval < y.realval + | String8, String16: res := x.ext^ < y.ext^ + | Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108) + END; + RETURN res + END LessConst; + + PROCEDURE IsNegConst (x: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < 0 OR x = (-0.0) *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Int8..Int32: res := x.intval < 0 + | Int64: Prepare(x); res := x.realval + x.intval < 0 + | Real32, Real64: res := (x.realval <= 0.) & (1. / x.realval <= 0.) + END; + RETURN res + END IsNegConst; + + + PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x + END NewIntConst; + + PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x + END NewLargeIntConst; + + PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc; + IF typ = NIL THEN typ := DevCPT.real64typ END; + x.typ := typ; + RETURN x + END NewRealConst; + + PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node; + VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + IF lstr # NIL THEN + x.typ := DevCPT.string16typ; + NEW(ext, 3 * len); i := 0; j := 0; + REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0; + x.conval.ext := ext + ELSE + x.typ := DevCPT.string8typ; x.conval.ext := str + END; + x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len; + RETURN x + END NewString; + + PROCEDURE CharToString8(n: DevCPT.Node); + VAR ch: SHORTCHAR; + BEGIN + n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2); + IF ch = 0X THEN n.conval.intval2 := 1 ELSE n.conval.intval2 := 2; n.conval.ext[1] := 0X END ; + n.conval.ext[0] := ch; n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString8; + + PROCEDURE CharToString16 (n: DevCPT.Node); + VAR ch, ch1: SHORTCHAR; i: INTEGER; + BEGIN + n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4); + IF n.conval.intval = 0 THEN + n.conval.ext[0] := 0X; n.conval.intval2 := 1 + ELSE + i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i); + n.conval.ext[i] := 0X; n.conval.intval2 := 2 + END; + n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString16; + + PROCEDURE String8ToString16 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string16typ; ext := n.conval.ext; + NEW(new, 2 * n.conval.intval2); i := 0; j := 0; + REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String8ToString16; + + PROCEDURE String16ToString8 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string8typ; ext := n.conval.ext; + NEW(new, n.conval.intval2); i := 0; j := 0; + REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String16ToString8; + + PROCEDURE StringToGuid (VAR n: DevCPT.Node); + BEGIN + ASSERT((n.class = Nconst) & (n.typ.form = String8)); + IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END; + n.typ := DevCPT.guidtyp + END StringToGuid; + + PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT); + VAR ntyp: DevCPT.Struct; + BEGIN + ntyp := n.typ; + IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n) + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN + IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *) + ELSE err(e) + END + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN + IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n) + ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN + (* ok *) + ELSE err(e) + END + ELSE err(e) + END + END CheckString; + + + PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.typ := typ; + node.left := x; node.right := y; x := node + END BindNodes; + + PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN; + BEGIN + RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst)) + OR (x.typ.form IN {String8, String16}) + END NotVar; + + + PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL; + BEGIN f := x.typ.form; g := typ.form; + IF x.class = Nconst THEN + IF g = String8 THEN + IF f = String16 THEN String16ToString8(x) + ELSIF f IN charSet THEN CharToString8(x) + ELSE typ := DevCPT.undftyp + END + ELSIF g = String16 THEN + IF f = String8 THEN String8ToString16(x) + ELSIF f IN charSet THEN CharToString16(x) + ELSE typ := DevCPT.undftyp + END + ELSE ConvConst(x.conval, f, g) + END; + x.obj := NIL + ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g)) + THEN + (* don't create new node *) + IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END + ELSE + IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN (* propagate to leaf nodes *) + Convert(x.left, typ); Convert(x.right, typ) + ELSE + node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node; + END + END; + x.typ := typ + END Convert; + + PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER); (* check expression compatibility *) + VAR f, g: INTEGER; new: DevCPT.Struct; + BEGIN + f := left.typ.form; g := right.typ.form; new := left.typ; + IF f IN intSet + realSet THEN + IF g IN intSet + realSet THEN + IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst) + (* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(right.conval.realval) = DevCPM.InfReal)) *) + OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst) + (* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN + new := DevCPT.real32typ (* SR *) + ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ + ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ (* SR *) + ELSIF op = slash THEN new := DevCPT.real64typ + ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ + ELSE new := DevCPT.int32typ + END + ELSE err(100) + END + ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN + IF f = String8 THEN StringToGuid(left) END; + IF g = String8 THEN StringToGuid(right) END; + IF left.typ # right.typ THEN err(100) END; + f := Comp + ELSIF f IN charSet + {String8, String16} THEN + IF g IN charSet + {String8, String16} THEN + IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN + new := DevCPT.string16typ + ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ + ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ + ELSIF op = plus THEN + IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ + ELSE new := DevCPT.string8typ + END + END; + IF (new.form IN {String8, String16}) + & ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst)) + THEN + err(100) + END + ELSE err(100) + END + ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN + IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp) + & ~((f = Pointer) & (g = Pointer) + & (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END + ELSIF f # g THEN err(100) + END; + IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN + IF g # new.form THEN Convert(right, new) END; + IF f # new.form THEN Convert(left, new) END + END + END Promote; + + PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *) + VAR ft, at: DevCPT.Struct; + BEGIN + WHILE fp # NIL DO + IF ap # NIL THEN + ft := fp.typ; at := ap.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ap.ptyp # NIL THEN at := ap.ptyp END; (* get original formal type *) + IF ~DevCPT.EqualType(ft, at) + OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis) + OR checkNames & (fp.name^ # ap.name^) THEN err(115) END ; + ap := ap.link + ELSE err(116) + END; + fp := fp.link + END; + IF ap # NIL THEN err(116) END + END CheckParameters; + + PROCEDURE CheckNewParamPair* (newPar, iidPar: DevCPT.Node); + VAR ityp, ntyp: DevCPT.Struct; + BEGIN + ntyp := newPar.typ.BaseTyp; + IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN + IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev) + THEN (* ok *) + ELSE err(168) + END + ELSIF ntyp.extlev = 0 THEN (* ok *) + ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN + IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END + ELSE err(168) + END + END CheckNewParamPair; + + + PROCEDURE DeRef*(VAR x: DevCPT.Node); + VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF typ.form = Pointer THEN + btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj; + IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN + btyp.pbused := TRUE + END ; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 0 + ELSE err(84) + END + END DeRef; + + PROCEDURE StrDeref*(VAR x: DevCPT.Node); + VAR typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN + IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ + ELSE btyp := DevCPT.string16typ + END; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 1 + ELSE err(90) + END + END StrDeref; + + PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; + BEGIN + f := y.typ.form; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79) + ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ; + IF f = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.typ.comp = Array THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & ((y.conval.intval < 0) OR (y.conval.intval >= x.typ.n)) THEN err(81) END + ELSIF x.typ.comp = DynArr THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & (y.conval.intval < 0) THEN err(81) END + ELSE err(82); typ := DevCPT.undftyp + END ; + BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly + END Index; + + PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object); + BEGIN (*x.typ.comp = Record*) + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(77) END ; + IF (y # NIL) & (y.mode IN {Fld, TProc}) THEN + BindNodes(Nfield, y.typ, x, NIL); x.obj := y; + x.readonly := x.left.readonly OR ((y.vis = externalR) & (y.mnolev < 0)) + ELSE err(83); x.typ := DevCPT.undftyp + END + END Field; + + PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN); + + PROCEDURE GTT(t0, t1: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN + IF ~guard THEN x := NewBoolConst(TRUE) END + ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint) + OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN + IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly + ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node + END + ELSE err(85) + END + END GTT; + + BEGIN + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112) + ELSIF x.typ.form = Pointer THEN + IF x.typ = DevCPT.sysptrtyp THEN + IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF x.typ.BaseTyp.comp # Record THEN err(85) + ELSIF obj.typ.form = Pointer THEN GTT(x.typ.BaseTyp, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF (x.typ.comp = Record) & (x.class = Nvarpar) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN + GTT(x.typ, obj.typ) + ELSE err(87) + END ; + IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END + END TypTest; + + PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; k: INTEGER; + BEGIN f := x.typ.form; + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (f IN intSet) & (y.typ.form = Set) THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202) + ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE err(92) + END ; + x.typ := DevCPT.booltyp + END In; + + PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Nmop); node.subcl := op; node.typ := typ; + node.left := z; RETURN node + END NewOp; + + BEGIN z := x; + IF ((z.class = Ntype) OR (z.class = Nproc)) & (op # adr) & (op # typfn) & (op # size) THEN err(126) (* !!! *) + ELSE + typ := z.typ; f := typ.form; + CASE op OF + | not: + IF f = Bool THEN + IF z.class = Nconst THEN + z.conval.intval := BoolToInt(~IntToBool(z.conval.intval)); z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(98) + END + | plus: + IF ~(f IN intSet + realSet) THEN err(96) END + | minus: + IF f IN intSet + realSet + {Set} THEN + IF z.class = Nconst THEN + IF f = Set THEN z.conval.setval := -z.conval.setval + ELSE NegateConst(z.conval, z.conval, z.typ) + END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(97) + END + | abs: + IF f IN intSet + realSet THEN + IF z.class = Nconst THEN + IF IsNegConst(z.conval, f) THEN NegateConst(z.conval, z.conval, z.typ) END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(111) + END + | cap: + IF f IN charSet THEN + IF z.class = Nconst THEN + IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END; + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111); z.typ := DevCPT.char8typ + END + | odd: + IF f IN intSet THEN + IF z.class = Nconst THEN + DivModConst(z.conval, two, FALSE, z.typ); (* z MOD 2 *) + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END ; + z.typ := DevCPT.booltyp + | adr: (*ADR*) + IF z.class = Nproc THEN + IF z.obj.mnolev > 0 THEN err(73) + ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc + END; + z := NewOp(op, typ, z) + ELSIF z.class = Ntype THEN + IF z.obj.typ.untagged THEN err(111) END; + z := NewOp(op, typ, z) + ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN + z := NewOp(op, typ, z) + ELSE err(127) + END ; + z.typ := DevCPT.int32typ + | typfn, size: (*TYP, SIZE*) + z := NewOp(op, typ, z); + z.typ := DevCPT.int32typ + | cc: (*SYSTEM.CC*) + IF (f IN intSet) & (z.class = Nconst) THEN + IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN + z := NewOp(op, typ, z) + ELSE err(219) + END + ELSE err(69) + END; + z.typ := DevCPT.booltyp + END + END; + x := z + END MOp; + + PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node); + VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct; + BEGIN + f := x.typ.form; + IF f = y.typ.form THEN + xval := x.conval; yval := y.conval; + CASE op OF + | times: + IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval * yval.setval + ELSIF f # Undef THEN err(101) + END + | slash: + IF f IN realSet THEN DivConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval / yval.setval + ELSIF f # Undef THEN err(102) + END + | div: + IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ) + ELSIF f # Undef THEN err(103) + END + | mod: + IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ) + ELSIF f # Undef THEN err(104) + END + | and: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) & IntToBool(yval.intval)) + ELSE err(94) + END + | plus: + IF f IN intSet + realSet THEN AddConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval + yval.setval + ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN + NEW(ext, LEN(xval.ext^) + LEN(yval.ext^)); + i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END; + j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END; + ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1) + ELSIF f # Undef THEN err(105) + END + | minus: + IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval - yval.setval + ELSIF f # Undef THEN err(106) + END + | min: + IF f IN intSet + realSet THEN + IF LessConst(yval, xval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | max: + IF f IN intSet + realSet THEN + IF LessConst(xval, yval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | or: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval)) + ELSE err(95) + END + | eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + | leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + END + ELSE err(100) + END; + x.obj := NIL + END ConstOp; + + PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ; + node.left := x; node.right := y; x := node + END NewOp; + + BEGIN z := x; + IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSE + Promote(z, y, op); + IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y) + ELSE + typ := z.typ; f := typ.form; g := y.typ.form; + CASE op OF + | times: + do := TRUE; + IF f IN intSet THEN + IF z.class = Nconst THEN + IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y + ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE + ELSE val := Log(z); + IF val >= 0 THEN + t := y; y := z; z := t; + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + ELSIF y.class = Nconst THEN + IF EqualConst(y.conval, one, f) THEN do := FALSE + ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + END + ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | slash: + IF f IN realSet THEN (* OK *) + ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y) + | div: + do := TRUE; + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSIF EqualConst(y.conval, one, f) THEN do := FALSE + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | mod: + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSE val := Log(y); + IF val >= 0 THEN + op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(104); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y); + | and: + IF f = Bool THEN + IF z.class = Nconst THEN + IF IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & IntToBool(y.conval.intval) THEN (* optimize z & TRUE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp + END + | plus: + IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END; + do := TRUE; + IF f IN intSet THEN + IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END + ELSIF f IN {String8, String16} THEN + IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END; + IF do THEN + IF z.class = Ndop THEN + t := z; WHILE t.right.class = Ndop DO t := t.right END; + IF (t.right.class = Nconst) & (y.class = Nconst) THEN + ConstOp(op, t.right, y); do := FALSE + ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE + ELSE + NewOp(op, typ, t.right, y); do := FALSE + END + ELSE + IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE + END + END + END + END ; + IF do THEN NewOp(op, typ, z, y) END; + | minus: + IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END; + IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y) + END; + | min, max: + IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END; + NewOp(op, typ, z, y); + | or: + IF f = Bool THEN + IF z.class = Nconst THEN + IF ~IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & ~IntToBool(y.conval.intval) THEN (* optimize z OR FALSE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp + END + | eql, neq, lss, leq, gtr, geq: + IF f IN {String8, String16} THEN + IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN + z := z.left; y := y.left (* remove LONG on both sides *) + ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *) + y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0 + ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *) + z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0 + END; + typ := DevCPT.booltyp + ELSIF (f IN {Undef, Char8..Real64, Char16, Int64}) + OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN + typ := DevCPT.booltyp + ELSE err(107); typ := DevCPT.undftyp + END; + NewOp(op, typ, z, y) + END + END + END; + x := z + END Op; + + PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR k, l: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (x.typ.form IN intSet) & (y.typ.form IN intSet) THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END + END ; + IF y.class = Nconst THEN + l := y.conval.intval; + IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) THEN err(202) END + END ; + IF (x.class = Nconst) & (y.class = Nconst) THEN + IF k <= l THEN + x.conval.setval := {k..l} + ELSE err(201); x.conval.setval := {l..k} + END ; + x.obj := NIL + ELSE BindNodes(Nupto, DevCPT.settyp, x, y) + END + ELSE err(93) + END ; + x.typ := DevCPT.settyp + END SetRange; + + PROCEDURE SetElem*(VAR x: DevCPT.Node); + VAR k: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END; + IF x.typ.form IN intSet THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k} + ELSE err(202) + END ; + x.obj := NIL + ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit + END ; + ELSE err(93) + END; + x.typ := DevCPT.settyp + END SetElem; + + PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node); + (* x := y, checks assignment compatibility *) + VAR f, g: SHORTINT; y, b: DevCPT.Struct; + BEGIN + y := ynode.typ; f := x.form; g := y.form; + IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ; + CASE f OF + | Undef, String8, String16, Byte: + | Bool, Set: + IF g # f THEN err(113) END + | Int8, Int16, Int32, Int64, Real32, Real64: (* SR *) + IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN + IF ynode.class = Nconst THEN Convert(ynode, x) + ELSIF ~DevCPT.Includes(f, g) THEN err(113) + END + ELSE err(113) + END +(* + IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN + err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END +*) + | Char8, Char16: + IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END + | Pointer: + b := x.BaseTyp; + IF DevCPT.Extends(y, x) + OR (g = NilTyp) + OR (g = Pointer) + & ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp)) + THEN (* ok *) + ELSIF (b.comp = DynArr) & b.untagged THEN (* pointer to untagged open array *) + IF ynode.class = Nconst THEN CheckString(ynode, b, 113) + ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113) + END + ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN (* p := ADR(r) *) + IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113) + ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113) + END + ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8})) + THEN + IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END + ELSE err(113) + END + | ProcTyp: + IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *) + ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN + IF ynode.obj.mode = LProc THEN + IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END + END; + IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN + IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE) + ELSE err(117) + END + ELSE err(113) + END + ELSE err(113) + END + | NoTyp, NilTyp: err(113) + | Comp: + x.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) + IF x.comp = Record THEN + IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END + ELSIF g IN {Char8, Char16, String8, String16} THEN + IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ) + ELSE CheckString(ynode, x, 113); + END; + IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN + err(114) + END + ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *) + ELSE err(113) + END + END + END CheckAssign; + + PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node); (* x := str or x[0] := 0X *) + BEGIN + ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16})); + IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN (* x := "" -> x[0] := 0X *) + Index(x, NewIntConst(0)); + str.typ := x.typ; str.conval.intval := 0; + END; + BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign + END AssignString; + + PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN); + BEGIN + IF (x.class = Nmop) & (x.subcl = val) THEN x := x.left END ; + IF x.class = Nguard THEN x := x.left END ; (* skip last (and unique) guard *) + IF (x.class = Nvar) & (dynArrToo OR (x.typ.comp # DynArr)) THEN x.obj.leaf := FALSE END + END CheckLeaf; + + PROCEDURE CheckOldType (x: DevCPT.Node); + BEGIN + IF ~(DevCPM.oberon IN DevCPM.options) + & ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN + err(198) + END + END CheckOldType; + + PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT); (* par0: first param of standard proc *) + VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node; + BEGIN x := par0; f := x.typ.form; + CASE fctno OF + haltfn: (*HALT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(218) + END + ELSIF (DevCPM.java IN DevCPM.options) + & ((x.class = Ntype) OR (x.class = Nvar)) + & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(69) + END ; + x.typ := DevCPT.notyp + | newfn: (*NEW*) + typ := DevCPT.notyp; + IF NotVar(x) THEN err(112) + ELSIF f = Pointer THEN + IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; + IF x.readonly THEN err(76) + ELSIF (x.typ.BaseTyp.attribute = absAttr) + OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + f := x.typ.BaseTyp.comp; + IF f IN {Record, DynArr, Array} THEN + IF f = DynArr THEN typ := x.typ.BaseTyp END ; + BindNodes(Nassign, DevCPT.notyp, x, NIL); x.subcl := newfn + ELSE err(111) + END + ELSE err(111) + END ; + x.typ := typ + | absfn: (*ABS*) + MOp(abs, x) + | capfn: (*CAP*) + MOp(cap, x) + | ordfn: (*ORD*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f = Char8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Set THEN Convert(x, DevCPT.int32typ) + ELSE err(111) + END + | bitsfn: (*BITS*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp) + ELSE err(111) + END + | entierfn: (*ENTIER*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | lentierfcn: (* LENTIER *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | oddfn: (*ODD*) + MOp(odd, x) + | minfn: (*MIN*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(FALSE) + | Char8: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Int8: x := NewIntConst(-128) + | Int16: x := NewIntConst(-32768) + | Int32: x := NewIntConst(-2147483648) + | Int64: x := NewLargeIntConst(0, -9223372036854775808.0E0) (* -2^63 *) + | Set: x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | maxfn: (*MAX*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(TRUE) + | Char8: x := NewIntConst(0FFH); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ + | Int8: x := NewIntConst(127) + | Int16: x := NewIntConst(32767) + | Int32: x := NewIntConst(2147483647) + | Int64: x := NewLargeIntConst(-1, 9223372036854775808.0E0) (* 2^63 - 1 *) + | Set: x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | chrfn: (*CHR*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | lchrfn: (* LCHR *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | shortfn: (*SHORT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int16 THEN Convert(x, DevCPT.int8typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ) + ELSIF f = String16 THEN Convert(x, DevCPT.string8typ) + ELSE err(111) + END + END + | longfn: (*LONG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ) + ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ) + ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ) + ELSIF f = String8 THEN Convert(x, DevCPT.string16typ) + ELSE err(111) + END + END + | incfn, decfn: (*INC, DEC*) + IF NotVar(x) THEN err(112) + ELSIF ~(f IN intSet) THEN err(111) + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | inclfn, exclfn: (*INCL, EXCL*) + IF NotVar(x) THEN err(112) + ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | lenfn: (*LEN*) + IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126) (* !!! *) + (* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.class = Nconst THEN + IF x.typ.form = Char8 THEN CharToString8(x) + ELSIF x.typ.form = Char16 THEN CharToString16(x) + END + END; + IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END + END + | copyfn: (*COPY*) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END + ELSE err(111); x.typ := DevCPT.int32typ + END + | adrfn: (*ADR*) + IF x.class = Ntype THEN CheckOldType(x) END; + CheckLeaf(x, FALSE); MOp(adr, x) + | typfn: (*TYP*) + CheckLeaf(x, FALSE); + IF x.class = Ntype THEN + CheckOldType(x); + IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(adr, x) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(typfn, x) + END + | sizefn: (*SIZE*) + IF x.class # Ntype THEN err(110); x := NewIntConst(1) + ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN + CheckOldType(x); x.typ.pvused := TRUE; + IF typSize # NIL THEN + typSize(x.typ); x := NewIntConst(x.typ.size) + ELSE + MOp(size, x) + END + ELSE err(111); x := NewIntConst(1) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ) + ELSIF f # Int32 THEN err(111) + END + | ccfn: (*SYSTEM.CC*) + MOp(cc, x) + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet + charSet + {Byte, Set}) THEN err(111) + END + | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END + | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (f IN intSet) & (x.class = Nconst) THEN + IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220) + END + ELSE err(69) + END + | valfn: (*SYSTEM.VAL*) + IF x.class # Ntype THEN err(110) + ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111) + ELSE CheckOldType(x) + END + | assertfn: (*ASSERT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := NewBoolConst(FALSE) + ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE) + ELSE MOp(not, x) + END + | validfn: (* VALID *) + IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN + MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil()) + ELSE err(111) + END; + x.typ := DevCPT.booltyp + | iidfn: (* COM.IID *) + IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x) + ELSE + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN + IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END + ELSE err(111) + END; + x.class := Nconst; x.typ := DevCPT.guidtyp + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f # Pointer THEN err(111) + END + END ; + par0 := x + END StPar0; + + PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE); + (* x: second parameter of standard proc *) + VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node; + + PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.subcl := subcl; + node.left := left; node.right := right; RETURN node + END NewOp; + + BEGIN p := par0; f := x.typ.form; + CASE fctno OF + incfn, decfn: (*INC DEC*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); p.typ := DevCPT.notyp + ELSE + IF f # p.typ.form THEN + IF f IN intSet THEN Convert(x, p.typ) + ELSE err(111) + END + END ; + p := NewOp(Nassign, fctno, p, x); + p.typ := DevCPT.notyp + END + | inclfn, exclfn: (*INCL, EXCL*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202) + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | lenfn: (*LEN*) + IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69) + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + L := SHORT(x.conval.intval); typ := p.typ; + WHILE (L > 0) & (typ.comp IN {DynArr, Array}) DO typ := typ.BaseTyp; DEC(L) END ; + IF (L # 0) OR ~(typ.comp IN {DynArr, Array}) THEN err(132) + ELSE x.obj := NIL; + IF typ.comp = DynArr THEN + WHILE p.class = Nindex DO + p := p.left; INC(x.conval.intval) (* possible side effect ignored *) + END; + p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ + ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ + END + END + END + | copyfn: (*COPY*) + IF NotVar(x) THEN err(112) + ELSIF x.readonly THEN err(76) + ELSE + CheckString(p, x.typ, 111); t := x; x := p; p := t; + IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x) + ELSE p := NewOp(Nassign, copyfn, p, x) + END + END ; + p.typ := DevCPT.notyp; MarkAsUsed(x) + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208) + ELSIF (p.class = Nconst) & (x.class = Nconst) THEN + n := x.conval.intval; + IF n > 0 THEN + WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END + ELSE + WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END + END; + p.obj := NIL + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ + END + ELSE err(111) + END + | minfn: (*MIN*) + IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END + | maxfn: (*MAX*) + IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) END + | newfn: (*NEW(p, x...)*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp = DynArr THEN + IF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) + & (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END + ELSE err(111) + END ; + p.right := x; p.typ := p.typ.BaseTyp + ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN + typ := p.left.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF typ.sysflag = interface THEN + typ := x.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF (f = Pointer) & (typ.sysflag = interface) THEN + p.right := x + ELSE err(169) + END + ELSE err(64) + END + ELSE err(111) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END; + p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp + ELSE err(111) + END + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet) THEN err(111) + ELSE + IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ; + p.typ := p.left.typ + END + | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef..Set, NilTyp, Pointer, ProcTyp, Char16, Int64} THEN + IF (fctno = getfn) OR (fctno = getrfn) THEN + IF NotVar(x) THEN err(112) END ; + t := x; x := p; p := t + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | bitfn: (*SYSTEM.BIT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + p := NewOp(Ndop, bit, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.booltyp + | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN (* ok *) + ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN + typ := x.typ; + WHILE typ.comp = DynArr DO typ := typ.BaseTyp END; + tp1 := p.typ; + WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END; + IF typ.size # tp1.size THEN err(115) END + ELSE err(115) + END + ELSIF p.typ.comp = DynArr THEN err(115) + ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN + i := 0; n := 0; + WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END; + x := NewIntConst(n) + ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111) + END ; + IF (x.class = Nconst) & (x.typ = p.typ) THEN (* ok *) + ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet)) + OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN + t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t + ELSE x.readonly := FALSE + END ; + x.typ := p.typ; p := x + | movefn: (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END ; + p.link := x + | assertfn: (*ASSERT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(218) + END + ELSIF + (DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(69) + END; + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp + END; + p.link := x + ELSE err(64) + END ; + par0 := p + END StPar1; + + PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT); + (* x: n+1-th param of standard proc *) + VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct; + BEGIN p := par0; f := x.typ.form; + IF fctno = newfn THEN (*NEW(p, ..., x...*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp # DynArr THEN err(64) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) THEN err(63) END; + node := p.right; WHILE node.link # NIL DO node := node.link END; + node.link := x; p.typ := p.typ.BaseTyp + ELSE err(111) + END + ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + node := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p; + node.left := p.link; p.link := x; p := node + ELSE err(111) + END ; + p.typ := DevCPT.notyp + ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN + IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END; + IF x.readonly THEN err(76) END; + CheckNewParamPair(x, p.link); + MarkAsUsed(x); + node := DevCPT.NewNode(Ndop); node.subcl := queryfn; + node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node + ELSE err(111) + END; + p.typ := DevCPT.booltyp + ELSE err(64) + END ; + par0 := p + END StParN; + + PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT); + VAR dim: SHORTINT; x, p: DevCPT.Node; + BEGIN p := par0; + IF fctno <= ashfn THEN + IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN + IF p.typ.comp = DynArr THEN err(65) END ; + p.typ := DevCPT.notyp + ELSIF (fctno = minfn) OR (fctno = maxfn) THEN + IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END; + p.hint := 0 + ELSIF fctno <= sizefn THEN (* 1 param *) + IF parno < 1 THEN err(65) END + ELSE (* more than 1 param *) + IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*) + BindNodes(Nassign, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ + ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*) + IF p.typ.form IN {String8, String16} THEN + IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1) + ELSIF (p.class = Ndop) & (p.subcl = plus) THEN (* propagate to leaf nodes *) + StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ + ELSE + WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END; + IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END; + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len + END + ELSIF p.typ.comp = DynArr THEN dim := 0; + WHILE p.class = Nindex DO p := p.left; INC(dim) END ; (* possible side effect ignored *) + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(dim)); p.subcl := len + ELSE + p := NewIntConst(p.typ.n) + END + ELSIF parno < 2 THEN err(65) + END + END + ELSIF fctno = assertfn THEN + IF parno = 1 THEN x := NIL; + BindNodes(Ntrap, DevCPT.notyp, x, NewIntConst(AssertTrap)); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + ELSIF parno < 1 THEN err(65) + END + ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN + IF parno < 1 THEN err(65) END + ELSIF fctno < validfn THEN (*SYSTEM*) + IF (parno < 1) OR + (fctno > ccfn) & (parno < 2) OR + (fctno = movefn) & (parno < 3) THEN err(65) + END + ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN + IF parno < 2 THEN err(65) END + ELSE (* COM *) + IF fctno = queryfn THEN + IF parno < 3 THEN err(65) END + ELSE + IF parno < 1 THEN err(65) END + END + END ; + par0 := p + END StFct; + + PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN); + (* check array compatibility *) + VAR atyp: DevCPT.Struct; + BEGIN (* ftyp.comp = DynArr *) + atyp := ap.typ; + IF atyp.form IN {Char8, Char16, String8, String16} THEN + IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ) + ELSE CheckString(ap, ftyp, 67) + END + ELSE + WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END; + IF ftyp.comp = DynArr THEN err(67) + ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *) + ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66) + END + END + END DynArrParCheck; + + PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.Object); + BEGIN + IF (x.obj # NIL) & (x.obj.mode IN {LProc, XProc, TProc, CProc}) THEN + fpar := x.obj.link; + IF x.obj.mode = TProc THEN + IF fpar.typ.form = Pointer THEN + IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END + END; + fpar := fpar.link + END + ELSIF (x.class # Ntype) & (x.typ # NIL) & (x.typ.form = ProcTyp) THEN + fpar := x.typ.link + ELSE err(121); fpar := NIL; x.typ := DevCPT.undftyp + END + END PrepCall; + + PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object); (* checks parameter compatibilty *) + VAR at, ft: DevCPT.Struct; + BEGIN + at := ap.typ; ft := fp.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ft.form # Undef THEN + IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END; + IF fp.mode = VarPar THEN + IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *) + ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *) + ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN + (* ok *) + ELSE + IF fp.vis = inPar THEN + IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN + StringToGuid(ap); at := ap.typ +(* + ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp)) + & ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *) + ELSIF NotVar(ap) THEN err(122) +*) + END; + IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END + ELSE + IF NotVar(ap) THEN err(122) + ELSIF ap.readonly THEN err(76) + ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN + err(167) + ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE) + END + END; + IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar) + ELSIF ODD(fp.sysflag DIV newBit) THEN + IF ~DevCPT.Extends(at, ft) THEN err(123) END + ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *) + ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *) + ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *) + ELSIF fp.vis = inPar THEN CheckAssign(ft, ap) + ELSIF ~DevCPT.EqualType(ft, at) THEN err(123) + END + END + ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE) + ELSE CheckAssign(ft, ap) + END + END + END Param; + + PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN); + VAR scope: DevCPT.Object; + BEGIN + scope := DevCPT.topScope; + WHILE dlev > 0 DO DEC(dlev); + INCL(scope.link.conval.setval, slNeeded); + scope := scope.left + END; + IF var THEN INCL(scope.link.conval.setval, imVar) END (* !!! *) + END StaticLink; + + PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object); + VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE; + BEGIN + IF x.class = Nproc THEN typ := x.typ; + lev := x.obj.mnolev; + IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) END ; (* !!! *) + IF x.obj.mode = IProc THEN err(121) END + ELSIF (x.class = Nfield) & (x.obj.mode = TProc) THEN typ := x.typ; + x.class := Nproc; p := x.left; x.left := NIL; p.link := apar; apar := p; fp := x.obj.link + ELSE typ := x.typ.BaseTyp + END ; + BindNodes(Ncall, typ, x, apar); x.obj := fp + END Call; + + PROCEDURE Enter*(VAR procdec: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object); + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc; + x.left := procdec; x.right := stat; procdec := x + END Enter; + + PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object); + VAR node: DevCPT.Node; + BEGIN + IF proc = NIL THEN (* return from module *) + IF x # NIL THEN err(124) END + ELSE + IF x # NIL THEN CheckAssign(proc.typ, x) + ELSIF proc.typ # DevCPT.notyp THEN err(124) + END + END ; + node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node + END Return; + + PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR z: DevCPT.Node; + BEGIN + IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ; + CheckAssign(x.typ, y); + IF x.readonly THEN err(76) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y) + ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign + END + END Assign; + + PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ninittd); node.typ := typ; + node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos; + IF inittd = NIL THEN inittd := node ELSE last.link := node END ; + last := node + END Inittd; + + (* handling of temporary variables for string operations *) + + PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN; + BEGIN + IF right.class = Nconst THEN + RETURN FALSE + ELSIF (right.class = Ndop) & (right.subcl = plus) THEN + RETURN Overlap(left, right.left) OR Overlap(left, right.right) + ELSE + WHILE right.class = Nmop DO right := right.left END; + IF right.class = Nderef THEN right := right.left END; + IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END; + LOOP + IF left.class = Nvarpar THEN + WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO + right := right.left + END; + RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev) + ELSIF right.class = Nvarpar THEN + WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END; + RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev) + ELSIF (left.class = Nvar) & (right.class = Nvar) THEN + RETURN left.obj = right.obj + ELSIF (left.class = Nderef) & (right.class = Nderef) THEN + RETURN TRUE + ELSIF (left.class = Nindex) & (right.class = Nindex) THEN + IF (left.right.class = Nconst) & (right.right.class = Nconst) + & (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END; + left := left.left; right := right.left + ELSIF (left.class = Nfield) & (right.class = Nfield) THEN + IF left.obj # right.obj THEN RETURN FALSE END; + left := left.left; right := right.left; + WHILE left.class = Nguard DO left := left.left END; + WHILE right.class = Nguard DO right := right.left END + ELSE + RETURN FALSE + END + END + END + END Overlap; + + PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER); + VAR x: INTEGER; + BEGIN + IF n.class = Nconst THEN + length := n.conval.intval2 - 1 + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetStaticLength(n.left, length); GetStaticLength(n.right, x); + IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := n.typ.n - 1 + ELSIF n.typ.comp = DynArr THEN + length := -1 + ELSE (* error case *) + length := 4 + END + END + END GetStaticLength; + + PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node); + VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object; + BEGIN + IF n.class = Nconst THEN + length := NewIntConst(n.conval.intval2 - 1) + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x); + IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x) + ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus + END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := NewIntConst(n.typ.n - 1) + ELSIF n.typ.comp = DynArr THEN + d := 0; + WHILE n.class = Nindex DO n := n.left; INC(d) END; + ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar)); + IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN + GetTempVar("@tmp", n.left.typ, obj); + x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x); + n.left := NewLeaf(obj); (* tree is manipulated here *) + n := NewLeaf(obj); DeRef(n) + END; + IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN + StrDeref(n); + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus + ELSE + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + END; + length := n + ELSE (* error case *) + length := NewIntConst(4) + END + END + END GetMaxLength; + + PROCEDURE CheckBuffering* ( + VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node + ); + VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER; + BEGIN + IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) + & ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right)) + OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL) + OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN + IF (par # NIL) & (par.typ.comp = Array) THEN + len := par.typ.n - 1 + ELSE + IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END; + GetStaticLength(n, xlen); + IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END + END; + IF len # -1 THEN + typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp; + GetTempVar("@str", typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + ELSE + IF left # NIL THEN GetMaxLength(left, stat, last, length) + ELSE GetMaxLength(n, stat, last, length) + END; + typ := DevCPT.NewStr(Pointer, Basic); + typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp; + GetTempVar("@ptr", typ, obj); + x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x); + x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj); DeRef(n) + END; + StrDeref(n) + ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL) + & ((par # NIL) OR (n.class = Ncall)) + & ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN + GetTempVar("@cip", DevCPT.punktyp, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckBuffering; + + PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node); + VAR x: DevCPT.Node; obj: DevCPT.Object; + BEGIN + IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN + GetTempVar("@ptr", n.typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckVarParBuffering; + + + (* case optimization *) + + PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node); + VAR a: INTEGER; + BEGIN + IF n.left # NIL THEN + a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head); + IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END + ELSIF n.conval.intval < min THEN + min := n.conval.intval + END; + IF n.right # NIL THEN + a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head); + IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END + ELSIF n.conval.intval2 > max THEN + max := n.conval.intval2 + END; + INC(num); + IF n.conval.intval < n.conval.intval2 THEN + INC(num); + IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END + END + END Evaluate; + + PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node); + VAR n: DevCPT.Node; + BEGIN + IF root # head THEN + IF head.conval.intval2 < root.conval.intval THEN + Rebuild(root.left, head); + root.left := head.right; head.right := root; root := head + ELSE + Rebuild(root.right, head); + root.right := head.left; head.left := root; root := head + END + END + END Rebuild; + + PROCEDURE OptimizeCase* (VAR n: DevCPT.Node); + VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node; + BEGIN + IF n # NIL THEN + min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n; + Evaluate(n, min, max, num, dist, head); + limit := 6 * num; + IF limit < 100 THEN limit := 100 END; + IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN + INCL(n.conval.setval, useTable) + ELSE + IF num > 4 THEN Rebuild(n, head) END; + INCL(n.conval.setval, useTree); + OptimizeCase(n.left); + OptimizeCase(n.right) + END + END + END OptimizeCase; +(* + PROCEDURE ShowTree (n: DevCPT.Node; opts: SET); + BEGIN + IF n # NIL THEN + IF opts = {} THEN opts := n.conval.setval END; + IF useTable IN opts THEN + IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END; + DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END + ELSIF useTree IN opts THEN + DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")") + ELSE + ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW(" "); ShowTree(n.right, opts) + END + END + END ShowTree; +*) +BEGIN + zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0; + one := DevCPT.NewConst(); one.intval := 1; one.realval := 0; + two := DevCPT.NewConst(); two.intval := 2; two.realval := 0; + dummy := DevCPT.NewConst(); + quot := DevCPT.NewConst() +END DevCPB. diff --git a/Trurl-based/Dev/Mod/CPC486.txt b/Trurl-based/Dev/Mod/CPC486.txt new file mode 100644 index 0000000..1a952d9 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPC486.txt @@ -0,0 +1,2333 @@ +MODULE DevCPC486; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPC486.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, DevCPM, DevCPT, DevCPE, DevCPL486; + + CONST + initializeAll = FALSE; (* initialize all local variable to zero *) + initializeOut = FALSE; (* initialize all OUT parameters to zero *) + initializeDyn = FALSE; (* initialize all open array OUT parameters to zero *) + initializeStr = FALSE; (* initialize rest of string value parameters to zero *) + + FpuControlRegister = 33EH; (* value for fpu control register initialization *) + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + VString16to8 = 29; VString8 = 30; VString16 = 31; + intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* item modes for i386 *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + getrfn = 26; putrfn = 27; + min = 34; max = 35; typ = 36; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isGuarded = 30; isCallback = 31; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + false = 0; true = 1; nil = 0; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; wreg = {AX, BX, CX, DX, SI, DI}; + + (* GenShiftOp *) + ROL = 0; ROR = 8H; SHL = 20H; SHR = 28H; SAR = 38H; + + (* GenBitOp *) + BT = 20H; BTS = 28H; BTR = 30H; + + (* GenFDOp *) + FADD = 0; FMUL = 8H; FCOM = 10H; FCOMP = 18H; FSUB = 20H; FSUBR = 28H; FDIV = 30H; FDIVR = 38H; + + (* GenFMOp *) + FABS = 1E1H; FCHS = 1E0H; FTST = 1E4H; FSTSW = 7E0H; FUCOM = 2E9H; + + (* GenCode *) + SAHF = 9EH; WAIT = 9BH; + + (* condition codes *) + ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *) + ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *) + ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1; + ccAlways = -1; ccNever = -2; ccCall = -3; + + (* sysflag *) + untagged = 1; callback = 2; noAlign = 3; union = 7; + interface = 10; ccall = -10; guarded = 10; noframe = 16; + nilBit = 1; enumBits = 8; new = 1; iid = 2; + stackArray = 120; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* pointer init limits *) + MaxPtrs = 10; MaxPush = 4; + + Tag0Offset = 12; + Mth0Offset = -4; + ArrDOffs = 8; + numPreIntProc = 2; + + stackAllocLimit = 2048; + + + VAR + imLevel*: ARRAY 64 OF BYTE; + intHandler*: DevCPT.Object; + inxchk, ovflchk, ranchk, typchk, ptrinit, hints: BOOLEAN; + WReg, BReg, AllReg: SET; FReg: INTEGER; + ptrTab: ARRAY MaxPtrs OF INTEGER; + stkAllocLbl: DevCPL486.Label; + procedureUsesFpu: BOOLEAN; + + + PROCEDURE Init* (opt: SET); + CONST chk = 0; achk = 1; hint = 29; + BEGIN + inxchk := chk IN opt; ovflchk := achk IN opt; ranchk := achk IN opt; typchk := chk IN opt; ptrinit := chk IN opt; + hints := hint IN opt; + stkAllocLbl := DevCPL486.NewLbl + END Init; + + PROCEDURE Reversed (cond: BYTE): BYTE; (* reversed condition *) + BEGIN + IF cond = lss THEN RETURN gtr + ELSIF cond = gtr THEN RETURN lss + ELSIF cond = leq THEN RETURN geq + ELSIF cond = geq THEN RETURN leq + ELSE RETURN cond + END + END Reversed; + + PROCEDURE Inverted (cc: INTEGER): INTEGER; (* inverted sense of condition code *) + BEGIN + IF ODD(cc) THEN RETURN cc-1 ELSE RETURN cc+1 END + END Inverted; + + PROCEDURE setCC* (VAR x: DevCPL486.Item; rel: BYTE; reversed, signed: BOOLEAN); + BEGIN + IF reversed THEN rel := Reversed(rel) END; + CASE rel OF + false: x.offset := ccNever + | true: x.offset := ccAlways + | eql: x.offset := ccE + | neq: x.offset := ccNE + | lss: IF signed THEN x.offset := ccL ELSE x.offset := ccB END + | leq: IF signed THEN x.offset := ccLE ELSE x.offset := ccBE END + | gtr: IF signed THEN x.offset := ccG ELSE x.offset := ccA END + | geq: IF signed THEN x.offset := ccGE ELSE x.offset := ccAE END + END; + x.mode := Cond; x.form := Bool; x.reg := 0; + IF reversed THEN x.reg := 1 END; + IF signed THEN INC(x.reg, 2) END + END setCC; + + PROCEDURE StackAlloc*; (* pre: len = CX bytes; post: len = CX words *) + BEGIN + DevCPL486.GenJump(ccCall, stkAllocLbl, FALSE) + END StackAlloc; + + PROCEDURE^ CheckAv* (reg: INTEGER); + + PROCEDURE AdjustStack (val: INTEGER); + VAR c, sp: DevCPL486.Item; + BEGIN + IF val < -stackAllocLimit THEN + CheckAv(CX); + DevCPL486.MakeConst(c, -val, Int32); DevCPL486.MakeReg(sp, CX, Int32); DevCPL486.GenMove(c, sp); + StackAlloc + ELSIF val # 0 THEN + DevCPL486.MakeConst(c, val, Int32); DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenAdd(c, sp, FALSE) + END + END AdjustStack; + + PROCEDURE DecStack (form: INTEGER); + BEGIN + IF form IN {Real64, Int64} THEN AdjustStack(-8) ELSE AdjustStack(-4) END + END DecStack; + + PROCEDURE IncStack (form: INTEGER); + BEGIN + IF form IN {Real64, Int64} THEN AdjustStack(8) ELSE AdjustStack(4) END + END IncStack; + + (*-----------------register handling------------------*) + + PROCEDURE SetReg* (reg: SET); + BEGIN + AllReg := reg; WReg := reg; BReg := reg * {0..3} + SYSTEM.LSH(reg * {0..3}, 4); FReg := 8 + END SetReg; + + PROCEDURE CheckReg*; + VAR reg: SET; + BEGIN + reg := AllReg - WReg; + IF reg # {} THEN + DevCPM.err(-777); (* register not released *) + IF AX IN reg THEN DevCPM.LogWStr(" AX") END; + IF BX IN reg THEN DevCPM.LogWStr(" BX") END; + IF CX IN reg THEN DevCPM.LogWStr(" CX") END; + IF DX IN reg THEN DevCPM.LogWStr(" DX") END; + IF SI IN reg THEN DevCPM.LogWStr(" SI") END; + IF DI IN reg THEN DevCPM.LogWStr(" DI") END; + WReg := AllReg; BReg := AllReg * {0..3} + SYSTEM.LSH(AllReg * {0..3}, 4) + END; + IF FReg < 8 THEN DevCPM.err(-778); FReg := 8 (* float register not released *) + ELSIF FReg > 8 THEN DevCPM.err(-779); FReg := 8 + END + END CheckReg; + + PROCEDURE CheckAv* (reg: INTEGER); + BEGIN + ASSERT(reg IN WReg) + END CheckAv; + + PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR n: INTEGER; s, s1: SET; + BEGIN + CASE f OF + | Byte, Bool, Char8, Int8: + s := BReg * {0..3} - stop; + IF (high IN stop) OR (high IN hint) & (s - hint # {}) THEN n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + IF s - hint # {} THEN s := s - hint END; + WHILE ~(n IN s) DO INC(n) END + ELSE + s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4); + IF s1 # {} THEN s := s1 END; + WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END; + IF ~(n IN s) THEN n := n + 4 END + END; + EXCL(BReg, n); EXCL(WReg, n MOD 4) + | Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16: + s := WReg - stop; + IF high IN stop THEN s := s * {0..3} END; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END; + s1 := s - hint; + IF high IN hint THEN s1 := s1 * {0..3} END; + IF s1 # {} THEN s := s1 END; + IF 0 IN s THEN n := 0 + ELSIF 2 IN s THEN n := 2 + ELSIF 6 IN s THEN n := 6 + ELSIF 7 IN s THEN n := 7 + ELSIF 1 IN s THEN n := 1 + ELSE n := 3 + END; + EXCL(WReg, n); + IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END + | Real32, Real64: + IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END; + DEC(FReg); n := 0 + END; + DevCPL486.MakeReg(x, n, f); + END GetReg; + + PROCEDURE FreeReg (n, f: INTEGER); + BEGIN + IF f <= Int8 THEN + INCL(BReg, n); + IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END + ELSIF f IN realSet THEN + INC(FReg) + ELSIF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeReg; + + PROCEDURE FreeWReg (n: INTEGER); + BEGIN + IF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeWReg; + + PROCEDURE Free* (VAR x: DevCPL486.Item); + BEGIN + CASE x.mode OF + | Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END + | Ind: FreeWReg(x.reg); + IF x.scale # 0 THEN FreeWReg(x.index) END + | Reg: FreeReg(x.reg, x.form); + IF x.form = Int64 THEN FreeWReg(x.index) END + ELSE + END + END Free; + + PROCEDURE FreeHi (VAR x: DevCPL486.Item); (* free hi byte of word reg *) + BEGIN + IF x.mode = Reg THEN + IF x.form = Int64 THEN FreeWReg(x.index) + ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4) + END + END + END FreeHi; + + PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN; (* x.mode = Reg *) + BEGIN + IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END; + IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop)) + ELSIF x.form IN realSet THEN RETURN ~(float IN stop) + ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop) + ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop)) + END + END Fits; + + PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR rh: DevCPL486.Item; + BEGIN + IF f = Int64 THEN + GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r); + GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh); + r.form := Int64; r.index := rh.reg + ELSE + IF f < Int16 THEN INCL(stop, high) END; + GetReg(r, f, hint, stop); DevCPL486.GenPop(r) + END + END Pop; + + PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + + PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET); (* = Assert(x, hint, stop + {mem, stk}) *) + VAR r: DevCPL486.Item; f: BYTE; + BEGIN + f := x.typ.form; + IF x.mode = Con THEN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END; + IF con IN stop THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + ELSIF x.mode = Stk THEN + IF f IN realSet THEN + GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form) + ELSE + Pop(r, f, hint, stop) + END; + x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f + ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN + Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := Int32 + ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + Free(x); GetReg(r, f, hint, stop); + IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + END Load; + + PROCEDURE Push* (VAR x: DevCPL486.Item); + VAR y: DevCPL486.Item; + BEGIN + IF x.form IN realSet THEN + Load(x, {}, {}); DecStack(x.form); + Free(x); x.mode := Stk; + IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END; + DevCPL486.GenFStore(x, TRUE) + ELSIF x.form = Int64 THEN + Free(x); x.form := Int32; y := x; + IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END; + DevCPL486.GenPush(y); DevCPL486.GenPush(x); + x.mode := Stk; x.form := Int64 + ELSE + IF x.form < Int16 THEN Load(x, {}, {high}) + ELSIF x.form = Int16 THEN Load(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x); x.mode := Stk + END + END Push; + + PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN + IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x) + ELSE Load(x, hint, stop); + END + ELSE + CASE x.mode OF + | Var, VarPar: IF ~(mem IN stop) THEN RETURN END + | Con: IF ~(con IN stop) THEN RETURN END + | Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Stk: IF ~(stk IN stop) THEN RETURN END + | Reg: IF Fits(x, stop) THEN RETURN END + ELSE RETURN + END; + IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x) + ELSE Load(x, hint, stop) + END + END + END Assert; + + (*------------------------------------------------*) + + PROCEDURE LoadR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN + Free(x); DevCPL486.GenFLoad(x); + IF x.mode = Stk THEN IncStack(x.form) END; + GetReg(x, Real32, {}, {}) + END + END LoadR; + + PROCEDURE PushR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN LoadR(x) END; + DecStack(x.form); + Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE) + END PushR; + + PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSE + Free(x); GetReg(r, x.form, hint, stop); + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg + END + END LoadW; + + PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop); + IF (x.form < Int32) OR (x.form = Char16) THEN + r := x; x.form := Int32; DevCPL486.GenExtMove(r, x) + END + ELSE + Free(x); + IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END; + IF x.mode = Con THEN x.form := r.form END; + IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := r.form + END + END LoadL; + + PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r, rh, c: DevCPL486.Item; offs: INTEGER; + BEGIN + IF x.form = Int64 THEN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSIF x.mode = Reg THEN + FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop); + FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop); + x.form := Int32; DevCPL486.GenMove(x, r); + x.reg := x.index; DevCPL486.GenMove(x, rh); + x.reg := r.reg; x.index := rh.reg + ELSE + GetReg(rh, Int32, hint, stop + {AX}); + Free(x); + GetReg(r, Int32, hint, stop); + x.form := Int32; offs := x.offset; + IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END; + DevCPL486.GenMove(x, rh); + x.offset := offs; + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.index := rh.reg + END + ELSE + LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh); + x.index := rh.reg + END; + x.form := Int64 + END LoadLong; + + (*------------------------------------------------*) + + PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET); + BEGIN + ASSERT(x.mode = Reg); + GetReg(y, x.form, hint, stop); + DevCPL486.GenMove(x, y) + END CopyReg; + + PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = DInd THEN + x.mode := Ind + ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN + x.mode := Reg + ELSE + Free(x); GetReg(r, Pointer, hint, stop); + IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := Pointer + END; + x.form := Pointer; x.typ := DevCPT.anyptrtyp; + Assert(x, hint, stop) + END GetAdr; + + PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN); + VAR r, v: DevCPL486.Item; + BEGIN + IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer + ELSIF niltest THEN + GetAdr(x, {}, {mem, stk}); + DevCPL486.MakeReg(r, AX, Int32); + v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg; + DevCPL486.GenTest(r, v) + ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer + ELSE GetAdr(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x) + END PushAdr; + + PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET); + VAR n: BYTE; + BEGIN + a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ; + IF lev = DevCPL486.level THEN a.reg := BP + ELSE + a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev])); + WHILE n > 0 DO + a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n) + END + END + END LevelBase; + + PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *) + BEGIN + IF x.tmode = VarPar THEN + LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr; + ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind)); + len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32 + END; + INC(len.offset, typ.n * 4 + 4); + IF typ.sysflag = stackArray THEN len.offset := -4 END + END LenDesc; + + PROCEDURE Tag* (VAR x, tag: DevCPL486.Item); + VAR typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final type *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ) + ELSIF x.typ.form = Pointer THEN + ASSERT(x.mode = Reg); + tag.mode := Ind; tag.reg := x.reg; tag.offset := -4; + IF x.typ.sysflag = interface THEN tag.offset := 0 END + ELSIF x.tmode = VarPar THEN + LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4; + Free(tag) (* ??? *) + ELSIF x.tmode = Ind THEN + ASSERT(x.mode = Ind); + tag := x; tag.offset := -4 + ELSE + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ) + END; + tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp + END Tag; + + PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER; + BEGIN + WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END; + IF typ # NIL THEN RETURN typ.n + ELSE RETURN 0 + END + END NumOfIntProc; + + PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN; + VAR fld: DevCPT.Object; + BEGIN + WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END; + IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + REPEAT + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) + OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END; + fld := fld.link + END; + typ := typ.BaseTyp + UNTIL typ = NIL + END; + RETURN FALSE + END ContainsIPtrs; + + PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item); + VAR cv: DevCPT.Const; + BEGIN + IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END; + cv := DevCPT.NewConst(); + cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str; + DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp + END GuidFromString; + + PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END + END; + IF x.mode # Reg THEN + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + ELSE r := x + END; + IF nilTest THEN + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + DevCPL486.GenPush(r); p := r; + IF x.mode # Reg THEN Free(r) END; + GetReg(r, Pointer, {}, {}); + p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r); + p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPAddRef; + + PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END + END; + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + DevCPL486.MakeConst(c, 0, Pointer); + IF nilTest THEN + DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nilSet THEN DevCPL486.GenMove(c, p) END; + DevCPL486.GenPush(r); + p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r); + p.offset := 8; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPRelease; + + PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN + DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ; + WHILE typ.comp = DynArr DO (* complete dynamic array iterations *) + LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + END; + n := x.scale; i := 0; + WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END; + IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *) + DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n + END + END; + CASE x.mode OF + Var, VarPar: + lev := x.obj.mnolev; + IF lev <= 0 THEN + x.mode := Abs + ELSE + LevelBase(y, lev, hint, stop); + IF x.mode # VarPar THEN + x.mode := Ind + ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN + x.mode := DInd; x.offset := x.obj.adr + ELSE + y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind + END; + x.reg := y.reg + END; + x.form := x.typ.form + | LProc, XProc, IProc: + x.mode := Con; x.offset := 0; x.form := ProcTyp + | TProc, CProc: + x.form := ProcTyp + | Ind, Abs, Stk, Reg: + IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END + END + END Prepare; + + PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object); + BEGIN + INC(x.offset, field.adr); x.tmode := Con + END Field; + + PROCEDURE DeRef* (VAR x: DevCPL486.Item); + VAR btyp: DevCPT.Struct; + BEGIN + x.mode := Ind; x.tmode := Ind; x.scale := 0; + btyp := x.typ.BaseTyp; + IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0 + ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size + ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4 + ELSE x.offset := 0 + END + END DeRef; + + PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET); (* x[y] *) + VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER; + BEGIN + btyp := x.typ.BaseTyp; elsize := btyp.size; + IF elsize = 0 THEN Free(y) + ELSIF x.typ.comp = Array THEN + len.mode := Con; len.obj := NIL; + IF y.mode = Con THEN + INC(x.offset, y.offset * elsize) + ELSE + Load(y, hint, stop + {mem, stk, short}); + IF inxchk THEN + DevCPL486.MakeConst(len, x.typ.n, Int32); + DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap) + END; + IF x.scale = 0 THEN x.index := y.reg + ELSE + IF x.scale MOD elsize # 0 THEN + IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4 + ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2 + ELSE elsize := 1 + END; + DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32); + DevCPL486.GenMul(len, y, FALSE) + END; + DevCPL486.MakeConst(len, x.scale DIV elsize, Int32); + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END; + x.scale := elsize + END; + x.tmode := Con + ELSE (* x.typ.comp = DynArr *) + IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END; + LenDesc(x, len, x.typ); + IF x.scale # 0 THEN + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE) + END; + IF (y.mode # Con) OR (y.offset # 0) THEN + IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN + Load(y, hint, stop + {mem, stk, con, short}) + ELSE y.form := Int32 + END; + IF inxchk & ~x.typ.untagged THEN + DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap) + END; + IF (y.mode = Con) & (btyp.comp # DynArr) THEN + INC(x.offset, y.offset * elsize) + ELSIF x.scale = 0 THEN + WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END; + x.index := y.reg; x.scale := btyp.size + ELSE + DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END + END; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END + END + END Index; + + PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN); + VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END; + IF ~guard & typ.untagged THEN DevCPM.err(139) + ELSIF ~guard OR typchk & ~typ.untagged THEN + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + IF (x.typ.form = Pointer) & (x.mode # Reg) THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag) + ELSE Tag(x, tag) + END; + IF ~guard THEN Free(x) END; + IF ~equal THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r); + tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev + END; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + IF guard THEN + IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END + ELSE setCC(x, eql, FALSE, FALSE) + END + END + END + END TypTest; + + PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct); + VAR tag, tdes: DevCPL486.Item; + BEGIN + (* tag must be in AX ! *) + IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END; + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + setCC(x, eql, FALSE, FALSE) + END + END ShortTypTest; + + PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER); + VAR c: DevCPL486.Item; + BEGIN + ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4)); + IF ranchk & (x.mode # Con) THEN + DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x); + IF min # 0 THEN + DevCPL486.GenAssert(ccLE, ranTrap); + c.offset := min; DevCPL486.GenComp(c, x); + DevCPL486.GenAssert(ccGE, ranTrap) + ELSIF max # 0 THEN + DevCPL486.GenAssert(ccBE, ranTrap) + ELSE + DevCPL486.GenAssert(ccNS, ranTrap) + END + END + END Check; + + PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN); + VAR c: DevCPL486.Item; local: DevCPL486.Label; + BEGIN + IF useSt1 THEN DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + ELSE DevCPL486.GenFMOp(1C0H); (* FLD ST0 *) + END; + DevCPL486.GenFMOp(1FCH); (* FRNDINT *) + DevCPL486.GenFMOp(0D1H); (* FCOM *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.AllocConst(c, DevCPL486.one, Real32); + DevCPL486.GenFDOp(FSUB, c); + DevCPL486.SetLabel(local); + END Floor; + + PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET); + BEGIN + IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END; + DevCPL486.GenFStore(x, TRUE); + IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END + END Entier; + + PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET); (* x := y *) + (* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *) + VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item; + BEGIN + f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk}); + IF y.form IN {Real32, Real64} THEN + IF f IN {Real32, Real64} THEN + IF m = Undef THEN + IF (y.form = Real64) & (f = Real32) THEN + IF y.mode # Reg THEN LoadR(y) END; + Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE) + END + ELSE + IF y.mode # Reg THEN LoadR(y) END; + IF m = Stk THEN DecStack(f) END; + IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END; + END + ELSE (* x not real *) + IF sysval THEN + IF y.mode = Reg THEN Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN + x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f + ELSE + ASSERT(y.form # Real64); + DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32; + IF m # Stk THEN + Pop(y, y.form, hint, stop); + IF f < Int16 THEN ASSERT(y.reg < 4) END; + y.form := f; + IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END + END + END + ELSE (* y.mode # Reg *) + y.form := f; + IF m # Undef THEN LoadW(y, hint, stop); Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END + END + END + ELSE (* not sysval *) + IF y.mode # Reg THEN LoadR(y) END; + Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN + Entier(x, y.typ, hint, stop); + ELSE + DecStack(f); y.mode := Stk; + IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END; + IF m = Stk THEN Entier(y, y.typ, {}, {}) + ELSIF m = Undef THEN Entier(y, y.typ, hint, stop) + ELSE Entier(y, y.typ, hint, stop + {stk}) + END; + IF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y) + END; + y.form := f; + IF (m # Undef) & (m # Stk) THEN + IF f = Int64 THEN + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + Free(y); DevCPL486.GenMove(y, x); + END + END + END + END + END + ELSE (* y not real *) + IF sysval THEN + IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END; + IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END + ELSE + CASE y.form OF + | Byte, Bool: + IF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char8: + IF f = Int8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, 0, 0) + ELSIF f = Char16 THEN (* ok *) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int32 THEN LoadL(y, hint, stop) + END + | Int8: + IF f = Char8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Int16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 0) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop) + END + | Int32, Set, Pointer, ProcTyp: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, -32768, 32767) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + END + | Int64: + IF f IN {Bool..Int32, Char16} THEN + (* make range checks !!! *) + FreeHi(y) + END + END + END; + IF f IN {Real32, Real64} THEN + IF sysval THEN + IF (m # Undef) & (m # Reg) THEN + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) + ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f + END + ELSE + IF y.mode = Reg THEN Push(y) END; + y.form := f; + IF m = Reg THEN LoadR(y) END + END + ELSE (* not sysval *) (* int -> float *) + IF y.mode = Reg THEN Push(y) END; + IF m = Stk THEN + Free(y); DevCPL486.GenFLoad(y); s := -4; + IF f = Real64 THEN DEC(s, 4) END; + IF y.mode = Stk THEN + IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END + END; + IF s # 0 THEN AdjustStack(s) END; + GetReg(y, Real32, {}, {}); + Free(y); DevCPL486.GenFStore(x, TRUE) + ELSIF m = Reg THEN + LoadR(y) + ELSIF m # Undef THEN + LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE) + END + END + ELSE + y.form := f; + IF m = Stk THEN + IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END; + Push(y) + ELSIF m # Undef THEN + IF f = Int64 THEN + IF y.mode # Reg THEN LoadLong(y, hint, stop) END; + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); DevCPL486.GenMove(y, x) + END + END + END + END + END ConvMove; + + PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET); (* size >= 0: sysval *) + VAR y: DevCPL486.Item; + BEGIN + ASSERT(x.mode # Con); + IF (size >= 0) + & ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4)) + OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END; +(* + IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.form IN {Comp, Int64})) THEN DevCPM.err(220) END; +*) + y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop) + END Convert; + + PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET); + VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item; + BEGIN + IF mem IN stop THEN GetReg(x, Bool, hint, stop) END; + IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *) + DevCPL486.GenSetCC(y.offset, x) + ELSE + end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl; + DevCPL486.GenJump(y.offset, T1, TRUE); (* T1 to enable short jump *) + DevCPL486.SetLabel(F); + DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x); + DevCPL486.GenJump(ccAlways, end, TRUE); + DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1); + DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x); + DevCPL486.SetLabel(end) + END; + IF x.mode # Reg THEN Free(x) END + END LoadCond; + + PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con)); + CASE subcl OF + | eql..geq: + DevCPL486.GenComp(y, x); Free(x); + setCC(x, subcl, rev, x.typ.form IN {Int8..Int32}) + | times: + IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END + | slash: + DevCPL486.GenXor(y, x) + | plus: + IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END + | minus, msk: + IF (x.form = Set) OR (subcl = msk) THEN (* and not *) + IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x) (* y and not x *) + ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x) (* x and y' *) + ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x) (* x and not y *) + ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x) (* not (not x or y) *) + END + ELSE (* minus *) + IF rev THEN (* y - x *) + IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x) + ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk) (* ??? *) + END + ELSE (* x - y *) + DevCPL486.GenSub(y, x, ovflchk) + END + END + | min, max: + local := DevCPL486.NewLbl; + DevCPL486.GenComp(y, x); + IF subcl = min THEN + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE) + ELSE DevCPL486.GenJump(ccLE, local, TRUE) + END + ELSE + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE) + ELSE DevCPL486.GenJump(ccGE, local, TRUE) + END + END; + DevCPL486.GenMove(y, x); + DevCPL486.SetLabel(local) + END; + Free(y); + IF x.mode # Reg THEN Free(x) END + END IntDOp; + + PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN); (* INC(x, y) or DEC(x, y) *) + BEGIN + ASSERT(x.form = Int64); + IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END; + Free(x); Free(y); x.form := Int32; y.form := Int32; + IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END; + INC(x.offset, 4); + IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END; + IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END; + END LargeInc; + + PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; a, b: DevCPL486.Item; + BEGIN + ASSERT(x.mode = Reg); + IF y.form = Int64 THEN LoadR(y) END; + IF y.mode = Reg THEN rev := ~rev END; + CASE subcl OF + | eql..geq: DevCPL486.GenFDOp(FCOMP, y) + | times: DevCPL486.GenFDOp(FMUL, y) + | slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END + | plus: DevCPL486.GenFDOp(FADD, y) + | minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END + | min, max: + IF y.mode = Reg THEN + DevCPL486.GenFMOp(0D1H); (* FCOM ST1 *) + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END; + DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D8H) (* FSTP ST0 *) + ELSE + DevCPL486.GenFDOp(FCOM, y); + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END; + DevCPL486.GenFMOp(5D8H); (* FSTP ST0 *) + DevCPL486.GenFLoad(y); + DevCPL486.SetLabel(local) + END + (* largeint support *) + | div: + IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END; + Floor(y, FALSE) + | mod: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1F8H); (* FPREM *) + DevCPL486.GenFMOp(1E4H); (* FTST *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX}); + DevCPL486.GenMove(a, b); + DevCPL486.GenFMOp(0D1H); (* FCOM *) + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenXor(b, a); Free(b); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.GenFMOp(0C1H); (* FADD ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + | ash: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1FDH); (* FSCALE *) + Floor(y, TRUE) + END; + IF y.mode = Stk THEN IncStack(y.form) END; + Free(y); + IF (subcl >= eql) & (subcl <= geq) THEN + Free(x); CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + setCC(x, subcl, rev, FALSE) + END + END FloatDOp; + + PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + VAR L: DevCPL486.Label; c: DevCPL486.Item; + BEGIN + CASE subcl OF + | minus: + IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END + | abs: + L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccNS, L, TRUE); + DevCPL486.GenNeg(x, ovflchk); + DevCPL486.SetLabel(L) + | cap: + DevCPL486.MakeConst(c, -1 - 20H, x.form); + DevCPL486.GenAnd(c, x) + | not: + DevCPL486.MakeConst(c, 1, x.form); + DevCPL486.GenXor(c, x) + END; + IF x.mode # Reg THEN Free(x) END + END IntMOp; + + PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + BEGIN + ASSERT(x.mode = Reg); + IF subcl = minus THEN DevCPL486.GenFMOp(FCHS) + ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS) + END + END FloatMOp; + + PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET); + (* range neg result + F F {x} + F T -{x} + T F {x..31} + T T -{0..x} *) + VAR c, r: DevCPL486.Item; val: INTEGER; + BEGIN + IF x.mode = Con THEN + IF range THEN + IF neg THEN val := -2 ELSE val := -1 END; + x.offset := SYSTEM.LSH(val, x.offset) + ELSE + val := 1; x.offset := SYSTEM.LSH(val, x.offset); + IF neg THEN x.offset := -1 - x.offset END + END + ELSE + Check(x, 0, 31); + IF neg THEN val := -2 + ELSIF range THEN val := -1 + ELSE val := 1 + END; + DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r); + IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END; + Free(x); x.reg := r.reg + END; + x.typ := DevCPT.settyp; x.form := Set + END MakeSet; + + PROCEDURE MakeCond* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Con THEN + setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE) + ELSE + DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); Free(x); + setCC(x, neq, FALSE, FALSE) + END + END MakeCond; + + PROCEDURE Not* (VAR x: DevCPL486.Item); + VAR a: INTEGER; + BEGIN + x.offset := Inverted(x.offset); (* invert cc *) + END Not; + + PROCEDURE Odd* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END; + Free(x); DevCPL486.MakeConst(c, 1, x.form); + IF x.mode = Reg THEN + IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END; + DevCPL486.GenAnd(c, x) + ELSE + c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x) + END; + setCC(x, neq, FALSE, FALSE) + END Odd; + + PROCEDURE In* (VAR x, y: DevCPL486.Item); + BEGIN + IF y.form = Set THEN Check(x, 0, 31) END; + DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y); + setCC(x, lss, FALSE, FALSE); (* carry set *) + END In; + + PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE); (* ASH, LSH, ROT *) + VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER; + BEGIN + IF subcl = ash THEN opl := SHL; opr := SAR + ELSIF subcl = lsh THEN opl := SHL; opr := SHR + ELSE opl := ROL; opr := ROR + END; + IF y.mode = Con THEN + IF y.offset > 0 THEN + DevCPL486.GenShiftOp(opl, y, x) + ELSIF y.offset < 0 THEN + y.offset := -y.offset; + DevCPL486.GenShiftOp(opr, y, x) + END + ELSE + ASSERT(y.mode = Reg); + Check(y, -31, 31); + L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl; + DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y); + DevCPL486.GenJump(ccNS, L1, TRUE); + DevCPL486.GenNeg(y, FALSE); + DevCPL486.GenShiftOp(opr, y, x); + DevCPL486.GenJump(ccAlways, L2, TRUE); + DevCPL486.SetLabel(L1); + DevCPL486.GenShiftOp(opl, y, x); + DevCPL486.SetLabel(L2); + Free(y) + END; + IF x.mode # Reg THEN Free(x) END + END Shift; + + PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN); + VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN; + BEGIN + ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE; + IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END; + DevCPL486.GenDiv(y, mod, pos); Free(y); + IF mod THEN + r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *) (* ??? *) + END + END DivMod; + + PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct); (* x := Mem[x+offset] *) + BEGIN + IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset) + ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset + END; + x.scale := 0; x.typ := typ; x.form := typ.form + END Mem; + + PROCEDURE SysMove* (VAR len: DevCPL486.Item); (* implementation of SYSTEM.MOVE *) + BEGIN + IF len.mode = Con THEN + IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END + ELSE + Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len) + END; + FreeWReg(SI); FreeWReg(DI) + END SysMove; + + PROCEDURE Len* (VAR x, y: DevCPL486.Item); + VAR typ: DevCPT.Struct; dim: INTEGER; + BEGIN + dim := y.offset; typ := x.typ; + IF typ.untagged THEN DevCPM.err(136) END; + WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END; + LenDesc(x, x, typ); + END Len; + + PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER; + BEGIN + CASE x.form OF + | String8, VString8: RETURN 1 + | String16, VString16: RETURN 2 + | VString16to8: RETURN 0 + | Comp: RETURN x.typ.BaseTyp.size + END + END StringWSize; + + PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN); + VAR sw, dw: INTEGER; + BEGIN + CheckAv(CX); + IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN + DevCPL486.GenBlockComp(4, 4) + ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index) + ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index) + ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index) + ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index) + ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x)) + END; + FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE); + END CmpString; + + PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item); + VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct; + BEGIN + atyp := y.typ; + WHILE ftyp.comp = DynArr DO + IF ftyp.BaseTyp = DevCPT.bytetyp THEN + IF atyp.comp = DynArr THEN + IF atyp.untagged THEN DevCPM.err(137) END; + LenDesc(y, len, atyp); + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z); + len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp; + WHILE atyp.comp = DynArr DO + LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE); + IF y.tmode = VarPar THEN Free(z) END; (* ??? *) + atyp := atyp.BaseTyp + END; + DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE); + Free(len) + ELSE + DevCPL486.MakeConst(len, atyp.size, Int32) + END + ELSE + IF atyp.comp = DynArr THEN LenDesc(y, len, atyp); + IF atyp.untagged THEN DevCPM.err(137) END; + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + ELSE DevCPL486.MakeConst(len, atyp.n, Int32) + END + END; + DevCPL486.GenPush(len); + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END + END VarParDynArr; + + PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *) + BEGIN + IF y.mode = Con THEN + IF y.form IN {Real32, Real64} THEN + DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {}); + IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END (* ??? move const *) + ELSIF x.form = Int64 THEN + ASSERT(x.mode IN {Ind, Abs}); + y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x); + y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x); + DEC(x.offset, 4); x.form := Int64 + ELSE + DevCPL486.GenMove(y, x) + END + ELSE + IF y.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(x.form = Pointer); + GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer + END; + IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END; + ConvMove(x, y, FALSE, {}, {}) + END; + Free(x) + END Assign; + + PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET); + VAR c: DevCPL486.Item; + BEGIN + IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSE len.mode := Con + END; + len.typ := DevCPT.int32typ + END ArrayLen; + +(* +(!) src dest zero +sx = sy x b y b +SHORT(lx) = sy x b+ x w y b +SHORT(lx) = SHORT(ly) x b+ x w y b+ + +lx = ly x w y w +LONG(sx) = ly x b y w * +LONG(SHORT(lx)) = ly x b+ x w* y w * + +sx := sy y b x b +sx := SHORT(ly) y b+ y w x b + +lx := ly y w x w +lx := LONG(sy) y b x w * +lx := LONG(SHORT(ly)) y b+ y w* x w * +(!)*) + + PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *) + BEGIN + IF (x.typ.comp = DynArr) & x.typ.untagged THEN + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1) + ELSE + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0) + END; + FreeWReg(SI); FreeWReg(DI) + END AddCopy; + + PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *) + VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item; + BEGIN + sx := x.typ.size; CheckAv(CX); + IF y.form IN {String8, String16} THEN + sy := y.index * y.typ.BaseTyp.size; + IF x.typ.comp = Array THEN (* adjust size for optimal performance *) + sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4; + IF sy4 <= sx THEN sy := sy4 + ELSIF sy2 <= sx THEN sy := sy2 + ELSIF sy > sx THEN DevCPM.err(114); sy := 1 + END + ELSIF inxchk & ~x.typ.untagged THEN (* check array length *) + Free(x); LenDesc(x, c, x.typ); + DevCPL486.MakeConst(y, y.index, Int32); + DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap); + Free(c) + END; + DevCPL486.GenBlockMove(1, sy) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1) + ELSE + Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c); + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0) + END + ELSIF y.form IN {VString16to8, VString8, VString16} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + ASSERT(y.mode # Stk) + ELSIF short THEN (* COPY *) + sy := y.typ.size; + IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END; + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + IF y.mode = Stk THEN AdjustStack(sy) END + ELSE (* := *) + IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END; + IF y.mode = Stk THEN AdjustStack(sy) END + END; + FreeWReg(SI); FreeWReg(DI) + END Copy; + + PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + CheckAv(AX); CheckAv(CX); + DevCPL486.GenStringLength(typ.BaseTyp.size, -1); + Free(x); GetReg(x, Int32, {}, wreg - {CX}); + DevCPL486.GenNot(x); + IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END; + FreeWReg(DI) + END StrLen; + + PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); (* z := z * y *) + VAR c: DevCPL486.Item; + BEGIN + IF y.mode = Con THEN fact := fact * y.offset + ELSE + IF ranchk OR inxchk THEN + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap) + END; + DevCPL486.GenPush(y); + IF z.mode = Con THEN z := y + ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y) + END + END + END MulDim; + + PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *) + (* y const or on stack *) + VAR z: DevCPL486.Item; end: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) & (x.form = Pointer)); + z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32; + IF y.mode = Con THEN y.form := Int32 + ELSE Pop(y, Int32, {}, {}) + END; + end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE); (* flags set in New *) + DevCPL486.GenMove(y, z); + DevCPL486.SetLabel(end); + IF y.mode = Reg THEN Free(y) END + END SetDim; + + PROCEDURE SysNew* (VAR x: DevCPL486.Item); + BEGIN + DevCPM.err(141) + END SysNew; + + PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER); + (* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *) + VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label; + BEGIN + typ := x.typ.BaseTyp; + IF typ.untagged THEN DevCPM.err(138) END; + IF typ.comp = Record THEN (* call to Kernel.NewRec(tag: Tag): ADDRESS *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ); + IF ContainsIPtrs(typ) THEN INC(tag.offset) END; + DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewRec; + ELSE eltyp := typ.BaseTyp; + IF typ.comp = Array THEN + nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n + ELSE (* DynArr *) + nofdim := typ.n+1; + WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END + END ; + WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END; + IF eltyp.comp = Record THEN + IF eltyp.untagged THEN DevCPM.err(138) END; + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp); + IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END; + ELSIF eltyp.form = Pointer THEN + IF ~eltyp.untagged THEN + DevCPL486.MakeConst(tag, 0, Pointer) (* special TDesc in Kernel for ARRAY OF pointer *) + ELSIF eltyp.sysflag = interface THEN + DevCPL486.MakeConst(tag, -1, Pointer) (* special TDesc in Kernel for ARRAY OF interface pointer *) + ELSE + DevCPL486.MakeConst(tag, 12, Pointer) + END + ELSE (* eltyp is pointerless basic type *) + CASE eltyp.form OF + | Undef, Byte, Char8: n := 1; + | Int16: n := 2; + | Int8: n := 3; + | Int32: n := 4; + | Bool: n := 5; + | Set: n := 6; + | Real32: n := 7; + | Real64: n := 8; + | Char16: n := 9; + | Int64: n := 10; + | ProcTyp: n := 11; + END; + DevCPL486.MakeConst(tag, n, Pointer) +(* + DevCPL486.MakeConst(tag, eltyp.size, Pointer) +*) + END; + IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL + ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk) + END; + DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p); + DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewArr; + END; + DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX}); + IF typ.comp = DynArr THEN (* set flags for nil test *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x) + ELSIF typ.comp = Record THEN + n := NumOfIntProc(typ); + IF n > 0 THEN (* interface method table pointer setup *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE); + tag.offset := - 4 * (n + numPreIntProc); + p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer; + DevCPL486.GenMove(tag, p); + IF nofel.mode # Con THEN (* unk pointer setup *) + p.offset := 8; + DevCPL486.GenMove(nofel, p); + Free(nofel) + END; + DevCPL486.SetLabel(lbl); + END + END + END New; + + PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item); (* returns tag if rec *) + VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct; + BEGIN + par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form; + IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END; + IF ap.typ = DevCPT.niltyp THEN + IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN + DevCPM.err(142) + END; + DevCPL486.GenPush(ap) + ELSIF par.typ.comp = DynArr THEN + IF ap.form IN {String8, String16} THEN + IF ~par.typ.untagged THEN + DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c) + END; + ap.mode := Con; DevCPL486.GenPush(ap); + ELSIF ap.form IN {VString8, VString16} THEN + DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a); + IF ~par.typ.untagged THEN + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c); + Free(ap); StrLen(c, ap.typ, TRUE); + DevCPL486.GenPush(c); Free(c) + END; + DevCPL486.GenPush(a) + ELSE + IF ~par.typ.untagged THEN + IF ap.typ.comp = DynArr THEN niltest := FALSE END; (* ap dereferenced for length descriptor *) + VarParDynArr(par.typ, ap) + END; + PushAdr(ap, niltest) + END + ELSIF fp.mode = VarPar THEN + recTyp := ap.typ; + IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END; + IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN + Tag(ap, tag); + IF rec & (tag.mode # Con) THEN + GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c + END; + DevCPL486.GenPush(tag); + IF tag.mode # Con THEN niltest := FALSE END; + PushAdr(ap, niltest); + IF rec THEN Free(tag) END + ELSE PushAdr(ap, niltest) + END; + tag.typ := recTyp + ELSIF par.form = Comp THEN + s := par.typ.size; + IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN + s := (s + 3) DIV 4 * 4; AdjustStack(-s); + IF ap.form IN {String8, String16} THEN + IF ap.index > 1 THEN (* nonempty string *) + ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4; + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenBlockMove(1, ss); + ELSE + ss := 0; + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c) + END; + IF s > ss THEN + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(1, s - ss) + END; + ELSE + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n); + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(StringWSize(par), 0) + END + ELSE + IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN (* empty string *) + AdjustStack((4 - s) DIV 4 * 4); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c) + ELSE + AdjustStack((-s) DIV 4 * 4); + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + IF ap.form IN {String8, String16} THEN + DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4) + ELSIF ap.form IN {VString8, VString16, VString16to8} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n) + ELSE + DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4) + END + END + END + ELSIF ap.mode = Con THEN + IF ap.form IN {Real32, Real64} THEN (* ??? push const *) + DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE) + ELSE + ap.form := Int32; + IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END; + DevCPL486.GenPush(ap) + END + ELSIF ap.typ.form = Pointer THEN + recTyp := ap.typ.BaseTyp; + IF rec THEN + Load(ap, {}, {}); Tag(ap, tag); + IF tag.mode = Con THEN (* explicit nil test needed *) + DevCPL486.MakeReg(a, AX, Int32); + c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg; + DevCPL486.GenTest(a, c) + END + END; + DevCPL486.GenPush(ap); Free(ap); + tag.typ := recTyp + ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(par.form = Pointer); + PushAdr(ap, FALSE) + ELSE + ConvMove(par, ap, FALSE, {}, {high}); + END + END Param; + + PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item); + VAR r: DevCPL486.Item; + BEGIN + DevCPL486.MakeReg(r, AX, proc.typ.form); (* don't allocate AX ! *) + IF res.mode = Con THEN + IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res); + ELSIF r.form = Int64 THEN + r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r); + r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r) + ELSE DevCPL486.GenMove(res, r); + END + ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(r.form = Pointer); + GetAdr(res, {}, wreg - {AX}) + ELSE + r.index := DX; (* for int64 *) + ConvMove(r, res, FALSE, wreg - {AX} + {high}, {}); + END; + Free(res) + END Result; + + PROCEDURE InitFpu; + VAR x: DevCPL486.Item; + BEGIN + DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x); + DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H); (* FLDCW 0(SP) *) + DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x); (* reset stack *) + END InitFpu; + + PROCEDURE PrepCall* (proc: DevCPT.Object); + VAR lev: BYTE; r: DevCPL486.Item; + BEGIN + lev := proc.mnolev; + IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r) + END + END PrepCall; + + PROCEDURE Call* (VAR x, tag: DevCPL486.Item); (* TProc: tag.typ = actual receiver type *) + VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object; + BEGIN + IF x.mode IN {LProc, XProc, IProc} THEN + lev := x.obj.mnolev; saved := FALSE; + IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN (* pass static link *) + n := imLevel[DevCPL486.level] - imLevel[lev]; + IF n > 0 THEN + saved := TRUE; + y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4; + DevCPL486.MakeReg(r, BX, Pointer); + WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END + END + END; + DevCPL486.GenCall(x); + IF x.obj.sysflag = ccall THEN (* remove parameters *) + p := x.obj.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + IF saved THEN DevCPL486.GenPop(r) END; + ELSIF x.mode = TProc THEN + IF x.scale = 1 THEN (* super *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp) + ELSIF x.scale = 2 THEN (* static call *) + DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + tag.obj := DevCPE.TypeObj(typ) + ELSIF x.scale = 3 THEN (* interface method call *) + DevCPM.err(200) + END; + IF tag.mode = Con THEN + y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0 + ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final method *) + y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0; + IF tag.mode = Ind THEN (* nil test *) + DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag) + END + ELSE + IF tag.mode = Reg THEN y.reg := tag.reg + ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y) + END; + y.mode := Ind; y.offset := 0; y.scale := 0 + END; + IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset + ELSIF tag.typ.untagged THEN DevCPM.err(140) + ELSE + IF x.obj.link.typ.sysflag = interface THEN (* correct method number *) + x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset + END; + INC(y.offset, Mth0Offset - 4 * x.offset) + END; + DevCPL486.GenCall(y); Free(y) + ELSIF x.mode = CProc THEN + IF x.obj.link # NIL THEN (* tag = first param *) + IF x.obj.link.mode = VarPar THEN + GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag) + ELSE + (* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *) + Result(x.obj.link, tag) (* use result load for first parameter *) + END + END; + i := 1; n := ORD(x.obj.conval.ext^[0]); + WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END + ELSE (* proc var *) + DevCPL486.GenCall(x); Free(x); + IF x.typ.sysflag = ccall THEN (* remove parameters *) + p := x.typ.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + x.typ := x.typ.BaseTyp + END; + IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128) + & ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN (* restore fpu *) + InitFpu + END; + CheckReg; + IF x.typ.form = Int64 THEN + GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX}); + x.index := y.reg; x.form := Int64 + ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high}) + END + END Call; + + PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct); (* needs CX, SI, DI *) + VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct; + BEGIN + IF typ.untagged THEN DevCPM.err(-137) END; + ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer; + DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32); + DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp + END; + ptr.offset := adr; DevCPL486.GenMove(ptr, src); + DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE); + (* CX = length in bytes *) + StackAlloc; + (* CX = length in 32bit words *) + DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr); + DevCPL486.GenBlockMove(4, 0) (* 32bit moves *) + END CopyDynArray; + + PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER); + VAR i, j, x: INTEGER; + BEGIN + (* align *) + i := 1; + WHILE i < n DO + x := tab[i]; j := i-1; + WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END; + tab[j+1] := x; INC(i) + END; + (* eliminate equals *) + i := 1; j := 1; + WHILE i < n DO + IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END; + INC(i) + END; + n := j + END Sort; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form IN {Pointer, ProcTyp} THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END; + INC(num); + IF adr MOD 4 # 0 THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END; + INC(num) + END + ELSIF typ.comp = Record THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.name^ = DevCPM.HdPtrName) OR + (fld.name^ = DevCPM.HdUtPtrName) OR + (fld.name^ = DevCPM.HdProcName) THEN + FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num) + ELSE FindPtrs(fld.typ, fld.adr + adr, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, num); + IF num # i THEN i := 1; + WHILE (i < n) & (num <= MaxPtrs) DO + INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i) + END + END + END + END + END FindPtrs; + + PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item); + VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct; + BEGIN + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr; + DevCPL486.MakeReg(y, DI, Int32); + IF par.typ.comp # DynArr THEN + DevCPL486.GenMove(x, y); + lbl := DevCPL486.NewLbl; + IF ODD(par.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zreg, y); + DevCPL486.GenJump(ccE, lbl, TRUE) + END; + size := par.typ.size; + IF size <= 16 THEN + x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0; + WHILE size > 0 DO + IF size = 1 THEN x.form := Int8; s := 1 + ELSIF size = 2 THEN x.form := Int16; s := 2 + ELSE x.form := Int32; s := 4 + END; + zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s) + END; + zreg.form := Int32 + ELSE + DevCPL486.GenBlockStore(1, size) + END; + DevCPL486.SetLabel(lbl) + ELSIF initializeDyn & ~par.typ.untagged THEN (* untagged open arrays not initialized !!! *) + DevCPL486.GenMove(x, y); + DevCPL486.MakeReg(len, CX, Int32); + INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *) + bt := par.typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp + END; + size := bt.size; + IF size MOD 4 = 0 THEN size := size DIV 4; s := 4 + ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2 + ELSE s := 1 + END; + DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE); + DevCPL486.GenBlockStore(s, 0) + END + END InitOutPar; + + PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); + VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER; + BEGIN + op := 0; par := proc.link; + WHILE par # NIL DO (* count out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END; + par := par.link + END; + DevCPL486.MakeConst(zero, 0, Int32); + IF (op = 0) & (size <= 8) THEN (* use PUSH 0 *) + WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END + ELSE + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); + IF size <= 32 THEN (* use PUSH reg *) + WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END + ELSE (* use string store *) + AdjustStack(-size); + DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + DevCPL486.GenBlockStore(1, size) + END; + IF op > 0 THEN + par := proc.link; + WHILE par # NIL DO (* init out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END; + par := par.link + END + END + END + END AllocAndInitAll; + + PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); (* needs AX *) + VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + IF ptrinit & (proc.scope # NIL) THEN + nofptrs := 0; obj := proc.scope.scope; (* local variables *) + WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO + FindPtrs(obj.typ, obj.adr, nofptrs); + obj := obj.link + END; + IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN + base := proc.conval.intval2; + Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END; + INC(i) + END; + IF a # base THEN INC(gaps) END; + IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN + DevCPL486.MakeConst(z, 0, Pointer); + IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END; + i := 0; a := size + base; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END; + DevCPL486.GenPush(z); INC(i) + END; + IF a # base THEN AdjustStack(base - a) END + ELSE + AdjustStack(-size); + DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z); + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END + ELSE + AdjustStack(-size) + END + ELSE + nofptrs := 0; + AdjustStack(-size) + END + END AllocAndInitPtrs1; + + PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER); (* needs AX, CX, DI *) + VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label; + BEGIN + IF ptrinit THEN + zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer); + IF nofptrs > MaxPtrs THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y); + DevCPL486.GenStrStore(size) + END; + obj := proc.link; (* parameters *) + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN + IF ~zeroed THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE + END; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + IF ODD(obj.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zero, y); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nofptrs > MaxPtrs THEN + DevCPL486.GenStrStore(obj.typ.size) + ELSE + Sort(ptrTab, nofptrs); + x.reg := DI; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END; + IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END + END + END; + obj := obj.link + END + END + END InitPtrs2; + + PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN; + VAR obj: DevCPT.Object; nofptrs: INTEGER; + BEGIN + IF ptrinit THEN + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN RETURN TRUE END + END; + obj := obj.link + END + END; + RETURN FALSE + END NeedOutPtrInit; + + PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN); + VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER; + BEGIN + procedureUsesFpu := useFpu; + SetReg({AX, CX, DX, SI, DI}); + DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer); + IF proc # NIL THEN (* enter proc *) + DevCPL486.SetLabel(proc.adr); + IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + adr := proc.conval.intval2; size := -adr; + IF isGuarded IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); + r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL; + DevCPL486.GenPush(r1); + intHandler.used := TRUE; + r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler; + DevCPL486.GenPush(r1); + r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenPush(r1); + DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1); + DEC(size, 24) + ELSE + IF imVar IN proc.conval.setval THEN (* set down pointer *) + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4) + END; + IF isCallback IN proc.conval.setval THEN + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8) + END + END; + ASSERT(size >= 0); + IF initializeAll THEN + AllocAndInitAll(proc, adr, size, np) + ELSE + AllocAndInitPtrs1(proc, adr, size, np); (* needs AX *) + InitPtrs2(proc, adr, size, np); (* needs AX, CX, DI *) + END; + par := proc.link; (* parameters *) + WHILE par # NIL DO + IF (par.mode = Var) & (par.typ.comp = DynArr) THEN + CopyDynArray(par.adr, par.typ) + END; + par := par.link + END; + IF imVar IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r) + END + END + ELSIF ~empty THEN (* enter module *) + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r) + END; + IF useFpu THEN InitFpu END + END Enter; + + PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN); + VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER; + BEGIN + DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer); + IF proc # NIL THEN (* exit proc *) + IF proc.sysflag # noframe THEN + IF ~empty OR NeedOutPtrInit(proc) THEN + IF isGuarded IN proc.conval.setval THEN (* remove exception frame *) + x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32; + DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r); + x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x); + size := 12 + ELSE + size := 0; + IF imVar IN proc.conval.setval THEN INC(size, 4) END; + IF isCallback IN proc.conval.setval THEN INC(size, 8) END + END; + IF size > 0 THEN + x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32; + DevCPL486.GenLoadAdr(x, sp); + IF size > 4 THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r) + END; + IF size # 8 THEN + DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r) + END + ELSE + DevCPL486.GenMove(fp, sp) + END; + DevCPL486.GenPop(fp) + END; + IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0) + ELSE DevCPL486.GenReturn(proc.conval.intval - 8) + END + END + ELSE (* exit module *) + IF ~empty THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r); + DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp) + END; + DevCPL486.GenReturn(0) + END + END Exit; + + PROCEDURE InstallStackAlloc*; + VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label; + BEGIN + IF stkAllocLbl # DevCPL486.NewLbl THEN + DevCPL486.SetLabel(stkAllocLbl); + DevCPL486.MakeReg(ax, AX, Int32); + DevCPL486.MakeReg(cx, CX, Int32); + DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.GenPush(ax); + DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE); + l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx); + DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax); + DevCPL486.GenSub(ax, sp, FALSE); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax); + l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE); + l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c); + DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE); + DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE); + DevCPL486.GenJump(ccNE, l1, TRUE); + DevCPL486.SetLabel(l2); + DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE); + x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1; + DevCPL486.GenMove(x, ax); + DevCPL486.GenPush(ax); + DevCPL486.GenMove(x, ax); + DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx); + DevCPL486.GenReturn(0); + name := "$StackAlloc"; DevCPE.OutRefName(name); + END + END InstallStackAlloc; + + PROCEDURE Trap* (n: INTEGER); + BEGIN + DevCPL486.GenAssert(ccNever, n) + END Trap; + + PROCEDURE Jump* (VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(ccAlways, L, FALSE) + END Jump; + + PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(x.offset, L, FALSE); + END JumpT; + + PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(Inverted(x.offset), L, FALSE); + END JumpF; + + PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label); + VAR c: DevCPL486.Item; n: INTEGER; + BEGIN + n := high - low + 1; + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE); + DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccAE, else, FALSE); + DevCPL486.GenCaseJump(x) + END CaseTableJump; + + PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + IF high = low THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END; + DevCPL486.GenJump(ccE, this, FALSE) + ELSIF first THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccL, else, FALSE); + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccLE, this, FALSE); + ELSE + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccG, else, FALSE); + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccGE, this, FALSE); + END + END CaseJump; + +BEGIN + imLevel[0] := 0 +END DevCPC486. diff --git a/Trurl-based/Dev/Mod/CPE.txt b/Trurl-based/Dev/Mod/CPE.txt new file mode 100644 index 0000000..f864ca7 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPE.txt @@ -0,0 +1,1105 @@ +MODULE DevCPE; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPE.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Dates, DevCPM, DevCPT; + + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* object modes *) + Fld = 4; Typ = 5; Head = 12; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* history of imported objects *) + inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6; + mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13; + mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3; + mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4; + mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13; + mInterface = 32; mGuid = 33; mResult = 34; + + (* sysflag *) + untagged = 1; noAlign = 3; union = 7; interface = 10; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* kernel flags *) + iptrs = 30; + + expAllFields = TRUE; + + (* implementation restrictions *) + CodeBlocks = 512; + CodeLength = 16384; + MaxNameTab = 800000H; + + useAllRef = FALSE; + outSignatures = TRUE; + + TYPE + CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR; + + VAR + pc*: INTEGER; + dsize*: INTEGER; (* global data size *) + KNewRec*, KNewArr*: DevCPT.Object; + closeLbl*: INTEGER; + CaseLinks*: DevCPT.LinkList; + + processor: INTEGER; + bigEndian: BOOLEAN; + procVarIndirect: BOOLEAN; + idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER; + Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object; + outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN; + codePos, srcPos: INTEGER; + options: SET; + code: ARRAY CodeBlocks OF CodeBlock; + actual: CodeBlock; + actIdx, blkIdx: INTEGER; + CodeOvF: BOOLEAN; + zero: ARRAY 16 OF SHORTCHAR; (* all 0X *) + imports: INTEGER; + dllList, dllLast: DevCPT.Object; + + + PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + CONST N = 4294967296.0; (* 2^32 *) + VAR rh, rl: REAL; + BEGIN + rl := con.intval; rh := con.realval / N; + IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N + ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N + END; + hi := SHORT(ENTIER(rh)); + rl := rl + (rh - hi) * N; + IF rl < 0 THEN hi := hi - 1; rl := rl + N + ELSIF rl >= N THEN hi := hi + 1; rl := rl - N + END; + IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END; + low := SHORT(ENTIER(rl)) +(* + hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0)); + r := con.realval + con.intval - hi * 4294967296.0; + IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; + low := SHORT(ENTIER(r)) +*) + END GetLongWords; + + PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER); + VAR r: SHORTREAL; + BEGIN + r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r) + END GetRealWord; + + PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + TYPE A = ARRAY 2 OF INTEGER; + VAR a: A; + BEGIN + a := SYSTEM.VAL(A, con.realval); + IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END + END GetRealWords; + + PROCEDURE IsSame (x, y: REAL): BOOLEAN; + BEGIN + RETURN (x = y) & ((x # 0.) OR (1. / x = 1. / y)) + END IsSame; + + PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER); + VAR c: DevCPT.Const; + BEGIN + INCL(con.setval, form); + CASE form OF + | String8: + obj := Const8; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END + | String16: + obj := Const16; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END + | Int64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO + c := c.link + END; + IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END + | Real32: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 4) END + | Real64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx64; INC(idx64, 8) END + | Guid: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 16) END + END; + IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END; + con.intval := adr + END AllocConst; + + + PROCEDURE AllocTypDesc* (typ: DevCPT.Struct); (* typ.comp = Record *) + VAR obj: DevCPT.Object; name: DevCPT.Name; + BEGIN + IF typ.strobj = NIL THEN + name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null; (* avoid err 1 *) + obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END + END AllocTypDesc; + + + PROCEDURE PutByte* (a, x: INTEGER); + BEGIN + code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256)) + END PutByte; + + PROCEDURE PutShort* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 256); PutByte(a + 1, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256) + END + END PutShort; + + PROCEDURE PutWord* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H); + PutByte(a + 2, x DIV 256); PutByte(a + 3, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256); + PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H) + END + END PutWord; + + PROCEDURE ThisByte* (a: INTEGER): INTEGER; + BEGIN + RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength]) + END ThisByte; + + PROCEDURE ThisShort* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ThisByte(a) * 256 + ThisByte(a+1) + ELSE + RETURN ThisByte(a+1) * 256 + ThisByte(a) + END + END ThisShort; + + PROCEDURE ThisWord* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3) + ELSE + RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a) + END + END ThisWord; + + PROCEDURE GenByte* (x: INTEGER); + BEGIN + IF actIdx >= CodeLength THEN + IF blkIdx < CodeBlocks THEN + NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0 + ELSE + IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END; + actIdx := 0; pc := 0 + END + END; + actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc) + END GenByte; + + PROCEDURE GenShort* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256) + END + END GenShort; + + PROCEDURE GenWord* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H) + END + END GenWord; + + PROCEDURE WriteCode; + VAR i, j, k, n: INTEGER; b: CodeBlock; + BEGIN + j := 0; k := 0; + WHILE j < pc DO + n := pc - j; i := 0; b := code[k]; + IF n > CodeLength THEN n := CodeLength END; + WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END; + INC(j, n); INC(k) + END + END WriteCode; + + + PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList; + VAR link: DevCPT.LinkList; m: DevCPT.Object; + BEGIN + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ)); + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp)); + IF obj.mnolev >= 0 THEN (* not imported *) + CASE obj.mode OF + | Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END + | TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END + | Var: offs := offs + dsize; obj := Data + | Con, IProc, XProc, LProc: + END + ELSIF obj.mode = Typ THEN + IF obj.typ.untagged THEN (* add desc for imported untagged types *) + IF obj.links = NIL THEN obj.link := descList; descList := obj END + ELSE + m := DevCPT.GlbMod[-obj.mnolev]; + IF m.library # NIL THEN RETURN NIL END (* type import from dll *) + END + END; + link := obj.links; + WHILE (link # NIL) & (link.offset # offs) DO link := link.next END; + IF link = NIL THEN + NEW(link); link.offset := offs; link.linkadr := 0; + link.next := obj.links; obj.links := link + END; + RETURN link + END OffsetLink; + + + PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + obj := typ.strobj; + IF obj = NIL THEN + obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0; + obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END; + RETURN obj + END TypeObj; + + + PROCEDURE Align (n: INTEGER); + VAR p: INTEGER; + BEGIN + p := DevCPM.ObjLen(); + DevCPM.ObjWBytes(zero, (-p) MOD n) + END Align; + + PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR); + VAR ch: SHORTCHAR; i: SHORTINT; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE Out2 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256))) + END + END Out2; + + PROCEDURE Out4 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H))); + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjWLInt(x) + END + END Out4; + + PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER); + VAR link: DevCPT.LinkList; + BEGIN + link := OffsetLink(obj, offs); + IF link # NIL THEN + Out4(typ * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := -(DevCPM.ObjLen() - headSize - 4) + ELSE Out4(0) + END + END OutReference; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form = Pointer THEN + IF ip & (typ.sysflag = interface) + OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface) + OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num) + ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, ip, num); + IF num # i THEN i := 1; + WHILE i < n DO + INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i) + END + END + END + END + END FindPtrs; + + + PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR); + BEGIN + DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name) + END OutRefName; + + PROCEDURE OutRefs* (obj: DevCPT.Object); + VAR f: BYTE; + BEGIN + IF outRef & (obj # NIL) THEN + OutRefs(obj.left); + IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN + f := obj.typ.form; + IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64}) + OR outURef & (obj.typ.comp # DynArr) + OR outAllRef & ~obj.typ.untagged + OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN + IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END; + IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr))) + ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec))) + ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16))) + ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64))) + ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid))) + ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult))) + ELSIF f = Pointer THEN + IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface))) + ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + END + ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN + DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1))) + ELSE DevCPM.ObjW(SHORT(CHR(f))) + END; + IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END; + OutName(obj.name^) + END + END ; + OutRefs(obj.right) + END + END OutRefs; + + PROCEDURE OutSourceRef* (pos: INTEGER); + BEGIN + IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN + WHILE pc > codePos + 250 DO + DevCPM.ObjW(SHORT(CHR(250))); + INC(codePos, 250); + DevCPM.ObjWNum(0) + END; + DevCPM.ObjW(SHORT(CHR(pc - codePos))); + codePos := pc; + DevCPM.ObjWNum(pos - srcPos); + srcPos := pos + END + END OutSourceRef; + + + PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER); + BEGIN + WHILE link # NIL DO + ASSERT(link.linkadr # 0); + DevCPM.ObjWNum(link.linkadr); + DevCPM.ObjWNum(adr + link.offset); + link := link.next + END + END OutPLink; + + PROCEDURE OutLink (link: DevCPT.LinkList); + BEGIN + OutPLink(link, 0); DevCPM.ObjW(0X) + END OutLink; + + PROCEDURE OutNames; + VAR a, b, c: DevCPT.Object; + BEGIN + a := nameList; b := NIL; + WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END; + DevCPM.ObjW(0X); (* names[0] = 0X *) + WHILE b # NIL DO + OutName(b.name^); + b := b.nlink + END; + END OutNames; + + PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR); + + PROCEDURE Copy (n: INTEGER); + VAR x, y: INTEGER; + BEGIN + x := ORD(str[n]); y := ORD(str[n + 1]); + IF x >= ORD("a") THEN DEC(x, ORD("a") - 10) + ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10) + ELSE DEC(x, ORD("0")) + END; + IF y >= ORD("a") THEN DEC(y, ORD("a") - 10) + ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10) + ELSE DEC(y, ORD("0")) + END; + DevCPM.ObjW(SHORT(CHR(x * 16 + y))) + END Copy; + + BEGIN + IF bigEndian THEN + Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17) + ELSE + Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15) + END; + Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35) + END OutGuid; + + PROCEDURE OutConst (obj: DevCPT.Object); + TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR; + VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER; + BEGIN + a := obj.conval; b := NIL; + WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END; + WHILE b # NIL DO + IF String8 IN b.setval THEN + DevCPM.ObjWBytes(b.ext^, b.intval2); + Align(4) + ELSIF String16 IN b.setval THEN + i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0; + Align(4) + ELSIF Real32 IN b.setval THEN + r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r); + IF DevCPM.LEHost = bigEndian THEN + ch := a4[0]; a4[0] := a4[3]; a4[3] := ch; + ch := a4[1]; a4[1] := a4[2]; a4[2] := ch + END; + DevCPM.ObjWBytes(a4, 4) + ELSIF Real64 IN b.setval THEN + a8 := SYSTEM.VAL(A8, b.realval); + IF DevCPM.LEHost = bigEndian THEN + ch := a8[0]; a8[0] := a8[7]; a8[7] := ch; + ch := a8[1]; a8[1] := a8[6]; a8[6] := ch; + ch := a8[2]; a8[2] := a8[5]; a8[5] := ch; + ch := a8[3]; a8[3] := a8[4]; a8[4] := ch + END; + DevCPM.ObjWBytes(a8, 8) + ELSIF Int64 IN b.setval THEN + (* intval moved to intval2 by AllocConst *) + x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x; + IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END + ELSIF Guid IN b.setval THEN + OutGuid(b.ext^) + END; + b := b.link + END + END OutConst; + + PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN); + BEGIN + IF typ = NIL THEN Out4(0) + ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr) + ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec) + ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr) + ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid) + ELSIF typ = DevCPT.restyp THEN Out4(mResult) + ELSE + CASE typ.form OF + | Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0) + | Bool, Char8: Out4(typ.form - 1) + | Int8..Set: Out4(typ.form) + | Char16: Out4(mChar16) + | Int64: Out4(mInt64) + | ProcTyp: OutReference(TypeObj(typ), 0, absolute) + | Pointer: + IF typ.sysflag = interface THEN Out4(mInterface) + ELSIF typ.untagged THEN Out4(mSysPtr) + ELSE OutReference(TypeObj(typ), 0, absolute) + END + | Comp: + IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute) + ELSE Out4(0) + END + END + END + END OutStruct; + + PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER; + VAR n: INTEGER; + BEGIN + n := 0; + IF obj.name # DevCPT.null THEN + IF obj.num = 0 THEN + obj.num := namex; + WHILE obj.name[n] # 0X DO INC(n) END; + INC(namex, n + 1); + obj.nlink := nameList; nameList := obj + END; + n := obj.num; + END; + RETURN n + END NameIdx; + + PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER); + VAR p: DevCPT.Object; n, m: INTEGER; + BEGIN + pos := DevCPM.ObjLen() - headSize; + OutStruct(retTyp, TRUE); + p := par; n := 0; + WHILE p # NIL DO INC(n); p := p.link END; + Out4(n); p := par; + WHILE p # NIL DO + IF p.mode # VarPar THEN m := mValue + ELSIF p.vis = inPar THEN m := mInPar + ELSIF p.vis = outPar THEN m := mOutPar + ELSE m := mVarPar + END; + Out4(NameIdx(p) * 256 + m); + OutStruct(p.typ, TRUE); + p := p.link + END + END OutSignature; + + PROCEDURE PrepObject (obj: DevCPT.Object); + BEGIN + IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN (* write param list *) + OutSignature(obj.link, obj.typ, obj.conval.intval) + END + END PrepObject; + + PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object); + VAR vis: INTEGER; + BEGIN + Out4(fprint); + Out4(offs); + IF obj.vis = internal THEN vis := mInternal + ELSIF obj.vis = externalR THEN vis := mReadonly + ELSIF obj.vis = external THEN vis := mExported + END; + Out4(mode + vis * 16 + NameIdx(obj) * 256); + IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute) (* ref to par list *) + ELSE OutStruct(typ, mode = mField) + END + END OutObject; + + PROCEDURE PrepDesc (desc: DevCPT.Struct); + VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct; + BEGIN + IF desc.comp = Record THEN (* write field list *) + desc.strobj.adr := DevCPM.ObjLen() - headSize; + n := 0; fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN INC(n) END; + fld := fld.link + END; + Out4(n); fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN + OutObject(mField, 0, fld.adr, fld.typ, fld) + END; + fld := fld.link + END + ELSIF (desc.form = ProcTyp) & outSignatures THEN (* write param list *) + OutSignature(desc.link, desc.BaseTyp, desc.n) + END; + (* assert name and base type are included *) + IF desc.untagged THEN n := NameIdx(untgd) + ELSE n := NameIdx(desc.strobj) + END; + IF desc.form # ProcTyp THEN b := desc.BaseTyp; + IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp, ProcTyp}) + & (b.sysflag # interface) & (b # DevCPT.guidtyp) + & (~b.untagged OR outURef & (b.form = Comp)) THEN + l := OffsetLink(TypeObj(b), 0) + END + END + END PrepDesc; + + PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END; + obj := NumMeth(root.left, num); + IF obj = NIL THEN obj := NumMeth(root.right, num) END; + RETURN obj + END NumMeth; + + PROCEDURE OutDesc (desc: DevCPT.Struct); + VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE; + name: DevCPT.Name; + BEGIN + ASSERT(~desc.untagged); + IF desc.comp = Record THEN + xb := desc; flddir := desc.strobj.adr; + REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged; + Out4(-1); i := desc.n; + WHILE i > 0 DO DEC(i); t := desc; + REPEAT + m := NumMeth(t.link, i); t := t.BaseTyp + UNTIL (m # NIL) OR (t = xb); + IF m # NIL THEN + IF absAttr IN m.conval.setval THEN Out4(0) + ELSE OutReference(m, 0, absolute) + END + ELSIF (xb = NIL) OR xb.untagged THEN Out4(0) (* unimplemented ANYREC method *) + ELSE OutReference(xb.strobj, -4 - 4 * i, copy) + END + END; + desc.strobj.adr := DevCPM.ObjLen() - headSize; (* desc adr *) + Out4(desc.size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + IF desc.attribute = extAttr THEN attr := 1 + ELSIF desc.attribute = limAttr THEN attr := 2 + ELSIF desc.attribute = absAttr THEN attr := 3 + ELSE attr := 0 + END; + Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0; + WHILE i <= desc.extlev DO + t := desc; + WHILE t.extlev > i DO t := t.BaseTyp END; + IF t.sysflag = interface THEN Out4(0) + ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute) + ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute) + ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute) + ELSE OutReference(xb.strobj, 12 + 4 * i, copy) + END; + INC(i) + END; + WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END; + OutReference(Meta, flddir, absolute); (* ref to field list *) + nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr); + Out4(-(4 * nofptr + 4)); + nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr); + Out4(-1) + ELSE + desc.strobj.adr := DevCPM.ObjLen() - headSize; + lev := 0; size := 0; + IF desc.comp = Array THEN + size := desc.n; form := mArray + ELSIF desc.comp = DynArr THEN + form := mArray; lev := SHORT(SHORT(desc.n + 1)) + ELSIF desc.form = Pointer THEN + form := mPointer + ELSE ASSERT(desc.form = ProcTyp); + DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp; + END; + Out4(size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + Out4(form + lev * 16 + NameIdx(m) * 256); + IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE) + ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute) (* ref to par list *) + END + END + END OutDesc; + + PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER); + VAR i: INTEGER; t: Dates.Time; d: Dates.Date; + BEGIN + Out4(0); (* link *) + Out4(ORD(options)); (* opts *) + Out4(0); (* refcnt *) + Dates.GetDate(d); Dates.GetTime(t); (* compile time *) + Out2(d.year); Out2(d.month); Out2(d.day); + Out2(t.hour); Out2(t.minute); Out2(t.second); + Out4(0); Out4(0); Out4(0); (* load time *) + Out4(0); (* ext *) + IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute); (* terminator *) + ELSE Out4(0) + END; + Out4(imports); (* nofimps *) + Out4(nofptr); (* nofptrs *) + Out4(pc); (* csize *) + Out4(dsize); (* dsize *) + Out4(refSize); (* rsize *) + OutReference(Code, 0, absolute); (* code *) + OutReference(Data, 0, absolute); (* data *) + OutReference(Meta, 0, absolute); (* refs *) + IF procVarIndirect THEN + OutReference(Proc, 0, absolute); (* procBase *) + ELSE + OutReference(Code, 0, absolute); (* procBase *) + END; + OutReference(Data, 0, absolute); (* varBase *) + OutReference(Meta, namePos, absolute); (* names *) + OutReference(Meta, ptrPos, absolute); (* ptrs *) + OutReference(Meta, impPos, absolute); (* imports *) + OutReference(Meta, expPos, absolute); (* export *) + i := 0; (* name *) + WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END; + DevCPM.ObjW(0X); + Align(4) + END OutModDesc; + + PROCEDURE OutProcTable (obj: DevCPT.Object); (* 68000 *) + BEGIN + IF obj # NIL THEN + OutProcTable(obj.left); + IF obj.mode IN {XProc, IProc} THEN + Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0); + END; + OutProcTable(obj.right); + END; + END OutProcTable; + + PROCEDURE PrepExport (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + PrepExport(obj.left); + IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN + PrepObject(obj) + END; + PrepExport(obj.right) + END + END PrepExport; + + PROCEDURE OutExport (obj: DevCPT.Object); + VAR num: INTEGER; + BEGIN + IF obj # NIL THEN + OutExport(obj.left); + IF (obj.history # removed) & ((obj.vis # internal) OR + (obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN + DevCPT.FPrintObj(obj); + IF obj.mode IN {LProc, XProc, IProc} THEN + IF procVarIndirect THEN + ASSERT(obj.nlink = NIL); + num := obj.num; obj.num := 0; + OutObject(mProc, obj.fprint, num, NIL, obj); + obj.num := num + ELSE + OutObject(mProc, obj.fprint, obj.adr, NIL, obj) + END + ELSIF obj.mode = Var THEN + OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj) + ELSIF obj.mode = Typ THEN + OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj) + ELSE ASSERT(obj.mode IN {Con, CProc}); + OutObject(mConst, obj.fprint, 0, NIL, obj) + END + END; + OutExport(obj.right) + END + END OutExport; + + PROCEDURE OutCLinks (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + OutCLinks(obj.left); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END; + OutCLinks(obj.right) + END + END OutCLinks; + + PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER); + BEGIN + IF obj # NIL THEN + OutCPLinks(obj.left, base); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END; + OutCPLinks(obj.right, base) + END + END OutCPLinks; + + PROCEDURE OutImport (obj: DevCPT.Object); + VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER; + BEGIN + IF obj # NIL THEN + OutImport(obj.left); + IF obj.mode = Typ THEN typ := obj.typ; + IF obj.used OR + (typ.form IN {Pointer, Comp}) & (typ.strobj = obj) & + ((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN + DevCPT.FPrintStr(typ); + DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^); + IF obj.used THEN opt := 2 ELSE opt := 0 END; + IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN + DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1))); + IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END + ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt))) + END; + OutLink(obj.links) + END + ELSIF obj.used THEN + DevCPT.FPrintObj(obj); + IF obj.mode = Var THEN + DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSIF obj.mode IN {XProc, IProc} THEN + DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSE ASSERT(obj.mode IN {Con, CProc}); + DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint) + END + END; + OutImport(obj.right) + END + END OutImport; + + PROCEDURE OutUseBlock; + VAR m, obj: DevCPT.Object; i: INTEGER; + BEGIN + m := dllList; + WHILE m # NIL DO + obj := m.nlink; + WHILE obj # NIL DO + IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar))) + ELSE DevCPM.ObjW(SHORT(CHR(mProc))) + END; + IF obj.entry # NIL THEN OutName(obj.entry^) + ELSE OutName(obj.name^); + END; + DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links); + obj := obj.nlink + END; + DevCPM.ObjW(0X); m := m.link + END; + i := 1; + WHILE i < DevCPT.nofGmod DO + obj := DevCPT.GlbMod[i]; + IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END; + INC(i) + END; + END OutUseBlock; + + PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String); + VAR name: DevCPT.String; dll: DevCPT.Object; + BEGIN + IF obj # NIL THEN + CollectDll(obj.left, mod); + IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN + IF obj.library # NIL THEN name := obj.library + ELSE name := mod + END; + dll := dllList; + WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END; + IF dll = NIL THEN + NEW(dll); dll.library := name; INC(imports); + IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END; + dllLast := dll; dll.left := dll; + END; + dll.left.nlink := obj; dll.left := obj + END; + CollectDll(obj.right, mod) + END + END CollectDll; + + PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER); + BEGIN + IF obj # NIL THEN + EnumXProc(obj.left, num); + IF obj.mode IN {XProc, IProc} THEN + obj.num := num; INC(num, 8); + END; + EnumXProc(obj.right, num) + END; + END EnumXProc; + + PROCEDURE OutHeader*; + VAR i: INTEGER; m: DevCPT.Object; + BEGIN + DevCPM.ObjWLInt(processor); (* processor type *) + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); (* sizes *) + imports := 0; i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library # NIL THEN (* dll import *) + CollectDll(m.right, m.library); + ELSE INC(imports) (* module import *) + END; + INC(i) + END; + DevCPM.ObjWNum(imports); (* num of import *) + OutName(DevCPT.SelfName); + m := dllList; + WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END; + i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library = NIL THEN OutName(m.name^) END; + INC(i) + END; + Align(16); headSize := DevCPM.ObjLen(); + IF procVarIndirect THEN + i := 0; EnumXProc(DevCPT.topScope.right, i) + END + END OutHeader; + + PROCEDURE OutCode*; + VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos, + con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER; + m, obj, dlist: DevCPT.Object; + BEGIN + (* Ref *) + DevCPM.ObjW(0X); (* end mark *) + refSize := DevCPM.ObjLen() - headSize; + (* Export *) + Align(4); + IF outSignatures THEN PrepExport(DevCPT.topScope.right) END; (* procedure signatures *) + Align(8); expPos := DevCPM.ObjLen(); + Out4(0); + OutExport(DevCPT.topScope.right); (* export objects *) + i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i); + (* Pointers *) + ptrPos := DevCPM.ObjLen(); + obj := DevCPT.topScope.scope; nofptrs := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END; + obj := DevCPT.topScope.scope; i := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END; + IF i > 0 THEN Out4(-1); INCL(options, iptrs) END; + (* Prepare Type Descriptors *) + dlist := NIL; + WHILE descList # NIL DO + obj := descList; descList := descList.link; + PrepDesc(obj.typ); + obj.link := dlist; dlist := obj + END; + (* Import List *) + impPos := DevCPM.ObjLen(); i := 0; + WHILE i < imports DO Out4(0); INC(i) END; + (* Names *) + namePos := DevCPM.ObjLen(); OutNames; + (* Const *) + Align(4); con8Pos := DevCPM.ObjLen(); + OutConst(Const8); con16Pos := DevCPM.ObjLen(); + ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8); + OutConst(Const16); con32Pos := DevCPM.ObjLen(); + ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16); + OutConst(Const32); con64Pos := DevCPM.ObjLen(); + ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32); + IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END; + OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64); + (* Module Descriptor *) + Align(16); modPos := DevCPM.ObjLen(); + OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize); + (* Procedure Table *) + procPos := DevCPM.ObjLen(); + OutProcTable(DevCPT.topScope.right); + Out4(0); Out4(0); (* at least one entry in ProcTable *) + Out4(0); (* sentinel *) + (* Type Descriptors *) + obj := dlist; + WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END; + (* Code *) + codePos := DevCPM.ObjLen(); WriteCode; + WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END; + (* Fixups *) + OutLink(KNewRec.links); OutLink(KNewArr.links); + (* metalink *) + OutPLink(Const8.links, con8Pos - headSize); + OutPLink(Const16.links, con16Pos - headSize); + OutPLink(Const32.links, con32Pos - headSize); + OutPLink(Const64.links, con64Pos - headSize); + OutLink(Meta.links); + (* desclink *) + obj := dlist; i := modPos - headSize; + WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END; + IF procVarIndirect THEN + OutPLink(Proc.links, procPos - modPos); + OutCPLinks(DevCPT.topScope.right, procPos - modPos) + END; + OutLink(Mod.links); + (* codelink *) + IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END; + OutPLink(CaseLinks, 0); OutLink(Code.links); + (* datalink *) + OutLink(Data.links); + (* Use *) + OutUseBlock; + (* Header Fixups *) + DevCPM.ObjSet(8); + DevCPM.ObjWLInt(headSize); + DevCPM.ObjWLInt(modPos - headSize); + DevCPM.ObjWLInt(codePos - modPos); + DevCPM.ObjWLInt(pc); + DevCPM.ObjWLInt(dsize); + IF namex > MaxNameTab THEN DevCPM.err(242) END; + IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END + END OutCode; + + PROCEDURE Init* (proc: INTEGER; opt: SET); + CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14; + BEGIN + processor := proc; + bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt; + outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt; + outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options); + outSrc := srcpos IN opt; + pc := 0; actIdx := CodeLength; blkIdx := 0; + idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1; + options := opt * {0..15}; CodeOvF := FALSE; + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + codePos := 0; srcPos := 0; + NEW(untgd); untgd.name := DevCPT.NewName("!"); + closeLbl := 0 + END Init; + + PROCEDURE Close*; + BEGIN + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END; + actual := NIL; untgd := NIL; + END Close; + +BEGIN + NEW(KNewRec); KNewRec.mnolev := -128; + NEW(KNewArr); KNewArr.mnolev := -128; + NEW(Const8); Const8.mode := Con; Const8.mnolev := 0; + NEW(Const16); Const16.mode := Con; Const16.mnolev := 0; + NEW(Const32); Const32.mode := Con; Const32.mnolev := 0; + NEW(Const64); Const64.mode := Con; Const64.mnolev := 0; + NEW(Code); Code.mode := Con; Code.mnolev := 0; + NEW(Data); Data.mode := Con; Data.mnolev := 0; + NEW(Mod); Mod.mode := Con; Mod.mnolev := 0; + NEW(Proc); Proc.mode := Con; Proc.mnolev := 0; + NEW(Meta); Meta.mode := Con; Mod.mnolev := 0; +END DevCPE. diff --git a/Trurl-based/Dev/Mod/CPH.txt b/Trurl-based/Dev/Mod/CPH.txt new file mode 100644 index 0000000..c55a9e6 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPH.txt @@ -0,0 +1,291 @@ +MODULE DevCPH; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPH.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPT; + + CONST + (* UseCalls options *) + longMop* = 0; longDop* = 1; longConv* = 2; longOdd* = 3; + realMop* = 8; realDop* = 9; realConv* = 10; + intMulDiv* = 11; + force = 16; hide = 17; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55; + + (*function number*) + assign = 0; newfn = 1; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; + thisrecfn = 45; thisarrfn = 46; + shl = 50; shr = 51; lshr = 52; xor = 53; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + VString16to8 = 29; VString8 = 30; VString16 = 31; + realSet = {Real32, Real64}; + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + + + PROCEDURE UseThisCall (n: DevCPT.Node; IN name: ARRAY OF SHORTCHAR); + VAR mod, nm, moda: DevCPT.Name; mobj, obj: DevCPT.Object; done: BOOLEAN; + BEGIN + IF (n.typ.form = Real64) OR (n.left.typ.form = Real64) THEN mod := "Real" + ELSIF (n.typ.form = Real32) OR (n.left.typ.form = Real32) THEN mod := "SReal" + ELSIF (n.typ.form = Int64) OR (n.left.typ.form = Int64) THEN mod := "Long" + ELSE mod := "Int" + END; + moda := mod + "%"; + DevCPT.Find(moda, mobj); + IF mobj = NIL THEN + DevCPT.Import(moda, mod, done); + IF done THEN DevCPT.Find(moda, mobj) END + END; + nm := name$; DevCPT.FindImport(nm, mobj, obj); + n.class := Ncall; n.subcl := 0; n.obj := obj.link; + n.left.link := n.right; n.right := n.left; + n.left := DevCPT.NewNode(Nproc); + n.left.obj := obj; n.left.typ := obj.typ; + ASSERT(n.typ.form = obj.typ.form) + END UseThisCall; + + PROCEDURE Convert (n: DevCPT.Node; typ: DevCPT.Struct); + VAR new: DevCPT.Node; r: REAL; + BEGIN + IF n.class = Nconst THEN + ASSERT((n.typ.form IN {Int32, Int64}) & (typ = DevCPT.intrealtyp)); + r := n.conval.realval + n.conval.intval; + IF r = n.conval.realval + n.conval.intval THEN + n.conval.realval := r; n.conval.intval := -1; n.typ := typ; n.obj := NIL + END + END; + IF (n.typ # typ) + & ((n.class # Nmop) OR (n.subcl # conv) + OR ~DevCPT.Includes(n.typ.form, n.left.typ.form) & ~DevCPT.Includes(n.typ.form, typ.form)) THEN + new := DevCPT.NewNode(0); new^ := n^; + n.class := Nmop; n.subcl := conv; n.left := new; n.right := NIL; n.obj := NIL + END; + n.typ := typ + END Convert; + + PROCEDURE UseCallForComp (n: DevCPT.Node); + VAR new: DevCPT.Node; + BEGIN + new := DevCPT.NewNode(0); + new.left := n.left; new.right := n.right; + new.typ := DevCPT.int32typ; + UseThisCall(new, "Comp"); + n.left := new; + n.right := DevCPT.NewNode(Nconst); n.right.conval := DevCPT.NewConst(); + n.right.conval.intval := 0; n.right.conval.realval := 0; n.right.typ := DevCPT.int32typ; + END UseCallForComp; + + PROCEDURE UseCallForConv (n: DevCPT.Node; opts: SET); + VAR f, g: INTEGER; typ: DevCPT.Struct; + BEGIN + typ := n.typ; f := typ.form; g := n.left.typ.form; + IF realConv IN opts THEN + IF f IN realSet THEN + IF g = Real32 THEN UseThisCall(n, "Long") + ELSIF g = Real64 THEN UseThisCall(n, "Short") + ELSIF g = Int64 THEN UseThisCall(n, "LFloat") + ELSIF g = Int32 THEN UseThisCall(n, "Float") + ELSE Convert(n.left, DevCPT.int32typ); UseThisCall(n, "Float") + END + ELSIF g IN realSet THEN + IF f = Int64 THEN UseThisCall(n, "LFloor") + ELSIF f = Int32 THEN UseThisCall(n, "Floor") + ELSE n.typ := DevCPT.int32typ; UseThisCall(n, "Floor"); Convert(n, typ) + END + END + END; + IF longConv IN opts THEN + IF f = Int64 THEN + IF g = Int32 THEN UseThisCall(n, "Long") + ELSIF ~(g IN realSet) THEN Convert(n.left, DevCPT.int32typ); UseThisCall(n, "IntToLong") + END + ELSIF g = Int64 THEN + IF f = Int32 THEN UseThisCall(n, "Short") + ELSIF ~(f IN realSet) THEN n.typ := DevCPT.int32typ; UseThisCall(n, "LongToInt"); Convert(n, typ) + END + END + END + END UseCallForConv; + + PROCEDURE UseCallForMop (n: DevCPT.Node; opts: SET); + BEGIN + CASE n.subcl OF + | minus: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Neg") + END + | abs: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Abs") + END + | odd: + IF (longOdd IN opts) & (n.left.typ.form = Int64) THEN UseThisCall(n, "Odd") END + | conv: + UseCallForConv(n, opts) + ELSE + END + END UseCallForMop; + + PROCEDURE UseCallForDop (n: DevCPT.Node; opts: SET); + BEGIN + IF (realDop IN opts) & (n.left.typ.form IN realSet) + OR (longDop IN opts) & (n.left.typ.form = Int64) + OR (intMulDiv IN opts) & (n.subcl IN {times, div, mod}) & (n.typ.form = Int32) THEN + CASE n.subcl OF + | times: UseThisCall(n, "Mul") + | slash: UseThisCall(n, "Div") + | div: UseThisCall(n, "Div") + | mod: UseThisCall(n, "Mod") + | plus: UseThisCall(n, "Add") + | minus: UseThisCall(n, "Sub") + | ash: UseThisCall(n, "Ash") + | min: UseThisCall(n, "Min") + | max: UseThisCall(n, "Max") + | eql..geq: UseCallForComp(n) + ELSE + END + END + END UseCallForDop; + + PROCEDURE UseCallForMove (n: DevCPT.Node; typ: DevCPT.Struct; opts: SET); + VAR f, g: INTEGER; + BEGIN + f := n.typ.form; g := typ.form; + IF f # g THEN + IF (realConv IN opts) & ((f IN realSet) OR (g IN realSet)) + OR (longConv IN opts) & ((f = Int64) OR (g = Int64)) THEN + Convert(n, typ); + UseCallForConv(n, opts) + END + END + END UseCallForMove; + + PROCEDURE UseCallForAssign (n: DevCPT.Node; opts: SET); + BEGIN + IF n.subcl = assign THEN UseCallForMove(n.right, n.left.typ, opts) END + END UseCallForAssign; + + PROCEDURE UseCallForReturn (n: DevCPT.Node; opts: SET); + BEGIN + IF (n.left # NIL) & (n.obj # NIL) THEN UseCallForMove(n.left, n.obj.typ, opts) END + END UseCallForReturn; + + PROCEDURE UseCallForParam (n: DevCPT.Node; fp: DevCPT.Object; opts: SET); + BEGIN + WHILE n # NIL DO + UseCallForMove(n, fp.typ, opts); + n := n.link; fp := fp.link + END + END UseCallForParam; + + PROCEDURE UseCalls* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + UseCalls(n.left, opts); UseCallForMop(n, opts) + | Ndop: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForDop(n, opts) + | Ncase: + UseCalls(n.left, opts); UseCalls(n.right.left, opts); UseCalls(n.right.right, opts) + | Nassign: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForAssign(n, opts) + | Ncall: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForParam(n.right, n.obj, opts) + | Nreturn: + UseCalls(n.left, opts); UseCallForReturn(n, opts) + | Ncasedo: + UseCalls(n.right, opts) + | Ngoto, Ndrop, Nloop, Nfield, Nderef, Nguard: + UseCalls(n.left, opts) + | Nenter, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseCalls(n.left, opts); UseCalls(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END UseCalls; + + + PROCEDURE UseReals* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + IF (longMop IN opts) & (n.typ.form = Int64) & ((n.subcl = abs) OR (n.subcl = minus)) THEN + UseReals(n.left, opts - {hide} + {force}); n.typ := DevCPT.intrealtyp + ELSIF n.subcl = conv THEN UseReals(n.left, opts - {force} + {hide}) + ELSE UseReals(n.left, opts - {force, hide}) + END + | Ndop: + IF (longDop IN opts) & (n.left.typ.form = Int64) THEN + UseReals(n.left, opts - {hide} + {force}); UseReals(n.right, opts - {hide} + {force}); + IF n.typ.form = Int64 THEN n.typ := DevCPT.intrealtyp END + ELSE UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + END + | Ncase: + UseReals(n.left, opts - {force, hide}); UseReals(n.right.left, opts - {force, hide}); + UseReals(n.right.right, opts - {force, hide}) + | Ncasedo: + UseReals(n.right, opts - {force, hide}) + | Ngoto, Ndrop, Nloop, Nreturn, Nfield, Nderef, Nguard: + UseReals(n.left, opts - {force, hide}) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + IF force IN opts THEN Convert(n, DevCPT.intrealtyp) + ELSIF ~(hide IN opts) & (n.typ = DevCPT.intrealtyp) THEN Convert(n, DevCPT.int64typ) + END; + n := n.link + END + END UseReals; + +END DevCPH. + + + + + PROCEDURE Traverse (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Ncase: + Traverse(n.left, opts); Traverse(n.right.left, opts); Traverse(n.right.right, opts) + | Ncasedo: + Traverse(n.right, opts) + | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard: + Traverse(n.left, opts) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex: + Traverse(n.left, opts); Traverse(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END Traverse; + diff --git a/Trurl-based/Dev/Mod/CPL486.txt b/Trurl-based/Dev/Mod/CPL486.txt new file mode 100644 index 0000000..a0ae315 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPL486.txt @@ -0,0 +1,1057 @@ +MODULE DevCPL486; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPL486.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPM, DevCPT, DevCPE; + + TYPE + Item* = RECORD + mode*, tmode*, form*: BYTE; + offset*, index*, reg*, scale*: INTEGER; (* adr = offset + index * scale *) + typ*: DevCPT.Struct; + obj*: DevCPT.Object + END ; + +(* Items: + + mode | offset index scale reg obj +------------------------------------------------ + 1 Var | adr xreg scale obj (ea = FP + adr + xreg * scale) + 2 VarPar| off xreg scale obj (ea = [FP + obj.adr] + off + xreg * scale) + 3 Con | val (val2) NIL + Con | off obj (val = adr(obj) + off) + Con | id NIL (for predefined reals) + 6 LProc | obj + 7 XProc | obj + 9 CProc | obj +10 IProc | obj +13 TProc | mthno 0/1 obj (0 = normal / 1 = super call) +14 Ind | off xreg scale Reg (ea = Reg + off + xreg * scale) +15 Abs | adr xreg scale NIL (ea = adr + xreg * scale) + Abs | off xreg scale obj (ea = adr(obj) + off + xreg * scale) + Abs | off len 0 obj (for constant strings and reals) +16 Stk | (ea = ESP) +17 Cond | CC +18 Reg | (Reg2) Reg +19 DInd | off xreg scale Reg (ea = [Reg + off + xreg * scale]) + + tmode | record tag array desc +------------------------------------- + VarPar | [FP + obj.adr + 4] [FP + obj.adr] + Ind | [Reg - 4] [Reg + 8] + Con | Adr(typ.strobj) + +*) + + CONST + processor* = 10; (* for i386 *) + NewLbl* = 0; + + TYPE + Label* = INTEGER; (* 0: unassigned, > 0: address, < 0: - (linkadr + linktype * 2^24) *) + + VAR + level*: BYTE; + one*: DevCPT.Const; + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* item modes for i386 (must not overlap item basemodes, > 13) *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* condition codes *) + ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *) + ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *) + ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1; + ccAlways = -1; ccNever = -2; ccCall = -3; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + + VAR + Size: ARRAY 32 OF INTEGER; (* Size[typ.form] == +/- typ.size *) + a1, a2: Item; + + + PROCEDURE MakeReg* (VAR x: Item; reg: INTEGER; form: BYTE); + BEGIN + ASSERT((reg >= 0) & (reg < 8)); + x.mode := Reg; x.reg := reg; x.form := form + END MakeReg; + + PROCEDURE MakeConst* (VAR x: Item; val: INTEGER; form: BYTE); + BEGIN + x.mode := Con; x.offset := val; x.form := form; x.obj := NIL; + END MakeConst; + + PROCEDURE AllocConst* (VAR x: Item; con: DevCPT.Const; form: BYTE); + VAR r: REAL; short: SHORTREAL; c: DevCPT.Const; i: INTEGER; + BEGIN + IF form IN {Real32, Real64} THEN + r := con.realval; + IF ABS(r) <= MAX(SHORTREAL) THEN + short := SHORT(r); + IF short = r THEN form := Real32 (* a shortreal can represent the exact value *) + ELSE form := Real64 (* use a real *) + END + ELSE form := Real64 (* use a real *) + END + ELSIF form IN {String8, String16, Guid} THEN + x.index := con.intval2 (* string length *) + END; + DevCPE.AllocConst(con, form, x.obj, x.offset); + x.form := form; x.mode := Abs; x.scale := 0 + END AllocConst; + + (*******************************************************) + + PROCEDURE BegStat*; (* general-purpose procedure which is called before each statement *) + BEGIN + END BegStat; + + PROCEDURE EndStat*; (* general-purpose procedure which is called after each statement *) + BEGIN + END EndStat; + + (*******************************************************) + + PROCEDURE SetLabel* (VAR L: Label); + VAR link, typ, disp, x: INTEGER; c: SHORTCHAR; + BEGIN + ASSERT(L <= 0); link := -L; + WHILE link # 0 DO + typ := link DIV 1000000H; link := link MOD 1000000H; + IF typ = short THEN + disp := DevCPE.pc - link - 1; ASSERT(disp < 128); + DevCPE.PutByte(link, disp); link := 0 + ELSIF typ = relative THEN + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc - link - 4); link := x + ELSE + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc + typ * 1000000H); link := x + END + END; + L := DevCPE.pc; + a1.mode := 0; a2.mode := 0 + END SetLabel; + + + (*******************************************************) + + PROCEDURE GenWord (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256) + END GenWord; + + PROCEDURE GenDbl (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256); DevCPE.GenByte(x DIV 10000H); DevCPE.GenByte(x DIV 1000000H) + END GenDbl; + + PROCEDURE CaseEntry* (tab, from, to: INTEGER); + VAR a, e: INTEGER; + BEGIN + a := tab + 4 * from; e := tab + 4 * to; + WHILE a <= e DO + DevCPE.PutByte(a, DevCPE.pc); + DevCPE.PutByte(a + 1, DevCPE.pc DIV 256); + DevCPE.PutByte(a + 2, DevCPE.pc DIV 65536); + INC(a, 4) + END; + a1.mode := 0; a2.mode := 0 + END CaseEntry; + + PROCEDURE GenLinked (VAR x: Item; type: BYTE); + VAR link: DevCPT.LinkList; + BEGIN + IF x.obj = NIL THEN GenDbl(x.offset) + ELSE + link := DevCPE.OffsetLink(x.obj, x.offset); + IF link # NIL THEN + GenDbl(type * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := DevCPE.pc - 4 + ELSE GenDbl(0) + END + END + END GenLinked; + + PROCEDURE CheckSize (form: BYTE; VAR w: INTEGER); + BEGIN + IF form IN {Int16, Char16} THEN DevCPE.GenByte(66H); w := 1 + ELSIF form >= Int32 THEN ASSERT(form IN {Int32, Set, NilTyp, Pointer, ProcTyp}); w := 1 + ELSE w := 0 + END + END CheckSize; + + PROCEDURE CheckForm (form: BYTE; VAR mf: INTEGER); + BEGIN + IF form = Real32 THEN mf := 0 + ELSIF form = Real64 THEN mf := 4 + ELSIF form = Int32 THEN mf := 2 + ELSE ASSERT(form = Int16); mf := 6 + END + END CheckForm; + + PROCEDURE CheckConst (VAR x: Item; VAR s: INTEGER); + BEGIN + IF (x.form > Int8) & (x.offset >= -128) & (x.offset < 128) & (x.obj = NIL) THEN s := 2 + ELSE s := 0 + END + END CheckConst; + + PROCEDURE GenConst (VAR x: Item; short: BOOLEAN); + BEGIN + IF x.obj # NIL THEN GenLinked(x, absolute) + ELSIF x.form <= Int8 THEN DevCPE.GenByte(x.offset) + ELSIF short & (x.offset >= -128) & (x.offset < 128) THEN DevCPE.GenByte(x.offset) + ELSIF x.form IN {Int16, Char16} THEN GenWord(x.offset) + ELSE GenDbl(x.offset) + END + END GenConst; + + PROCEDURE GenCExt (code: INTEGER; VAR x: Item); + VAR disp, mod, base, scale: INTEGER; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs, Stk}); + ASSERT((code MOD 8 = 0) & (code < 64)); + disp := x.offset; base := x.reg; scale := x.scale; + IF x.mode = Reg THEN mod := 0C0H; scale := 0 + ELSIF x.mode = Stk THEN base := SP; mod := 0; disp := 0; scale := 0 + ELSIF x.mode = Abs THEN + IF scale = 1 THEN base := x.index; mod := 80H; scale := 0 + ELSE base := BP; mod := 0 + END + ELSIF (disp = 0) & (base # BP) THEN mod := 0 + ELSIF (disp >= -128) & (disp < 128) THEN mod := 40H + ELSE mod := 80H + END; + IF scale # 0 THEN + DevCPE.GenByte(mod + code + 4); base := base + x.index * 8; + IF scale = 8 THEN DevCPE.GenByte(0C0H + base); + ELSIF scale = 4 THEN DevCPE.GenByte(80H + base); + ELSIF scale = 2 THEN DevCPE.GenByte(40H + base); + ELSE ASSERT(scale = 1); DevCPE.GenByte(base); + END; + ELSE + DevCPE.GenByte(mod + code + base); + IF (base = SP) & (mod <= 80H) THEN DevCPE.GenByte(24H) END + END; + IF x.mode = Abs THEN GenLinked(x, absolute) + ELSIF mod = 80H THEN GenDbl(disp) + ELSIF mod = 40H THEN DevCPE.GenByte(disp) + END + END GenCExt; + + PROCEDURE GenDExt (VAR r, x: Item); + BEGIN + ASSERT(r.mode = Reg); + GenCExt(r.reg * 8, x) + END GenDExt; + + (*******************************************************) + + PROCEDURE GenMove* (VAR from, to: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[from.form] = Size[to.form]); + IF to.mode = Reg THEN + IF from.mode = Con THEN + IF to.reg = AX THEN + + IF (a1.mode = Con) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0 + END; + CheckSize(from.form, w); + IF (from.offset = 0) & (from.obj = NIL) THEN + DevCPE.GenByte(30H + w); DevCPE.GenByte(0C0H + 9 * to.reg) (* XOR r,r *) + ELSE + DevCPE.GenByte(0B0H + w * 8 + to.reg); GenConst(from, FALSE) + END; + ELSIF (to.reg = AX) & (from.mode = Abs) & (from.scale = 0) THEN + + IF (a1.mode = Abs) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) + OR (a2.mode = Abs) & (from.offset = a2.offset) & (from.obj = a2.obj) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0; + CheckSize(from.form, w); + DevCPE.GenByte(0A0H + w); GenLinked(from, absolute); + ELSIF (from.mode # Reg) OR (from.reg # to.reg) THEN + IF to.reg = AX THEN + IF (from.mode = Ind) & (from.scale = 0) & ((from.reg = BP) OR (from.reg = BX)) THEN + + IF (a1.mode = Ind) & (from.offset = a1.offset) & (from.reg = a1.reg) & (from.form = a1.form) + OR (a2.mode = Ind) & (from.offset = a2.offset) & (from.reg = a2.reg) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from + ELSE a1.mode := 0 + END; + a2.mode := 0 + END; + CheckSize(from.form, w); + DevCPE.GenByte(8AH + w); GenDExt(to, from) + END + ELSE + CheckSize(from.form, w); + IF from.mode = Con THEN + DevCPE.GenByte(0C6H + w); GenCExt(0, to); GenConst(from, FALSE); + a1.mode := 0; a2.mode := 0 + ELSIF (from.reg = AX) & (to.mode = Abs) & (to.scale = 0) THEN + DevCPE.GenByte(0A2H + w); GenLinked(to, absolute); + a2 := to + ELSE + DevCPE.GenByte(88H + w); GenDExt(from, to); + IF from.reg = AX THEN + IF (to.mode = Ind) & (to.scale = 0) & ((to.reg = BP) OR (to.reg = BX)) THEN a2 := to END + ELSE a1.mode := 0; a2.mode := 0 + END + END + END + END GenMove; + + PROCEDURE GenExtMove* (VAR from, to: Item); + VAR w, op: INTEGER; + BEGIN + ASSERT(from.mode # Con); + IF from.form IN {Byte, Char8, Char16} THEN op := 0B6H (* MOVZX *) + ELSE op := 0BEH (* MOVSX *) + END; + IF from.form IN {Int16, Char16} THEN INC(op) END; + DevCPE.GenByte(0FH); DevCPE.GenByte(op); GenDExt(to, from); + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenExtMove; + + PROCEDURE GenSignExt* (VAR from, to: Item); + BEGIN + ASSERT(to.mode = Reg); + IF (from.mode = Reg) & (from.reg = AX) & (to.reg = DX) THEN + DevCPE.GenByte(99H) (* cdq *) + ELSE + GenMove(from, to); (* mov to, from *) + DevCPE.GenByte(0C1H); GenCExt(38H, to); DevCPE.GenByte(31) (* sar to, 31 *) + END + END GenSignExt; + + PROCEDURE GenLoadAdr* (VAR from, to: Item); + BEGIN + ASSERT(to.form IN {Int32, Pointer, ProcTyp}); + IF (from.mode = Abs) & (from.scale = 0) THEN + DevCPE.GenByte(0B8H + to.reg); GenLinked(from, absolute) + ELSIF from.mode = Stk THEN + DevCPE.GenByte(89H); GenCExt(SP * 8, to) + ELSIF (from.mode # Ind) OR (from.offset # 0) OR (from.scale # 0) THEN + DevCPE.GenByte(8DH); GenDExt(to, from) + ELSIF from.reg # to.reg THEN + DevCPE.GenByte(89H); GenCExt(from.reg * 8, to) + ELSE RETURN + END; + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenLoadAdr; + + PROCEDURE GenPush* (VAR src: Item); + VAR s: INTEGER; + BEGIN + IF src.mode = Con THEN + ASSERT(src.form >= Int32); + CheckConst(src, s); DevCPE.GenByte(68H + s); GenConst(src, TRUE) + ELSIF src.mode = Reg THEN + ASSERT((src.form >= Int16) OR (src.reg < 4)); + DevCPE.GenByte(50H + src.reg) + ELSE + ASSERT(src.form >= Int32); + DevCPE.GenByte(0FFH); GenCExt(30H, src) + END + END GenPush; + + PROCEDURE GenPop* (VAR dst: Item); + BEGIN + IF dst.mode = Reg THEN + ASSERT((dst.form >= Int16) OR (dst.reg < 4)); + DevCPE.GenByte(58H + dst.reg); + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + ELSE + DevCPE.GenByte(08FH); GenCExt(0, dst) + END + END GenPop; + + PROCEDURE GenConOp (op: INTEGER; VAR src, dst: Item); + VAR w, s: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + CheckConst(src, s); + IF (dst.mode = Reg) & (dst.reg = AX) & (s = 0) THEN + DevCPE.GenByte(op + 4 + w); GenConst(src, FALSE) + ELSE + DevCPE.GenByte(80H + s + w); GenCExt(op, dst); GenConst(src, TRUE) + END + END GenConOp; + + PROCEDURE GenDirOp (op: INTEGER; VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + IF dst.mode = Reg THEN + DevCPE.GenByte(op + 2 + w); GenDExt(dst, src) + ELSE + DevCPE.GenByte(op + w); GenDExt(src, dst) + END + END GenDirOp; + + PROCEDURE GenAdd* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(0, src, dst) + ELSE RETURN + END + ELSE + GenConOp(0, src, dst) + END + ELSE + GenDirOp(0, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAdd; + + PROCEDURE GenAddC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 0 ELSE op := 10H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAddC; + + PROCEDURE GenSub* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(28H, src, dst) + ELSE RETURN + END + ELSE + GenConOp(28H, src, dst) + END + ELSE + GenDirOp(28H, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSub; + + PROCEDURE GenSubC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 28H ELSE op := 18H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSubC; + + PROCEDURE GenComp* (VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + IF src.mode = Con THEN + IF (src.offset = 0) & (src.obj = NIL) & (dst.mode = Reg) THEN + CheckSize(dst.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * dst.reg) (* or r,r *) + ELSE GenConOp(38H, src, dst) + END + ELSE + GenDirOp(38H, src, dst) + END + END GenComp; + + PROCEDURE GenAnd* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # -1) THEN GenConOp(20H, src, dst) END + ELSE GenDirOp(20H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAnd; + + PROCEDURE GenOr* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(8H, src, dst) END + ELSE GenDirOp(8H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenOr; + + PROCEDURE GenXor* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(30H, src, dst) END + ELSE GenDirOp(30H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenXor; + + PROCEDURE GenTest* (VAR x, y: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[x.form] = Size[y.form]); + CheckSize(x.form, w); + IF x.mode = Con THEN + IF (x.mode = Reg) & (x.reg = AX) THEN + DevCPE.GenByte(0A8H + w); GenConst(x, FALSE) + ELSE + DevCPE.GenByte(0F6H + w); GenCExt(0, y); GenConst(x, FALSE) + END + ELSE + DevCPE.GenByte(84H + w); + IF y.mode = Reg THEN GenDExt(y, x) ELSE GenDExt(x, y) END + END + END GenTest; + + PROCEDURE GenNeg* (VAR dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(18H, dst); + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNeg; + + PROCEDURE GenNot* (VAR dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(10H, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNot; + + PROCEDURE GenMul* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w, s, val, f2, f5, f9: INTEGER; + BEGIN + ASSERT((dst.mode = Reg) & (Size[src.form] = Size[dst.form])); + IF (src.mode = Con) & (src.offset = 1) THEN RETURN END; + IF src.form <= Int8 THEN + ASSERT(dst.reg = 0); + DevCPE.GenByte(0F6H); GenCExt(28H, src) + ELSIF src.mode = Con THEN + val := src.offset; + IF (src.obj = NIL) & (val # 0) & ~ovflchk THEN + f2 := 0; f5 := 0; f9 := 0; + WHILE ~ODD(val) DO val := val DIV 2; INC(f2) END; + WHILE val MOD 9 = 0 DO val := val DIV 9; INC(f9) END; + WHILE val MOD 5 = 0 DO val := val DIV 5; INC(f5) END; + IF ABS(val) <= 3 THEN + WHILE f9 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(0C0H + dst.reg * 9); + DEC(f9) + END; + WHILE f5 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(80H + dst.reg * 9); + DEC(f5) + END; + IF ABS(val) = 3 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(dst.reg * 8 + 4); DevCPE.GenByte(40H + dst.reg * 9) + END; + IF f2 > 1 THEN DevCPE.GenByte(0C1H); DevCPE.GenByte(0E0H + dst.reg); DevCPE.GenByte(f2) + ELSIF f2 = 1 THEN DevCPE.GenByte(1); DevCPE.GenByte(0C0H + dst.reg * 9) + END; + IF val < 0 THEN DevCPE.GenByte(0F7H); GenCExt(18H, dst) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END; + RETURN + END + END; + CheckSize(src.form, w); CheckConst(src, s); + DevCPE.GenByte(69H + s); GenDExt(dst, dst); GenConst(src, TRUE) + ELSE + CheckSize(src.form, w); + DevCPE.GenByte(0FH); DevCPE.GenByte(0AFH); GenDExt(dst, src) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenMul; + + PROCEDURE GenDiv* (VAR src: Item; mod, pos: BOOLEAN); + VAR w, rem: INTEGER; + BEGIN + ASSERT(src.mode = Reg); + IF src.form >= Int32 THEN DevCPE.GenByte(99H) (* cdq *) + ELSIF src.form = Int16 THEN DevCPE.GenByte(66H); DevCPE.GenByte(99H) (* cwd *) + ELSE DevCPE.GenByte(66H); DevCPE.GenByte(98H) (* cbw *) + END; + CheckSize(src.form, w); DevCPE.GenByte(0F6H + w); GenCExt(38H, src); (* idiv src *) + IF src.form > Int8 THEN rem := 2 (* edx *) ELSE rem := 4 (* ah *) END; + IF pos THEN (* src > 0 *) + CheckSize(src.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + IF mod THEN + DevCPE.GenByte(79H); DevCPE.GenByte(2); (* jns end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); DevCPE.GenByte(1); (* jns end *) + DevCPE.GenByte(48H); (* dec eax *) + END + ELSE + CheckSize(src.form, w); DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + IF mod THEN + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(9); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(8) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(4); (* je end *) + DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(6); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(5) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(1); (* je end *) + DevCPE.GenByte(48H); (* dec eax *) + END +(* + CheckSize(src.form, w); DevCPE.GenByte(3AH + w); GenCExt(8 * rem, src); (* cmp rem,src *) + IF mod THEN + DevCPE.GenByte(72H); DevCPE.GenByte(4); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(2); (* jg end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(72H); DevCPE.GenByte(3); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(1); (* jg end *) + DevCPE.GenByte(48H); (* dec eax *) + END +*) + END; + a1.mode := 0; a2.mode := 0 + END GenDiv; + + PROCEDURE GenShiftOp* (op: INTEGER; VAR cnt, dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); + IF cnt.mode = Con THEN + ASSERT(cnt.offset >= 0); ASSERT(cnt.obj = NIL); + IF cnt.offset = 1 THEN + IF (op = 10H) & (dst.mode = Reg) THEN (* shl r *) + DevCPE.GenByte(w); GenDExt(dst, dst) (* add r, r *) + ELSE + DevCPE.GenByte(0D0H + w); GenCExt(op, dst) + END + ELSIF cnt.offset > 1 THEN + DevCPE.GenByte(0C0H + w); GenCExt(op, dst); DevCPE.GenByte(cnt.offset) + END + ELSE + ASSERT((cnt.mode = Reg) & (cnt.reg = CX)); + DevCPE.GenByte(0D2H + w); GenCExt(op, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenShiftOp; + + PROCEDURE GenBitOp* (op: INTEGER; VAR num, dst: Item); + BEGIN + DevCPE.GenByte(0FH); + IF num.mode = Con THEN + ASSERT(num.obj = NIL); + DevCPE.GenByte(0BAH); GenCExt(op, dst); DevCPE.GenByte(num.offset) + ELSE + ASSERT((num.mode = Reg) & (num.form = Int32)); + DevCPE.GenByte(83H + op); GenDExt(num, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenBitOp; + + PROCEDURE GenSetCC* (cc: INTEGER; VAR dst: Item); + BEGIN + ASSERT((dst.form = Bool) & (cc >= 0)); + DevCPE.GenByte(0FH); DevCPE.GenByte(90H + cc); GenCExt(0, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSetCC; + + PROCEDURE GenFLoad* (VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Con THEN (* predefined constants *) + DevCPE.GenByte(0D9H); DevCPE.GenByte(0E8H + src.offset) + ELSIF src.form = Int64 THEN + DevCPE.GenByte(0DFH); GenCExt(28H, src) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D9H + mf); GenCExt(0, src) + END + END GenFLoad; + + PROCEDURE GenFStore* (VAR dst: Item; pop: BOOLEAN); + VAR mf: INTEGER; + BEGIN + IF dst.form = Int64 THEN ASSERT(pop); + DevCPE.GenByte(0DFH); GenCExt(38H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE + CheckForm(dst.form, mf); DevCPE.GenByte(0D9H + mf); + IF pop THEN GenCExt(18H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE GenCExt(10H, dst) + END + END; + a1.mode := 0; a2.mode := 0 + END GenFStore; + + PROCEDURE GenFDOp* (op: INTEGER; VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Reg THEN + DevCPE.GenByte(0DEH); DevCPE.GenByte(0C1H + op) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D8H + mf); GenCExt(op, src) + END + END GenFDOp; + + PROCEDURE GenFMOp* (op: INTEGER); + BEGIN + DevCPE.GenByte(0D8H + op DIV 256); + DevCPE.GenByte(op MOD 256); + IF op = 07E0H THEN a1.mode := 0; a2.mode := 0 END (* FSTSW AX *) + END GenFMOp; + + PROCEDURE GenJump* (cc: INTEGER; VAR L: Label; shortjmp: BOOLEAN); + BEGIN + IF cc # ccNever THEN + IF shortjmp OR (L > 0) & (DevCPE.pc + 2 - L <= 128) & (cc # ccCall) THEN + IF cc = ccAlways THEN DevCPE.GenByte(0EBH) + ELSE DevCPE.GenByte(70H + cc) + END; + IF L > 0 THEN DevCPE.GenByte(L - DevCPE.pc - 1) + ELSE ASSERT(L = 0); L := -(DevCPE.pc + short * 1000000H); DevCPE.GenByte(0) + END + ELSE + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSIF cc = ccCall THEN DevCPE.GenByte(0E8H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + IF L > 0 THEN GenDbl(L - DevCPE.pc - 4) + ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + relative * 1000000H) + END + END + END + END GenJump; + + PROCEDURE GenExtJump* (cc: INTEGER; VAR dst: Item); + BEGIN + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + dst.offset := 0; GenLinked(dst, relative) + END GenExtJump; + + PROCEDURE GenIndJump* (VAR dst: Item); + BEGIN + DevCPE.GenByte(0FFH); GenCExt(20H, dst) + END GenIndJump; + + PROCEDURE GenCaseJump* (VAR src: Item); + VAR link: DevCPT.LinkList; tab: INTEGER; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := DevCPE.CaseLinks; DevCPE.CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + END GenCaseJump; +(* + PROCEDURE GenCaseJump* (VAR src: Item; num: LONGINT; VAR tab: LONGINT); + VAR link: DevCPT.LinkList; else, last: LONGINT; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + else := tab + num * 4; last := else - 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := CaseLinks; CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + WHILE DevCPE.pc < last DO GenDbl(table * 1000000H + else) END; + GenDbl(tableend * 1000000H + else) + END GenCaseJump; +*) + PROCEDURE GenCaseEntry* (VAR L: Label; last: BOOLEAN); + VAR typ: INTEGER; + BEGIN + IF last THEN typ := tableend * 1000000H ELSE typ := table * 1000000H END; + IF L > 0 THEN GenDbl(L + typ) ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + typ) END + END GenCaseEntry; + + PROCEDURE GenCall* (VAR dst: Item); + BEGIN + IF dst.mode IN {LProc, XProc, IProc} THEN + DevCPE.GenByte(0E8H); + IF dst.obj.mnolev >= 0 THEN (* local *) + IF dst.obj.adr > 0 THEN GenDbl(dst.obj.adr - DevCPE.pc - 4) + ELSE GenDbl(-dst.obj.adr); dst.obj.adr := -(DevCPE.pc - 4 + relative * 1000000H) + END + ELSE (* imported *) + dst.offset := 0; GenLinked(dst, relative) + END + ELSE DevCPE.GenByte(0FFH); GenCExt(10H, dst) + END; + a1.mode := 0; a2.mode := 0 + END GenCall; + + PROCEDURE GenAssert* (cc, no: INTEGER); + BEGIN + IF cc # ccAlways THEN + IF cc >= 0 THEN + DevCPE.GenByte(70H + cc); (* jcc end *) + IF no < 0 THEN DevCPE.GenByte(2) ELSE DevCPE.GenByte(3) END + END; + IF no < 0 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(0E0H - no) + ELSE + DevCPE.GenByte(8DH); DevCPE.GenByte(0F0H); DevCPE.GenByte(no) + END + END + END GenAssert; + + PROCEDURE GenReturn* (val: INTEGER); + BEGIN + IF val = 0 THEN DevCPE.GenByte(0C3H) + ELSE DevCPE.GenByte(0C2H); GenWord(val) + END; + a1.mode := 0; a2.mode := 0 + END GenReturn; + + PROCEDURE LoadStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0ACH) ELSE DevCPE.GenByte(0ADH) END (* lods *) + END LoadStr; + + PROCEDURE StoreStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0AAH) ELSE DevCPE.GenByte(0ABH) END (* stos *) + END StoreStr; + + PROCEDURE ScanStr (size: INTEGER; rep: BOOLEAN); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF rep THEN DevCPE.GenByte(0F2H) END; + IF size <= 1 THEN DevCPE.GenByte(0AEH) ELSE DevCPE.GenByte(0AFH) END (* scas *) + END ScanStr; + + PROCEDURE TestNull (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(8); DevCPE.GenByte(0C0H); (* or al,al *) + ELSE DevCPE.GenByte(9); DevCPE.GenByte(0C0H); (* or ax,ax *) + END + END TestNull; + + PROCEDURE GenBlockMove* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A4H + w); (* rep:movs *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A5H); (* rep:movs long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0A5H); DEC(len, 4) END; (* movs long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0A5H) END; (* movs word *); + IF ODD(len) THEN DevCPE.GenByte(0A4H) END; (* movs byte *) + END + END GenBlockMove; + + PROCEDURE GenBlockStore* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0ABH); (* rep:stos long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0ABH); DEC(len, 4) END; (* stos long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0ABH) END; (* stos word *); + IF ODD(len) THEN DevCPE.GenByte(0ABH) END; (* stos byte *) + END + END GenBlockStore; + + PROCEDURE GenBlockComp* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + ASSERT(len >= 0); + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A6H + w) (* repe:cmps *) + END GenBlockComp; + + PROCEDURE GenStringMove* (excl: BOOLEAN; wsize, dsize, len: INTEGER); + (* + len = 0: len in ECX, len = -1: len undefined; wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; excl: don't move 0X + *) + VAR loop, end: Label; + BEGIN + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + (* len >= 0: len IN ECX *) + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H) END; (* xor eax,eax *) + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + IF len < 0 THEN (* no limit *) + StoreStr(dsize); TestNull(wsize); GenJump(ccNE, loop, TRUE); + IF excl THEN (* dec edi *) + DevCPE.GenByte(4FH); + IF dsize # 1 THEN DevCPE.GenByte(4FH) END + END; + ELSE (* cx limit *) + IF excl THEN TestNull(wsize); GenJump(ccE, end, TRUE); StoreStr(dsize) + ELSE StoreStr(dsize); TestNull(wsize); GenJump(ccE, end, TRUE) + END; + DevCPE.GenByte(49H); (* dec ecx *) + GenJump(ccNE, loop, TRUE); + GenAssert(ccNever, copyTrap); (* trap *) + SetLabel(end) + END; + a1.mode := 0; a2.mode := 0 + END GenStringMove; + + PROCEDURE GenStringComp* (wsize, dsize: INTEGER); + (* wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; *) + VAR loop, end: Label; + BEGIN + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) END; + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + ScanStr(dsize, FALSE); GenJump(ccNE, end, TRUE); + IF dsize = 0 THEN DevCPE.GenByte(47H) END; (* inc edi *) + TestNull(wsize); GenJump(ccNE, loop, TRUE); + SetLabel(end); + a1.mode := 0; a2.mode := 0 + END GenStringComp; + + PROCEDURE GenStringLength* (wsize, len: INTEGER); (* len = 0: len in ECX, len = -1: len undefined *) + BEGIN + DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) + IF len # 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + ScanStr(wsize, TRUE); + a1.mode := 0; a2.mode := 0 + END GenStringLength; + + PROCEDURE GenStrStore* (size: INTEGER); + VAR w: INTEGER; + BEGIN + IF size # 0 THEN + IF size MOD 4 = 0 THEN w := 1; size := size DIV 4 + ELSIF size MOD 2 = 0 THEN w := 2; size := size DIV 2 + ELSE w := 0 + END; + DevCPE.GenByte(0B9H); GenDbl(size); (* ld ecx,size *) + IF w = 2 THEN DevCPE.GenByte(66H); w := 1 END + ELSE w := 0 + END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + a1.mode := 0; a2.mode := 0 + END GenStrStore; + + PROCEDURE GenCode* (op: INTEGER); + BEGIN + DevCPE.GenByte(op); + a1.mode := 0; a2.mode := 0 + END GenCode; + + + PROCEDURE Init*(opt: SET); + BEGIN + DevCPE.Init(processor, opt); + level := 0; + NEW(one); one.realval := 1.0; one.intval := DevCPM.ConstNotAlloc; + END Init; + + PROCEDURE Close*; + BEGIN + a1.obj := NIL; a1.typ := NIL; a2.obj := NIL; a2.typ := NIL; one := NIL; + DevCPE.Close + END Close; + +BEGIN + Size[Undef] := 0; + Size[Byte] := 1; + Size[Bool] := 1; + Size[Char8] := 1; + Size[Int8] := 1; + Size[Int16] := 2; + Size[Int32] := 4; + Size[Real32] := -4; + Size[Real64] := -8; + Size[Set] := 4; + Size[String8] := 0; + Size[NilTyp] := 4; + Size[NoTyp] := 0; + Size[Pointer] := 4; + Size[ProcTyp] := 4; + Size[Comp] := 0; + Size[Char16] := 2; + Size[Int64] := 8; + Size[String16] := 0 +END DevCPL486. diff --git a/Trurl-based/Dev/Mod/CPM.txt b/Trurl-based/Dev/Mod/CPM.txt new file mode 100644 index 0000000..71c432b --- /dev/null +++ b/Trurl-based/Dev/Mod/CPM.txt @@ -0,0 +1,853 @@ +MODULE DevCPM; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPM.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, Kernel, Files, Stores, Models, Views, TextModels, TextMappers, StdLog, DevMarkers; + + CONST + ProcSize* = 4; (* PROCEDURE type *) + PointerSize* = 4; (* POINTER type *) + DArrSizeA* = 8; (* dyn array descriptor *) + DArrSizeB* = 4; (* size = A + B * typ.n *) + + MaxSet* = 31; + MaxIndex* = 7FFFFFFFH; (* maximal index value for array declaration *) + + MinReal32Pat = 0FF7FFFFFH; (* most positive, 32-bit pattern *) + MinReal64PatL = 0FFFFFFFFH; (* most negative, lower 32-bit pattern *) + MinReal64PatH = 0FFEFFFFFH; (* most negative, higher 32-bit pattern *) + MaxReal32Pat = 07F7FFFFFH; (* most positive, 32-bit pattern *) + MaxReal64PatL = 0FFFFFFFFH; (* most positive, lower 32-bit pattern *) + MaxReal64PatH = 07FEFFFFFH; (* most positive, higher 32-bit pattern *) + InfRealPat = 07F800000H; (* real infinity pattern *) + + + (* inclusive range of parameter of standard procedure HALT *) + MinHaltNr* = 0; + MaxHaltNr* = 128; + + (* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *) + MinRegNr* = 0; + MaxRegNr* = 31; + + (* maximal value of flag used to mark interface structures *) + MaxSysFlag* = 127; (* shortint *) + CProcFlag* = 1; (* code procedures *) + + (* maximal condition value of parameter of SYSTEM.CC *) + MaxCC* = 15; + + (* initialization of constant address, must be different from any valid constant address *) + ConstNotAlloc* = -1; + + (* whether hidden pointer fields have to be nevertheless exported *) + ExpHdPtrFld* = TRUE; + HdPtrName* = "@ptr"; + + (* whether hidden untagged pointer fields have to be nevertheless exported *) + ExpHdUtPtrFld* = TRUE; + HdUtPtrName* = "@utptr"; + + (* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *) + ExpHdProcFld* = TRUE; + HdProcName* = "@proc"; + + (* whether hidden bound procedures have to be nevertheless exported *) + ExpHdTProc* = FALSE; + HdTProcName* = "@tproc"; + + (* maximal number of exported stuctures: *) + MaxStruct* = 16000; (* must be < MAX(INTEGER) DIV 2 in object model *) + + (* maximal number of record extensions: *) + MaxExts* = 15; (* defined by type descriptor layout *) + + (* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *) + NEWusingAdr* = FALSE; + + (* special character (< " ") returned by procedure Get, if end of text reached *) + Eot* = 0X; + + (* warnings *) + longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7; + + (* language options *) + interface* = 1; + com* = 2; comAware* = 3; + som* = 4; somAware* = 5; + oberon* = 6; + java* = 7; javaAware* = 8; + noCode* = 9; + allSysVal* = 14; + sysImp* = 15; + trap* = 31; + sys386 = 10; sys68k = 20; (* processor type in options if system imported *) + + CONST + SFdir = "Sym"; + OFdir = "Code"; + SYSdir = "System"; + SFtag = 6F4F5346H; (* symbol file tag *) + OFtag = 6F4F4346H; (* object file tag *) + maxErrors = 64; + +TYPE + File = POINTER TO RECORD next: File; f: Files.File END; + + VAR + LEHost*: BOOLEAN; (* little or big endian host *) + MinReal32*, MaxReal32*, InfReal*, + MinReal64*, MaxReal64*: REAL; + noerr*: BOOLEAN; (* no error found until now *) + curpos*, startpos*, errpos*: INTEGER; (* character, start, and error position in source file *) + searchpos*: INTEGER; (* search position in source file *) + errors*: INTEGER; + breakpc*: INTEGER; (* set by OPV.Init *) + options*: SET; (* language options *) + file*: Files.File; (* used for sym file import *) + codeDir*: ARRAY 16 OF CHAR; + symDir*: ARRAY 16 OF CHAR; + checksum*: INTEGER; (* symbol file checksum *) + + lastpos: INTEGER; + realpat: INTEGER; + lrealpat: RECORD H, L: INTEGER END; + fpi, fpj: SHORTINT; fp: ARRAY 4 OF SHORTCHAR; + ObjFName: Files.Name; + + in: TextModels.Reader; + oldSymFile, symFile, objFile: Files.File; + inSym: Files.Reader; + outSym, outObj: Files.Writer; + + errNo, errPos: ARRAY maxErrors OF INTEGER; + + lineReader: TextModels.Reader; + lineNum: INTEGER; + + crc32tab: ARRAY 256 OF INTEGER; + + + PROCEDURE^ err* (n: INTEGER); + + PROCEDURE Init* (source: TextModels.Reader; logtext: TextModels.Model); + BEGIN + in := source; + DevMarkers.Unmark(in.Base()); + noerr := TRUE; options := {}; + curpos := in.Pos(); errpos := curpos; lastpos := curpos - 11; errors := 0; + codeDir := OFdir; symDir := SFdir + END Init; + + PROCEDURE Close*; + BEGIN + oldSymFile := NIL; inSym := NIL; + symFile := NIL; outSym := NIL; + objFile := NIL; outObj := NIL; + in := NIL; lineReader := NIL + END Close; + + PROCEDURE Get* (VAR ch: SHORTCHAR); + VAR ch1: CHAR; + BEGIN + REPEAT in.ReadChar(ch1); INC(curpos) UNTIL (ch1 < 100X) & (ch1 # TextModels.viewcode); + ch := SHORT(ch1) + END Get; + + PROCEDURE GetL* (VAR ch: CHAR); + BEGIN + REPEAT in.ReadChar(ch); INC(curpos) UNTIL ch # TextModels.viewcode; + END GetL; + + PROCEDURE LineOf* (pos: INTEGER): INTEGER; + VAR ch: CHAR; + BEGIN + IF lineReader = NIL THEN lineReader := in.Base().NewReader(NIL); lineReader.SetPos(0); lineNum := 0 END; + IF lineReader.Pos() > pos THEN lineReader.SetPos(0); lineNum := 0 END; + WHILE lineReader.Pos() < pos DO + lineReader.ReadChar(ch); + IF ch = 0DX THEN INC(lineNum) END + END; + RETURN lineNum + END LineOf; + + PROCEDURE LoWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF ~LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END LoWord; + + PROCEDURE HiWord (r: REAL): INTEGER; + VAR x: INTEGER; + BEGIN + x := SYSTEM.ADR(r); + IF LEHost THEN INC(x, 4) END; + SYSTEM.GET(x, x); + RETURN x + END HiWord; + + PROCEDURE Compound (lo, hi: INTEGER): REAL; + VAR r: REAL; + BEGIN + IF LEHost THEN + SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi) + ELSE + SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi) + END; + RETURN r + END Compound; + + + (* sysflag control *) + + PROCEDURE ValidGuid* (VAR str: ARRAY OF SHORTCHAR): BOOLEAN; + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN + IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END; + i := 1; + WHILE i < 37 DO + ch := str[i]; + IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN + IF ch # "-" THEN RETURN FALSE END + ELSE + IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END + END; + INC(i) + END; + RETURN TRUE + END ValidGuid; + + PROCEDURE GetProcSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF id # "" THEN + IF id = "code" THEN num := 1 + ELSIF id = "callback" THEN num := 2 + ELSIF id = "nostkchk" THEN num := 4 + ELSIF id = "ccall" THEN num := -10 + ELSIF id = "guarded" THEN num := 8 + ELSIF id = "noframe" THEN num := 16 + ELSIF id = "native" THEN num := -33 + ELSIF id = "bytecode" THEN num := -35 + END + END; + IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num) + ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num) + ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10 + ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8 + ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16 + ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num + ELSE err(225); flag := 0 + END + END GetProcSysFlag; + + PROCEDURE GetVarParSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (options * {sys386, sys68k, interface, com} # {}) THEN + IF (num = 1) OR (id = "nil") THEN + IF ~ODD(old) THEN flag := SHORT(old + 1) END + ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 2) END + ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 4) END + ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN + IF old <= 1 THEN flag := SHORT(old + 8) END + ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN + IF old <= 1 THEN flag := SHORT(old + 16) END + END + END; + IF flag = 0 THEN err(225) END + END GetVarParSysFlag; + + PROCEDURE GetRecordSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 3) OR (id = "noalign") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END + ELSIF (num = 4) OR (id = "align2") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END + ELSIF (num = 5) OR (id = "align4") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END + ELSIF (num = 6) OR (id = "align8") THEN + IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END + ELSIF (num = 7) OR (id = "union") THEN + IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END + ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = -11) OR (id = "jint") THEN + IF (java IN options) & (old = 0) THEN flag := -11 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetRecordSysFlag; + + PROCEDURE GetArraySysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = -12) OR (id = "jarr") THEN + IF (java IN options) & (old = 0) THEN flag := -12 END + ELSIF (num = -13) OR (id = "jstr") THEN + IF (java IN options) & (old = 0) THEN flag := -13 END + END; + IF flag = 0 THEN err(225) END + END GetArraySysFlag; + + PROCEDURE GetPointerSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + VAR old: SHORTINT; + BEGIN + old := flag; flag := 0; + IF (num = 1) OR (id = "untagged") THEN + IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END + ELSIF (num = 2) OR (id = "handle") THEN + IF (sys68k IN options) & (old = 0) THEN flag := 2 END + ELSIF (num = 10) OR (id = "interface") THEN + IF (com IN options) & (old = 0) THEN flag := 10 END + ELSIF (num = 20) OR (id = "som") THEN + IF (som IN options) & (old = 0) THEN flag := 20 END + END; + IF flag = 0 THEN err(225) END + END GetPointerSysFlag; + + PROCEDURE GetProcTypSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10 + ELSE err(225); flag := 0 + END + END GetProcTypSysFlag; + + PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* propagate untagged .. union *) + IF flag = 0 THEN flag := baseFlag + ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *) (* special case for 8 byte aligned records *) + ELSIF flag # baseFlag THEN err(225); flag := 0 + END + ELSIF (baseFlag # 10) & (flag = 10) THEN err(225) + END + END PropagateRecordSysFlag; + + PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN (* pointer to untagged .. union is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = 10 THEN (* pointer to interface is interface *) + IF flag = 0 THEN flag := 10 + ELSIF flag # 10 THEN err(225); flag := 0 + END + ELSIF baseFlag = -11 THEN (* pointer to java interface is java interface *) + IF flag # 0 THEN err(225) END; + flag := -11 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateRecPtrSysFlag; + + PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT); + BEGIN + IF baseFlag = 1 THEN (* pointer to untagged or guid is untagged *) + IF flag = 0 THEN flag := 1 + ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0 + END + ELSIF baseFlag = -12 THEN (* pointer to java array is java array *) + IF flag # 0 THEN err(225) END; + flag := -12 + ELSIF baseFlag = -13 THEN (* pointer to java string is java string *) + IF flag # 0 THEN err(225) END; + flag := -13 + END + END PropagateArrPtrSysFlag; + + + (* utf8 strings *) + + PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER); + BEGIN + ASSERT((val >= 0) & (val < 65536)); + IF val < 128 THEN + str[idx] := SHORT(CHR(val)); INC(idx) + ELSIF val < 2048 THEN + str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + ELSE + str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx); + str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx); + str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx) + END + END PutUtf8; + + PROCEDURE GetUtf8* (VAR str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER); + VAR ch: SHORTCHAR; + BEGIN + ch := str[idx]; INC(idx); + IF ch < 80X THEN + val := ORD(ch) + ELSIF ch < 0E0X THEN + val := ORD(ch) - 192; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + ELSE + val := ORD(ch) - 224; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128; + ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128 + END + END GetUtf8; + + + (* log output *) + + PROCEDURE LogW* (ch: SHORTCHAR); + BEGIN + StdLog.Char(ch) + END LogW; + + PROCEDURE LogWStr* (s: ARRAY OF SHORTCHAR); + VAR str: ARRAY 256 OF CHAR; + BEGIN + str := s$; StdLog.String(str) + END LogWStr; + + PROCEDURE LogWNum* (i, len: INTEGER); + BEGIN + StdLog.Int(i) + END LogWNum; + + PROCEDURE LogWLn*; + BEGIN + StdLog.Ln + END LogWLn; +(* + PROCEDURE LogW* (ch: CHAR); + BEGIN + out.WriteChar(ch); + END LogW; + + PROCEDURE LogWStr* (s: ARRAY OF CHAR); + BEGIN + out.WriteString(s); + END LogWStr; + + PROCEDURE LogWNum* (i, len: LONGINT); + BEGIN + out.WriteChar(" "); out.WriteInt(i); + END LogWNum; + + PROCEDURE LogWLn*; + BEGIN + out.WriteLn; + Views.RestoreDomain(logbuf.Domain()) + END LogWLn; +*) + PROCEDURE Mark* (n, pos: INTEGER); + BEGIN + IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN + noerr := FALSE; + IF pos < 0 THEN pos := 0 END; + IF (pos < lastpos) OR (lastpos + 9 < pos) THEN + lastpos := pos; + IF errors < maxErrors THEN + errNo[errors] := n; errPos[errors] := pos + END; + INC(errors) + END; + IF trap IN options THEN HALT(100) END; + ELSIF (n <= -700) & (errors < maxErrors) THEN + errNo[errors] := -n; errPos[errors] := pos; INC(errors) + END + END Mark; + + PROCEDURE err* (n: INTEGER); + BEGIN + Mark(n, errpos) + END err; + + PROCEDURE InsertMarks* (text: TextModels.Model); + VAR i, j, x, y, n: INTEGER; script: Stores.Operation; + BEGIN + n := errors; + IF n > maxErrors THEN n := maxErrors END; + (* sort *) + i := 1; + WHILE i < n DO + x := errPos[i]; y := errNo[i]; j := i-1; + WHILE (j >= 0) & (errPos[j] > x) DO errPos[j+1] := errPos[j]; errNo[j+1] := errNo[j]; DEC(j) END; + errPos[j+1] := x; errNo[j+1] := y; INC(i) + END; + (* insert *) + Models.BeginModification(Models.clean, text); + Models.BeginScript(text, "#Dev:InsertMarkers", script); + WHILE n > 0 DO DEC(n); + DevMarkers.Insert(text, errPos[n], DevMarkers.dir.New(errNo[n])) + END; + Models.EndScript(text, script); + Models.EndModification(Models.clean, text); + END InsertMarks; + + + (* fingerprinting *) + + PROCEDURE InitCrcTab; + (* CRC32, high bit first, pre & post inverted *) + CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26}; (* CRC32 polynom *) + VAR x, c, i: INTEGER; + BEGIN + x := 0; + WHILE x < 256 DO + c := x * 1000000H; i := 0; + WHILE i < 8 DO + IF c < 0 THEN c := ORD(BITS(c * 2) / poly) + ELSE c := c * 2 + END; + INC(i) + END; + crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255)); + INC(x) + END + END InitCrcTab; + + PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER); + VAR c: INTEGER; + BEGIN +(* + fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1) (* bad collision detection *) +*) + (* CRC32, high bit first, pre & post inverted *) + c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256])); + c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256])); + fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256])); + END FPrint; + + PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET); + BEGIN FPrint(fp, ORD(set)) + END FPrintSet; + + PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL); + BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real)) + END FPrintReal; + + PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL); + VAR l, h: INTEGER; + BEGIN + FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr)) + END FPrintLReal; + + PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER); (* symbolfile checksum *) + BEGIN + (* same as FPrint, 8 bit only *) + fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256])) + END ChkSum; + + + + (* compact format *) + + PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER); + BEGIN + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256; + ChkSum(checksum, i); + w.WriteByte(SHORT(SHORT(i MOD 256))) + END WriteLInt; + + PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; x: INTEGER; + BEGIN + r.ReadByte(b); x := b MOD 256; + ChkSum(checksum, b); + r.ReadByte(b); x := x + 100H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); x := x + 10000H * (b MOD 256); + ChkSum(checksum, b); + r.ReadByte(b); i := x + 1000000H * b; + ChkSum(checksum, b) + END ReadLInt; + + PROCEDURE WriteNum (w: Files.Writer; i: INTEGER); + BEGIN (* old format of Oberon *) + WHILE (i < -64) OR (i > 63) DO ChkSum(checksum, i MOD 128 - 128); w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END; + ChkSum(checksum, i MOD 128); + w.WriteByte(SHORT(SHORT(i MOD 128))) + END WriteNum; + + PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER); + VAR b: BYTE; s, y: INTEGER; + BEGIN + s := 0; y := 0; r.ReadByte(b); + IF ~r.eof THEN ChkSum(checksum, b) END; + WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END; + i := ASH((b + 64) MOD 128 - 64, s) + y; + END ReadNum; + + PROCEDURE WriteNumSet (w: Files.Writer; x: SET); + BEGIN + WriteNum(w, ORD(x)) + END WriteNumSet; + + PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET); + VAR i: INTEGER; + BEGIN + ReadNum(r, i); x := BITS(i) + END ReadNumSet; + + PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL); + BEGIN + WriteLInt(w, SYSTEM.VAL(INTEGER, x)) + END WriteReal; + + PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL); + VAR i: INTEGER; + BEGIN + ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i) + END ReadReal; + + PROCEDURE WriteLReal (w: Files.Writer; x: REAL); + BEGIN + WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x)) + END WriteLReal; + + PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL); + VAR h, l: INTEGER; + BEGIN + ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h) + END ReadLReal; + + + (* read symbol file *) + + PROCEDURE SymRCh* (VAR ch: SHORTCHAR); + VAR b: BYTE; + BEGIN + inSym.ReadByte(b); ch := SHORT(CHR(b)); + ChkSum(checksum, b) + END SymRCh; + + PROCEDURE SymRInt* (): INTEGER; + VAR k: INTEGER; + BEGIN + ReadNum(inSym, k); RETURN k + END SymRInt; + + PROCEDURE SymRSet* (VAR s: SET); + BEGIN + ReadNumSet(inSym, s) + END SymRSet; + + PROCEDURE SymRReal* (VAR r: SHORTREAL); + BEGIN + ReadReal(inSym, r) + END SymRReal; + + PROCEDURE SymRLReal* (VAR lr: REAL); + BEGIN + ReadLReal(inSym, lr) + END SymRLReal; + + PROCEDURE eofSF* (): BOOLEAN; + BEGIN + RETURN inSym.eof + END eofSF; + + PROCEDURE OldSym* (VAR modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN); + VAR tag: INTEGER; loc: Files.Locator; dir, name: Files.Name; + BEGIN + done := FALSE; + IF modName = "@file" THEN + oldSymFile := file + ELSE + name := modName$; Kernel.SplitName(name, dir, name); + Kernel.MakeFileName(name, Kernel.symType); + loc := Files.dir.This(dir); loc := loc.This(symDir); + oldSymFile := Files.dir.Old(loc, name, Files.shared); + IF (oldSymFile = NIL) & (dir = "") THEN + loc := Files.dir.This(SYSdir); loc := loc.This(symDir); + oldSymFile := Files.dir.Old(loc, name, Files.shared) + END + END; + IF oldSymFile # NIL THEN + inSym := oldSymFile.NewReader(inSym); + IF inSym # NIL THEN + ReadLInt(inSym, tag); + IF tag = SFtag THEN done := TRUE ELSE err(151) END + END + END + END OldSym; + + PROCEDURE CloseOldSym*; + BEGIN + IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END + END CloseOldSym; + + + (* write symbol file *) + + PROCEDURE SymWCh* (ch: SHORTCHAR); + BEGIN + ChkSum(checksum, ORD(ch)); + outSym.WriteByte(SHORT(ORD(ch))) + END SymWCh; + + PROCEDURE SymWInt* (i: INTEGER); + BEGIN + WriteNum(outSym, i) + END SymWInt; + + PROCEDURE SymWSet* (s: SET); + BEGIN + WriteNumSet(outSym, s) + END SymWSet; + + PROCEDURE SymWReal* (VAR r: SHORTREAL); + BEGIN + WriteReal(outSym, r) + END SymWReal; + + PROCEDURE SymWLReal* (VAR r: REAL); + BEGIN + WriteLReal(outSym, r) + END SymWLReal; + + PROCEDURE SymReset*; + BEGIN + outSym.SetPos(4) + END SymReset; + + PROCEDURE NewSym* (VAR modName: ARRAY OF SHORTCHAR); + VAR loc: Files.Locator; dir: Files.Name; + BEGIN + ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName); + loc := Files.dir.This(dir); loc := loc.This(symDir); + symFile := Files.dir.New(loc, Files.ask); + IF symFile # NIL THEN + outSym := symFile.NewWriter(NIL); + WriteLInt(outSym, SFtag) + ELSE + err(153) + END + END NewSym; + + PROCEDURE RegisterNewSym*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF symFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.symType); + symFile.Register(name, Kernel.symType, Files.ask, res); + symFile := NIL + END + END RegisterNewSym; + + PROCEDURE DeleteNewSym*; + BEGIN + IF symFile # NIL THEN symFile.Close; symFile := NIL END + END DeleteNewSym; + + + (* write object file *) + + PROCEDURE ObjW* (ch: SHORTCHAR); + BEGIN + outObj.WriteByte(SHORT(ORD(ch))) + END ObjW; + + PROCEDURE ObjWNum* (i: INTEGER); + BEGIN + WriteNum(outObj, i) + END ObjWNum; + + PROCEDURE ObjWInt (i: SHORTINT); + BEGIN + outObj.WriteByte(SHORT(SHORT(i MOD 256))); + outObj.WriteByte(SHORT(SHORT(i DIV 256))) + END ObjWInt; + + PROCEDURE ObjWLInt* (i: INTEGER); + BEGIN + ObjWInt(SHORT(i MOD 65536)); + ObjWInt(SHORT(i DIV 65536)) + END ObjWLInt; + + PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SHORTCHAR; n: INTEGER); + TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE; + VAR p: P; + BEGIN + p := SYSTEM.VAL(P, SYSTEM.ADR(bytes)); + outObj.WriteBytes(p^, 0, n) + END ObjWBytes; + + PROCEDURE ObjLen* (): INTEGER; + BEGIN + RETURN outObj.Pos() + END ObjLen; + + PROCEDURE ObjSet* (pos: INTEGER); + BEGIN + outObj.SetPos(pos) + END ObjSet; + + PROCEDURE NewObj* (VAR modName: ARRAY OF SHORTCHAR); + VAR loc: Files.Locator; dir: Files.Name; + BEGIN + errpos := 0; + ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName); + loc := Files.dir.This(dir); loc := loc.This(codeDir); + objFile := Files.dir.New(loc, Files.ask); + IF objFile # NIL THEN + outObj := objFile.NewWriter(NIL); + WriteLInt(outObj, OFtag) + ELSE + err(153) + END + END NewObj; + + PROCEDURE RegisterObj*; + VAR res: INTEGER; name: Files.Name; + BEGIN + IF objFile # NIL THEN + name := ObjFName$; + Kernel.MakeFileName(name, Kernel.objType); + objFile.Register(name, Kernel.objType, Files.ask, res); + objFile := NIL; outObj := NIL + END + END RegisterObj; + + PROCEDURE DeleteObj*; + BEGIN + IF objFile # NIL THEN objFile.Close; objFile := NIL END + END DeleteObj; + + + PROCEDURE InitHost; + VAR test: SHORTINT; lo: SHORTCHAR; + BEGIN + test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X; + InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat); + MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat); + MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat); + MinReal64 := Compound(MinReal64PatL, MinReal64PatH); + MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH) + END InitHost; + +BEGIN + InitCrcTab; + InitHost +END DevCPM. diff --git a/Trurl-based/Dev/Mod/CPP.txt b/Trurl-based/Dev/Mod/CPP.txt new file mode 100644 index 0000000..b2fa032 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPP.txt @@ -0,0 +1,1650 @@ +MODULE DevCPP; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPP.odc *) + (* DO NOT EDIT *) + + IMPORT + DevCPM, DevCPT, DevCPB, DevCPS; + + CONST + anchorVarPar = TRUE; + + (* numtyp values *) + char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7; + + (*symbol values*) + null = 0; times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; arrow = 17; dollar = 18; period = 19; + comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24; + rbrace = 25; of = 26; then = 27; do = 28; to = 29; + by = 30; not = 33; + lparen = 40; lbrak = 41; lbrace = 42; becomes = 44; + number = 45; nil = 46; string = 47; ident = 48; semicolon = 49; + bar = 50; end = 51; else = 52; elsif = 53; until = 54; + if = 55; case = 56; while = 57; repeat = 58; for = 59; + loop = 60; with = 61; exit = 62; return = 63; array = 64; + record = 65; pointer = 66; begin = 67; const = 68; type = 69; + var = 70; out = 71; procedure = 72; close = 73; import = 74; + module = 75; eof = 76; + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20; + + (* Structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + intSet = {Int8..Int32, Int64}; charSet = {Char8, Char16}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (*function number*) + haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + + (* node subclasses *) + super = 1; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* sysflags *) + nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; som = 20; jstr = -13; + + + TYPE + Elem = POINTER TO RECORD + next: Elem; + struct: DevCPT.Struct; + obj, base: DevCPT.Object; + pos: INTEGER; + name: DevCPT.String + END; + + + VAR + sym, level: BYTE; + LoopLevel: SHORTINT; + TDinit, lastTDinit: DevCPT.Node; + userList: Elem; + recList: Elem; + hasReturn: BOOLEAN; + numUsafeVarPar, numFuncVarPar: INTEGER; + + + PROCEDURE^ Type(VAR typ: DevCPT.Struct; VAR name: DevCPT.String); + PROCEDURE^ Expression(VAR x: DevCPT.Node); + PROCEDURE^ Block(VAR procdec, statseq: DevCPT.Node); + + (* forward type handling *) + + PROCEDURE IncompleteType (typ: DevCPT.Struct): BOOLEAN; + BEGIN + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + RETURN (typ = DevCPT.undftyp) OR (typ.comp = Record) & (typ.BaseTyp = DevCPT.undftyp) + END IncompleteType; + + PROCEDURE SetType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; name: DevCPT.String); + VAR u: Elem; + BEGIN + IF obj # NIL THEN obj.typ := typ ELSE struct.BaseTyp := typ END; + IF name # NIL THEN + NEW(u); u.struct := struct; u.obj := obj; u.pos := DevCPM.errpos; u.name := name; + u.next := userList; userList := u + END + END SetType; + + PROCEDURE CheckAlloc (VAR typ: DevCPT.Struct; dynAllowed: BOOLEAN; pos: INTEGER); + BEGIN + typ.pvused := TRUE; + IF typ.comp = DynArr THEN + IF ~dynAllowed THEN DevCPM.Mark(88, pos); typ := DevCPT.undftyp END + ELSIF typ.comp = Record THEN + IF (typ.attribute = absAttr) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN + DevCPM.Mark(193, pos); typ := DevCPT.undftyp + END + END + END CheckAlloc; + + PROCEDURE CheckRecursiveType (outer, inner: DevCPT.Struct; pos: INTEGER); + VAR fld: DevCPT.Object; + BEGIN + IF outer = inner THEN DevCPM.Mark(58, pos) + ELSIF inner.comp IN {Array, DynArr} THEN CheckRecursiveType(outer, inner.BaseTyp, pos) + ELSIF inner.comp = Record THEN + fld := inner.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + CheckRecursiveType(outer, fld.typ, pos); + fld := fld.link + END; + IF inner.BaseTyp # NIL THEN CheckRecursiveType(outer, inner.BaseTyp, pos) END + END + END CheckRecursiveType; + + PROCEDURE FixType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER); + (* fix forward reference *) + VAR t: DevCPT.Struct; f, bf: DevCPT.Object; i: SHORTINT; + BEGIN + IF obj # NIL THEN + IF obj.mode = Var THEN (* variable type *) + IF struct # NIL THEN (* receiver type *) + IF (typ.form # Pointer) OR (typ.BaseTyp # struct) THEN DevCPM.Mark(180, pos) END; + ELSE CheckAlloc(typ, obj.mnolev > level, pos) (* TRUE for parameters *) + END + ELSIF obj.mode = VarPar THEN (* varpar type *) + IF struct # NIL THEN (* varpar receiver type *) + IF typ # struct THEN DevCPM.Mark(180, pos) END + END + ELSIF obj.mode = Fld THEN (* field type *) + CheckAlloc(typ, FALSE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF obj.mode = TProc THEN (* proc return type *) + IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END + ELSIF obj.mode = Typ THEN (* alias type *) + IF typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *) + t := DevCPT.NewStr(typ.form, Basic); i := t.ref; + t^ := typ^; t.ref := i; t.strobj := obj; t.mno := 0; + t.BaseTyp := typ; typ := t + END; + IF obj.vis # internal THEN + IF typ.comp = Record THEN typ.exp := TRUE + ELSIF typ.form = Pointer THEN typ.BaseTyp.exp := TRUE + END + END + ELSE HALT(100) + END; + obj.typ := typ + ELSE + IF struct.form = Pointer THEN (* pointer base type *) + IF typ.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.sysflag, struct.sysflag) + ELSIF typ.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.sysflag, struct.sysflag) + ELSE typ := DevCPT.undftyp; DevCPM.Mark(57, pos) + END; + struct.untagged := struct.sysflag > 0; + IF (struct.strobj # NIL) & (struct.strobj.vis # internal) THEN typ.exp := TRUE END; + ELSIF struct.comp = Array THEN (* array base type *) + CheckAlloc(typ, FALSE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF struct.comp = DynArr THEN (* array base type *) + CheckAlloc(typ, TRUE, pos); + CheckRecursiveType(struct, typ, pos) + ELSIF struct.comp = Record THEN (* record base type *) + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + typ.pvused := TRUE; struct.extlev := SHORT(SHORT(typ.extlev + 1)); + DevCPM.PropagateRecordSysFlag(typ.sysflag, struct.sysflag); + IF (typ.attribute = 0) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN DevCPM.Mark(181, pos) + ELSIF (struct.attribute = absAttr) & (typ.attribute # absAttr) THEN DevCPM.Mark(191, pos) + ELSIF (typ.attribute = limAttr) & (struct.attribute # limAttr) THEN DevCPM.Mark(197, pos) + END; + f := struct.link; + WHILE f # NIL DO (* check for field name conflicts *) + DevCPT.FindField(f.name, typ, bf); + IF bf # NIL THEN DevCPM.Mark(1, pos) END; + f := f.link + END; + CheckRecursiveType(struct, typ, pos); + struct.untagged := struct.sysflag > 0; + ELSIF struct.form = ProcTyp THEN (* proc type return type *) + IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END; + ELSE HALT(100) + END; + struct.BaseTyp := typ + END + END FixType; + + PROCEDURE CheckForwardTypes; + VAR u, next: Elem; progress: BOOLEAN; + BEGIN + u := userList; userList := NIL; + WHILE u # NIL DO + next := u.next; DevCPS.name := u.name^$; DevCPT.Find(DevCPS.name, u.base); + IF u.base = NIL THEN DevCPM.Mark(0, u.pos) + ELSIF u.base.mode # Typ THEN DevCPM.Mark(72, u.pos) + ELSE u.next := userList; userList := u (* reinsert *) + END; + u := next + END; + REPEAT (* iteration for multy level alias *) + u := userList; userList := NIL; progress := FALSE; + WHILE u # NIL DO + next := u.next; + IF IncompleteType(u.base.typ) THEN + u.next := userList; userList := u (* reinsert *) + ELSE + progress := TRUE; + FixType(u.struct, u.obj, u.base.typ, u.pos) + END; + u := next + END + UNTIL (userList = NIL) OR ~progress; + u := userList; (* remaining type relations are cyclic *) + WHILE u # NIL DO + IF (u.obj = NIL) OR (u.obj.mode = Typ) THEN DevCPM.Mark(58, u.pos) END; + u := u.next + END; + END CheckForwardTypes; + + PROCEDURE CheckUnimpl (m: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER); + VAR obj: DevCPT.Object; + BEGIN + IF m # NIL THEN + IF (m.mode = TProc) & (absAttr IN m.conval.setval) THEN + DevCPT.FindField(m.name^, typ, obj); + IF (obj = NIL) OR (obj.mode # TProc) OR (absAttr IN obj.conval.setval) THEN + DevCPM.Mark(192, pos); + DevCPM.LogWLn; DevCPM.LogWStr(" "); DevCPM.LogWStr(m.name^); + DevCPM.LogWStr(" not implemented"); + IF typ.strobj # NIL THEN + DevCPM.LogWStr(" in "); DevCPM.LogWStr(typ.strobj.name^) + END + END + END; + CheckUnimpl(m.left, typ, pos); + CheckUnimpl(m.right, typ, pos) + END + END CheckUnimpl; + + PROCEDURE CheckRecords (rec: Elem); + VAR b: DevCPT.Struct; + BEGIN + WHILE rec # NIL DO (* check for unimplemented methods in base type *) + b := rec.struct.BaseTyp; + WHILE (b # NIL) & (b # DevCPT.undftyp) DO + CheckUnimpl(b.link, rec.struct, rec.pos); + b := b.BaseTyp + END; + rec := rec.next + END + END CheckRecords; + + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE CheckSym(s: SHORTINT); + BEGIN + IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END + END CheckSym; + + PROCEDURE qualident(VAR id: DevCPT.Object); + VAR obj: DevCPT.Object; lev: BYTE; + BEGIN (*sym = ident*) + DevCPT.Find(DevCPS.name, obj); DevCPS.Get(sym); + IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN + DevCPS.Get(sym); + IF sym = ident THEN + DevCPT.FindImport(DevCPS.name, obj, obj); DevCPS.Get(sym) + ELSE err(ident); obj := NIL + END + END ; + IF obj = NIL THEN err(0); + obj := DevCPT.NewObj(); obj.mode := Var; obj.typ := DevCPT.undftyp; obj.adr := 0 + ELSE lev := obj.mnolev; + IF (obj.mode IN {Var, VarPar}) & (lev # level) THEN + obj.leaf := FALSE; + IF lev > 0 THEN DevCPB.StaticLink(SHORT(SHORT(level-lev)), TRUE) END (* !!! *) + END + END ; + id := obj + END qualident; + + PROCEDURE ConstExpression(VAR x: DevCPT.Node); + BEGIN Expression(x); + IF x.class # Nconst THEN + err(50); x := DevCPB.NewIntConst(1) + END + END ConstExpression; + + PROCEDURE CheckMark(obj: DevCPT.Object); (* !!! *) + VAR n: INTEGER; mod: ARRAY 256 OF DevCPT.String; + BEGIN DevCPS.Get(sym); + IF (sym = times) OR (sym = minus) THEN + IF (level > 0) OR ~(obj.mode IN {Var, Fld, TProc}) & (sym = minus) THEN err(41) END ; + IF sym = times THEN obj.vis := external ELSE obj.vis := externalR END ; + DevCPS.Get(sym) + ELSE obj.vis := internal + END; + IF (obj.mode IN {TProc, LProc, XProc, CProc, Var, Typ, Con, Fld}) & (sym = lbrak) THEN + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END; + DevCPS.Get(sym); n := 0; + IF (sym = comma) & (obj.mode IN {LProc, XProc, CProc, Var, Con}) THEN + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + obj.library := obj.entry; obj.entry := NIL; + IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END; + DevCPS.Get(sym); + ELSE err(string) + END + END; + WHILE sym = comma DO + DevCPS.Get(sym); + IF (sym = number) & (DevCPS.numtyp = char) THEN + NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string + END; + IF sym = string THEN + IF n < LEN(mod) THEN mod[n] := DevCPS.str; INC(n) + ELSE err(235) + END; + DevCPS.Get(sym) + ELSE err(string) + END + END; + IF n > 0 THEN + NEW(obj.modifiers, n); + WHILE n > 0 DO DEC(n); obj.modifiers[n] := mod[n] END + END + ELSE err(string) + END; + CheckSym(rbrak); + IF DevCPM.options * {DevCPM.interface, DevCPM.java} = {} THEN err(225) END + END + END CheckMark; + + PROCEDURE CheckSysFlag (VAR sysflag: SHORTINT; + GetSF: PROCEDURE(id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT)); + VAR x: DevCPT.Object; i: SHORTINT; + BEGIN + sysflag := 0; + IF sym = lbrak THEN + DevCPS.Get(sym); + WHILE (sym = number) OR (sym = ident) OR (sym = string) DO + IF sym = number THEN + IF DevCPS.numtyp = integer THEN + i := SHORT(DevCPS.intval); GetSF("", i, sysflag) + ELSE err(225) + END + ELSIF sym = ident THEN + DevCPT.Find(DevCPS.name, x); + IF (x # NIL) & (x.mode = Con) & (x.typ.form IN {Int8, Int16, Int32}) THEN + i := SHORT(x.conval.intval); GetSF("", i, sysflag) + ELSE + GetSF(DevCPS.name, 0, sysflag) + END + ELSE + GetSF(DevCPS.str^, 0, sysflag) + END; + DevCPS.Get(sym); + IF (sym = comma) OR (sym = plus) THEN DevCPS.Get(sym) END + END; + CheckSym(rbrak) + END + END CheckSysFlag; + + PROCEDURE Receiver(VAR mode, vis: BYTE; VAR name: DevCPT.Name; VAR typ, rec: DevCPT.Struct); + VAR obj: DevCPT.Object; tname: DevCPT.String; + BEGIN typ := DevCPT.undftyp; rec := NIL; vis := 0; + IF sym = var THEN DevCPS.Get(sym); mode := VarPar; + ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar (* ??? *) + ELSE mode := Var + END ; + name := DevCPS.name; CheckSym(ident); CheckSym(colon); + IF sym # ident THEN err(ident) END; + Type(typ, tname); + IF tname = NIL THEN + IF typ.form = Pointer THEN rec := typ.BaseTyp ELSE rec := typ END; + IF ~((mode = Var) & (typ.form = Pointer) & (rec.comp = Record) OR + (mode = VarPar) & (typ.comp = Record)) THEN err(70); rec := NIL END; + IF (rec # NIL) & (rec.mno # level) THEN err(72); rec := NIL END + ELSE err(0) + END; + CheckSym(rparen); + IF rec = NIL THEN rec := DevCPT.NewStr(Comp, Record); rec.BaseTyp := NIL END + END Receiver; + + PROCEDURE FormalParameters( + VAR firstPar: DevCPT.Object; VAR resTyp: DevCPT.Struct; VAR name: DevCPT.String + ); + VAR mode, vis: BYTE; sys: SHORTINT; + par, first, last, res, newPar, iidPar: DevCPT.Object; typ: DevCPT.Struct; + BEGIN + first := NIL; last := firstPar; + newPar := NIL; iidPar := NIL; + IF (sym = ident) OR (sym = var) OR (sym = in) OR (sym = out) THEN + LOOP + sys := 0; vis := 0; + IF sym = var THEN DevCPS.Get(sym); mode := VarPar + ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar + ELSIF sym = out THEN DevCPS.Get(sym); mode := VarPar; vis := outPar + ELSE mode := Var + END ; + IF mode = VarPar THEN CheckSysFlag(sys, DevCPM.GetVarParSysFlag) END; + IF ODD(sys DIV inBit) THEN vis := inPar + ELSIF ODD(sys DIV outBit) THEN vis := outPar + END; + IF ODD(sys DIV newBit) & (vis # outPar) THEN err(225) + ELSIF ODD(sys DIV iidBit) & (vis # inPar) THEN err(225) + END; + LOOP + IF sym = ident THEN + DevCPT.Insert(DevCPS.name, par); DevCPS.Get(sym); + par.mode := mode; par.link := NIL; par.vis := vis; par.sysflag := SHORT(sys); + IF first = NIL THEN first := par END ; + IF firstPar = NIL THEN firstPar := par ELSE last.link := par END ; + last := par + ELSE err(ident) + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSIF sym = var THEN err(comma); DevCPS.Get(sym) + ELSE EXIT + END + END ; + CheckSym(colon); Type(typ, name); + IF mode # VarPar THEN CheckAlloc(typ, TRUE, DevCPM.errpos) END; + IF (mode = VarPar) & (vis = inPar) & (typ.form # Undef) & (typ.form # Comp) & (typ.sysflag = 0) THEN err(177) + END; + (* typ.pbused is set when parameter type name is parsed *) + WHILE first # NIL DO + SetType (NIL, first, typ, name); + IF DevCPM.com IN DevCPM.options THEN + IF ODD(sys DIV newBit) THEN + IF (newPar # NIL) OR (typ.form # Pointer) OR (typ.sysflag # interface) THEN err(168) END; + newPar := first + ELSIF ODD(sys DIV iidBit) THEN + IF (iidPar # NIL) OR (typ # DevCPT.guidtyp) THEN err(168) END; + iidPar := first + END + END; + first := first.link + END; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(semicolon) + ELSE EXIT + END + END + END; + CheckSym(rparen); + IF (newPar = NIL) # (iidPar = NIL) THEN err(168) END; + name := NIL; + IF sym = colon THEN + DevCPS.Get(sym); + Type(resTyp, name); + IF resTyp.form = Comp THEN resTyp := DevCPT.undftyp; err(54) END + ELSE resTyp := DevCPT.notyp + END + END FormalParameters; + + PROCEDURE CheckOverwrite (proc, base: DevCPT.Object; rec: DevCPT.Struct); + VAR o, bo: DevCPT.Object; + BEGIN + IF base # NIL THEN + IF base.conval.setval * {absAttr, empAttr, extAttr} = {} THEN err(182) END; + IF (proc.link.mode # base.link.mode) OR (proc.link.vis # base.link.vis) + OR ~DevCPT.Extends(proc.link.typ, base.link.typ) THEN err(115) END; + o := proc.link; bo := base.link; + WHILE (o # NIL) & (bo # NIL) DO + IF (bo.sysflag # 0) & (o.sysflag = 0) THEN (* propagate sysflags *) + o.sysflag := bo.sysflag + END; + o := o.link; bo := bo.link + END; + DevCPB.CheckParameters(proc.link.link, base.link.link, FALSE); + IF ~DevCPT.Extends(proc.typ, base.typ) THEN err(117) END; + IF (base.vis # proc.vis) & ((proc.vis # internal) OR rec.exp) THEN err(183) END; + INCL(proc.conval.setval, isRedef) + END; + END CheckOverwrite; + + PROCEDURE GetAttributes (proc, base: DevCPT.Object; owner: DevCPT.Struct); (* read method attributes *) + VAR attr, battr: SET; o: DevCPT.Object; + BEGIN + attr := {}; + IF sym = comma THEN (* read attributes *) + DevCPS.Get(sym); + IF sym = ident THEN + DevCPT.Find(DevCPS.name, o); + IF (o # NIL) & (o.mode = SProc) & (o.adr = newfn) THEN + IF ~(DevCPM.oberon IN DevCPM.options) THEN INCL(attr, newAttr) ELSE err(178) END; + DevCPS.Get(sym); + IF sym = comma THEN + DevCPS.Get(sym); + IF sym = ident THEN DevCPT.Find(DevCPS.name, o) ELSE o := NIL; err(ident) END + ELSE o := NIL + END + END; + IF o # NIL THEN + IF (o.mode # Attr) OR (o.adr = limAttr) OR (DevCPM.oberon IN DevCPM.options) THEN err(178) + ELSE INCL(attr, o.adr) + END; + DevCPS.Get(sym) + END + ELSE err(ident) + END + END; + IF (base = NIL) & ~(newAttr IN attr) THEN err(185); INCL(attr, newAttr) + ELSIF (base # NIL) & (newAttr IN attr) THEN err(186) + END; + IF absAttr IN attr THEN + IF owner.attribute # absAttr THEN err(190) END; + IF (proc.vis = internal) & owner.exp THEN err(179) END + END; + IF (owner.attribute = 0) OR (owner.attribute = limAttr) THEN + IF (empAttr IN attr) & (newAttr IN attr) THEN err(187) +(* + ELSIF extAttr IN attr THEN err(188) +*) + END + END; + IF base # NIL THEN + battr := base.conval.setval; + IF empAttr IN battr THEN + IF absAttr IN attr THEN err(189) END + ELSIF ~(absAttr IN battr) THEN + IF (absAttr IN attr) OR (empAttr IN attr) THEN err(189) END + END + END; + IF empAttr IN attr THEN + IF proc.typ # DevCPT.notyp THEN err(195) + ELSE + o := proc.link; WHILE (o # NIL) & (o.vis # outPar) DO o := o.link END; + IF o # NIL THEN err(195) END + END + END; + IF (owner.sysflag = interface) & ~(absAttr IN attr) THEN err(162) END; + proc.conval.setval := attr + END GetAttributes; + + PROCEDURE RecordType(VAR typ: DevCPT.Struct; attr: DevCPT.Object); + VAR fld, first, last, base: DevCPT.Object; r: Elem; ftyp: DevCPT.Struct; name: DevCPT.String; + BEGIN typ := DevCPT.NewStr(Comp, Record); typ.BaseTyp := NIL; + CheckSysFlag(typ.sysflag, DevCPM.GetRecordSysFlag); + IF attr # NIL THEN + IF ~(DevCPM.oberon IN DevCPM.options) & (attr.adr # empAttr) THEN typ.attribute := SHORT(SHORT(attr.adr)) + ELSE err(178) + END + END; + IF typ.sysflag = interface THEN + IF (DevCPS.str # NIL) & (DevCPS.str[0] = "{") THEN typ.ext := DevCPS.str END; + IF typ.attribute # absAttr THEN err(163) END; + IF sym # lparen THEN err(160) END + END; + IF sym = lparen THEN + DevCPS.Get(sym); (*record extension*) + IF sym = ident THEN + Type(ftyp, name); + IF ftyp.form = Pointer THEN ftyp := ftyp.BaseTyp END; + SetType(typ, NIL, ftyp, name); + IF (ftyp.comp = Record) & (ftyp # DevCPT.anytyp) THEN + ftyp.pvused := TRUE; typ.extlev := SHORT(SHORT(ftyp.extlev + 1)); + DevCPM.PropagateRecordSysFlag(ftyp.sysflag, typ.sysflag); + IF (ftyp.attribute = 0) OR (ftyp.attribute = limAttr) & (ftyp.mno # 0) THEN err(181) + ELSIF (typ.attribute = absAttr) & (ftyp.attribute # absAttr) & ~(DevCPM.java IN DevCPM.options) THEN err(191) + ELSIF (ftyp.attribute = limAttr) & (typ.attribute # limAttr) THEN err(197) + END + ELSIF ftyp # DevCPT.undftyp THEN err(53) + END + ELSE err(ident) + END ; + IF typ.attribute # absAttr THEN (* save typ for unimplemented method check *) + NEW(r); r.struct := typ; r.pos := DevCPM.errpos; r.next := recList; recList := r + END; + CheckSym(rparen) + END; +(* + DevCPT.OpenScope(0, NIL); +*) + first := NIL; last := NIL; + LOOP + IF sym = ident THEN + LOOP + IF sym = ident THEN + IF (typ.BaseTyp # NIL) & (typ.BaseTyp # DevCPT.undftyp) THEN + DevCPT.FindBaseField(DevCPS.name, typ, fld); + IF fld # NIL THEN err(1) END + END ; + DevCPT.InsertField(DevCPS.name, typ, fld); + fld.mode := Fld; fld.link := NIL; fld.typ := DevCPT.undftyp; + CheckMark(fld); + IF first = NIL THEN first := fld END ; + IF last = NIL THEN typ.link := fld ELSE last.link := fld END ; + last := fld + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(colon); Type(ftyp, name); + CheckAlloc(ftyp, FALSE, DevCPM.errpos); + WHILE first # NIL DO + SetType(typ, first, ftyp, name); first := first.link + END; + IF typ.sysflag = interface THEN err(161) END + END; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(semicolon) + ELSE EXIT + END + END; +(* + IF typ.link # NIL THEN ASSERT(typ.link = DevCPT.topScope.right) END; + typ.link := DevCPT.topScope.right; DevCPT.CloseScope; +*) + typ.untagged := typ.sysflag > 0; + DevCPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end) + END RecordType; + + PROCEDURE ArrayType(VAR typ: DevCPT.Struct); + VAR x: DevCPT.Node; n: INTEGER; sysflag: SHORTINT; name: DevCPT.String; + BEGIN CheckSysFlag(sysflag, DevCPM.GetArraySysFlag); + IF sym = of THEN (*dynamic array*) + typ := DevCPT.NewStr(Comp, DynArr); typ.mno := 0; typ.sysflag := sysflag; + DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name); + CheckAlloc(typ.BaseTyp, TRUE, DevCPM.errpos); + IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 ELSE typ.n := 0 END + ELSE + typ := DevCPT.NewStr(Comp, Array); typ.sysflag := sysflag; ConstExpression(x); + IF x.typ.form IN {Int8, Int16, Int32} THEN n := x.conval.intval; + IF (n <= 0) OR (n > DevCPM.MaxIndex) THEN err(63); n := 1 END + ELSE err(42); n := 1 + END ; + typ.n := n; + IF sym = of THEN + DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name); + CheckAlloc(typ.BaseTyp, FALSE, DevCPM.errpos) + ELSIF sym = comma THEN + DevCPS.Get(sym); + IF sym # of THEN ArrayType(typ.BaseTyp) END + ELSE err(35) + END + END; + typ.untagged := typ.sysflag > 0 + END ArrayType; + + PROCEDURE PointerType(VAR typ: DevCPT.Struct); + VAR id: DevCPT.Object; name: DevCPT.String; + BEGIN typ := DevCPT.NewStr(Pointer, Basic); CheckSysFlag(typ.sysflag, DevCPM.GetPointerSysFlag); + CheckSym(to); + Type(typ.BaseTyp, name); + SetType(typ, NIL, typ.BaseTyp, name); + IF (typ.BaseTyp # DevCPT.undftyp) & (typ.BaseTyp.comp = Basic) THEN + typ.BaseTyp := DevCPT.undftyp; err(57) + END; + IF typ.BaseTyp.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag) + ELSIF typ.BaseTyp.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag) + END; + typ.untagged := typ.sysflag > 0 + END PointerType; + + PROCEDURE Type (VAR typ: DevCPT.Struct; VAR name: DevCPT.String); (* name # NIL => forward reference *) + VAR id: DevCPT.Object; tname: DevCPT.String; + BEGIN + typ := DevCPT.undftyp; name := NIL; + IF sym < lparen THEN err(12); + REPEAT DevCPS.Get(sym) UNTIL sym >= lparen + END ; + IF sym = ident THEN + DevCPT.Find(DevCPS.name, id); + IF (id = NIL) OR (id.mode = -1) OR (id.mode = Typ) & IncompleteType(id.typ) THEN (* forward type definition *) + name := DevCPT.NewName(DevCPS.name); DevCPS.Get(sym); + IF (id = NIL) & (sym = period) THEN (* missing module *) + err(0); DevCPS.Get(sym); name := NIL; + IF sym = ident THEN DevCPS.Get(sym) END + ELSIF sym = record THEN (* wrong attribute *) + err(178); DevCPS.Get(sym); name := NIL; RecordType(typ, NIL) + END + ELSE + qualident(id); + IF id.mode = Typ THEN + IF ~(DevCPM.oberon IN DevCPM.options) + & ((id.typ = DevCPT.lreal64typ) OR (id.typ = DevCPT.lint64typ) OR (id.typ = DevCPT.lchar16typ)) THEN + err(198) + END; + typ := id.typ + ELSIF id.mode = Attr THEN + IF sym = record THEN + DevCPS.Get(sym); RecordType(typ, id) + ELSE err(12) + END + ELSE err(52) + END + END + ELSIF sym = array THEN + DevCPS.Get(sym); ArrayType(typ) + ELSIF sym = record THEN + DevCPS.Get(sym); RecordType(typ, NIL) + ELSIF sym = pointer THEN + DevCPS.Get(sym); PointerType(typ) + ELSIF sym = procedure THEN + DevCPS.Get(sym); typ := DevCPT.NewStr(ProcTyp, Basic); + CheckSysFlag(typ.sysflag, DevCPM.GetProcTypSysFlag); + typ.untagged := typ.sysflag > 0; + IF sym = lparen THEN + DevCPS.Get(sym); DevCPT.OpenScope(level, NIL); + FormalParameters(typ.link, typ.BaseTyp, tname); SetType(typ, NIL, typ.BaseTyp, tname); DevCPT.CloseScope + ELSE typ.BaseTyp := DevCPT.notyp; typ.link := NIL + END + ELSE err(12) + END ; + LOOP + IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof) + OR (sym = number) OR (sym = comma) OR (sym = string) THEN EXIT END; + err(15); IF sym = ident THEN EXIT END; + DevCPS.Get(sym) + END + END Type; + + PROCEDURE ActualParameters(VAR aparlist: DevCPT.Node; fpar: DevCPT.Object; VAR pre, lastp: DevCPT.Node); + VAR apar, last, newPar, iidPar, n: DevCPT.Node; + BEGIN + aparlist := NIL; last := NIL; + IF sym # rparen THEN + newPar := NIL; iidPar := NIL; + LOOP Expression(apar); + IF fpar # NIL THEN + IF (apar.typ.form = Pointer) & (fpar.typ.form = Comp) THEN DevCPB.DeRef(apar) END; + DevCPB.Param(apar, fpar); + IF (fpar.mode = Var) OR (fpar.vis = inPar) THEN DevCPB.CheckBuffering(apar, NIL, fpar, pre, lastp) END; + DevCPB.Link(aparlist, last, apar); + IF ODD(fpar.sysflag DIV newBit) THEN newPar := apar + ELSIF ODD(fpar.sysflag DIV iidBit) THEN iidPar := apar + END; + IF (newPar # NIL) & (iidPar # NIL) THEN DevCPB.CheckNewParamPair(newPar, iidPar) END; + IF anchorVarPar & (fpar.mode = VarPar) & ~(DevCPM.java IN DevCPM.options) + OR (DevCPM.allSysVal IN DevCPM.options) (* source output: avoid double evaluation *) + & ((fpar.mode = VarPar) & (fpar.typ.comp = Record) & ~fpar.typ.untagged + OR (fpar.typ.comp = DynArr) & ~fpar.typ.untagged) THEN + n := apar; + WHILE n.class IN {Nfield, Nindex, Nguard} DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 0) THEN + IF n.left.class = Nguard THEN n := n.left END; + DevCPB.CheckVarParBuffering(n.left, pre, lastp) + END + END; + fpar := fpar.link + ELSE err(64) + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END + END + END; + IF fpar # NIL THEN err(65) END + END ActualParameters; + + PROCEDURE selector(VAR x: DevCPT.Node); + VAR obj, proc, p, fpar: DevCPT.Object; y, apar, pre, lastp: DevCPT.Node; typ: DevCPT.Struct; name: DevCPT.Name; + BEGIN + LOOP + IF sym = lbrak THEN DevCPS.Get(sym); + LOOP + IF (x.typ # NIL) & (x.typ.form = Pointer) THEN DevCPB.DeRef(x) END ; + Expression(y); DevCPB.Index(x, y); + IF sym = comma THEN DevCPS.Get(sym) ELSE EXIT END + END ; + CheckSym(rbrak) + ELSIF sym = period THEN DevCPS.Get(sym); + IF sym = ident THEN name := DevCPS.name; DevCPS.Get(sym); + IF x.typ # NIL THEN + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END ; + IF x.typ.comp = Record THEN + typ := x.typ; DevCPT.FindField(name, typ, obj); DevCPB.Field(x, obj); + IF (obj # NIL) & (obj.mode = TProc) THEN + IF sym = arrow THEN (* super call *) DevCPS.Get(sym); + y := x.left; + IF y.class = Nderef THEN y := y.left END ; (* y = record variable *) + IF y.obj # NIL THEN + proc := DevCPT.topScope; (* find innermost scope which owner is a TProc *) + WHILE (proc.link # NIL) & (proc.link.mode # TProc) DO proc := proc.left END ; + IF (proc.link = NIL) OR (proc.link.link # y.obj) (* OR (proc.link.name^ # name) *) THEN err(75) + END ; + typ := y.obj.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END ; + DevCPT.FindBaseField(x.obj.name^, typ, p); + IF p # NIL THEN + x.subcl := super; x.typ := p.typ; (* correct result type *) + IF p.conval.setval * {absAttr, empAttr} # {} THEN err(194) END; + IF (p.vis = externalR) & (p.mnolev < 0) & (proc.link.name^ # name) THEN err(196) END; + ELSE err(74) + END + ELSE err(75) + END + ELSE + proc := obj; + WHILE (proc.mnolev >= 0) & ~(newAttr IN proc.conval.setval) & (typ.BaseTyp # NIL) DO + (* find base method *) + typ := typ.BaseTyp; DevCPT.FindField(name, typ, proc); + END; + IF (proc.vis = externalR) & (proc.mnolev < 0) THEN err(196) END; + END ; + IF (obj.typ # DevCPT.notyp) & (sym # lparen) THEN err(lparen) END + END + ELSE err(53) + END + ELSE err(52) + END + ELSE err(ident) + END + ELSIF sym = arrow THEN DevCPS.Get(sym); DevCPB.DeRef(x) + ELSIF sym = dollar THEN + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END; + DevCPS.Get(sym); DevCPB.StrDeref(x) + ELSIF sym = lparen THEN + IF (x.obj # NIL) & (x.obj.mode IN {XProc, LProc, CProc, TProc}) THEN typ := x.obj.typ + ELSIF x.typ.form = ProcTyp THEN typ := x.typ.BaseTyp + ELSIF x.class = Nproc THEN EXIT (* standard procedure *) + ELSE typ := NIL + END; + IF typ # DevCPT.notyp THEN + DevCPS.Get(sym); + IF typ = NIL THEN (* type guard *) + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE) + ELSE err(52) + END + ELSE err(ident) + END + ELSE (* function call *) + pre := NIL; lastp := NIL; + DevCPB.PrepCall(x, fpar); + IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) + END; + ActualParameters(apar, fpar, pre, lastp); + DevCPB.Call(x, apar, fpar); + IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END; + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END + END; + CheckSym(rparen) + ELSE EXIT + END +(* + ELSIF (sym = lparen) & (x.class # Nproc) & (x.typ.form # ProcTyp) & + ((x.obj = NIL) OR (x.obj.mode # TProc)) THEN + DevCPS.Get(sym); + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE) + ELSE err(52) + END + ELSE err(ident) + END ; + CheckSym(rparen) +*) + ELSE EXIT + END + END + END selector; + + PROCEDURE StandProcCall(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; m: BYTE; n: SHORTINT; + BEGIN m := SHORT(SHORT(x.obj.adr)); n := 0; + IF sym = lparen THEN DevCPS.Get(sym); + IF sym # rparen THEN + LOOP + IF n = 0 THEN Expression(x); DevCPB.StPar0(x, m); n := 1 + ELSIF n = 1 THEN Expression(y); DevCPB.StPar1(x, y, m); n := 2 + ELSE Expression(y); DevCPB.StParN(x, y, m, n); INC(n) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(rparen) + ELSE DevCPS.Get(sym) + END ; + DevCPB.StFct(x, m, n) + ELSE err(lparen) + END ; + IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN DevCPT.topScope.link.leaf := FALSE END + END StandProcCall; + + PROCEDURE Element(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; + BEGIN Expression(x); + IF sym = upto THEN + DevCPS.Get(sym); Expression(y); DevCPB.SetRange(x, y) + ELSE DevCPB.SetElem(x) + END + END Element; + + PROCEDURE Sets(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; + BEGIN + IF sym # rbrace THEN + Element(x); + LOOP + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma) + ELSE EXIT + END ; + Element(y); DevCPB.Op(plus, x, y) + END + ELSE x := DevCPB.EmptySet() + END ; + CheckSym(rbrace) + END Sets; + + PROCEDURE Factor(VAR x: DevCPT.Node); + VAR fpar, id: DevCPT.Object; apar: DevCPT.Node; + BEGIN + IF sym < not THEN err(13); + REPEAT DevCPS.Get(sym) UNTIL sym >= lparen + END ; + IF sym = ident THEN + qualident(id); x := DevCPB.NewLeaf(id); selector(x); + IF (x.class = Nproc) & (x.obj.mode = SProc) THEN StandProcCall(x) (* x may be NIL *) +(* + ELSIF sym = lparen THEN + DevCPS.Get(sym); DevCPB.PrepCall(x, fpar); + ActualParameters(apar, fpar); + DevCPB.Call(x, apar, fpar); + CheckSym(rparen); + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END +*) + END + ELSIF sym = number THEN + CASE DevCPS.numtyp OF + char: + x := DevCPB.NewIntConst(DevCPS.intval); x.typ := DevCPT.char8typ; + IF DevCPS.intval > 255 THEN x.typ := DevCPT.char16typ END + | integer: x := DevCPB.NewIntConst(DevCPS.intval) + | int64: x := DevCPB.NewLargeIntConst(DevCPS.intval, DevCPS.realval) + | real: x := DevCPB.NewRealConst(DevCPS.realval, NIL) + | real32: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real32typ) + | real64: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real64typ) + END ; + DevCPS.Get(sym) + ELSIF sym = string THEN + x := DevCPB.NewString(DevCPS.str, DevCPS.lstr, DevCPS.intval); + DevCPS.Get(sym) + ELSIF sym = nil THEN + x := DevCPB.Nil(); DevCPS.Get(sym) + ELSIF sym = lparen THEN + DevCPS.Get(sym); Expression(x); CheckSym(rparen) + ELSIF sym = lbrak THEN + DevCPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen) + ELSIF sym = lbrace THEN DevCPS.Get(sym); Sets(x) + ELSIF sym = not THEN + DevCPS.Get(sym); Factor(x); DevCPB.MOp(not, x) + ELSE err(13); DevCPS.Get(sym); x := NIL + END ; + IF x = NIL THEN x := DevCPB.NewIntConst(1); x.typ := DevCPT.undftyp END + END Factor; + + PROCEDURE Term(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; mulop: BYTE; + BEGIN Factor(x); + WHILE (times <= sym) & (sym <= and) DO + mulop := sym; DevCPS.Get(sym); + Factor(y); DevCPB.Op(mulop, x, y) + END + END Term; + + PROCEDURE SimpleExpression(VAR x: DevCPT.Node); + VAR y: DevCPT.Node; addop: BYTE; + BEGIN + IF sym = minus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(minus, x) + ELSIF sym = plus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(plus, x) + ELSE Term(x) + END ; + WHILE (plus <= sym) & (sym <= or) DO + addop := sym; DevCPS.Get(sym); Term(y); + IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END; + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) (* OR (x.typ.sysflag = jstr) *) THEN + DevCPB.StrDeref(x) + END; + IF y.typ.form = Pointer THEN DevCPB.DeRef(y) END; + IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) (* OR (y.typ.sysflag = jstr) *) THEN + DevCPB.StrDeref(y) + END; + DevCPB.Op(addop, x, y) + END + END SimpleExpression; + + PROCEDURE Expression(VAR x: DevCPT.Node); + VAR y, pre, last: DevCPT.Node; obj: DevCPT.Object; relation: BYTE; + BEGIN SimpleExpression(x); + IF (eql <= sym) & (sym <= geq) THEN + relation := sym; DevCPS.Get(sym); SimpleExpression(y); + pre := NIL; last := NIL; + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN + DevCPB.StrDeref(x) + END; + IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) THEN + DevCPB.StrDeref(y) + END; + DevCPB.CheckBuffering(x, NIL, NIL, pre, last); + DevCPB.CheckBuffering(y, NIL, NIL, pre, last); + DevCPB.Op(relation, x, y); + IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END + ELSIF sym = in THEN + DevCPS.Get(sym); SimpleExpression(y); DevCPB.In(x, y) + ELSIF sym = is THEN + DevCPS.Get(sym); + IF sym = ident THEN + qualident(obj); + IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, FALSE) + ELSE err(52) + END + ELSE err(ident) + END + END + END Expression; + + PROCEDURE ProcedureDeclaration(VAR x: DevCPT.Node); + VAR proc, fwd: DevCPT.Object; + name: DevCPT.Name; + mode: BYTE; + forward: BOOLEAN; + sys: SHORTINT; + + PROCEDURE GetCode; + VAR ext: DevCPT.ConstExt; i, n, c: INTEGER; s: ARRAY 256 OF SHORTCHAR; + BEGIN + n := 0; + IF sym = string THEN + NEW(ext, DevCPS.intval); + WHILE DevCPS.str[n] # 0X DO ext[n+1] := DevCPS.str[n]; INC(n) END ; + ext^[0] := SHORT(CHR(n)); DevCPS.Get(sym); + ELSE + LOOP + IF sym = number THEN c := DevCPS.intval; INC(n); + IF (c < 0) OR (c > 255) OR (n = 255) THEN + err(64); c := 1; n := 1 + END ; + DevCPS.Get(sym); s[n] := SHORT(CHR(c)) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = number THEN err(comma) + ELSE s[0] := SHORT(CHR(n)); EXIT + END + END; + NEW(ext, n + 1); i := 0; + WHILE i <= n DO ext[i] := s[i]; INC(i) END; + END; + proc.conval.ext := ext; + INCL(proc.conval.setval, hasBody) + END GetCode; + + PROCEDURE GetParams; + VAR name: DevCPT.String; + BEGIN + proc.mode := mode; proc.typ := DevCPT.notyp; + proc.sysflag := SHORT(sys); + proc.conval.setval := {}; + IF sym = lparen THEN + DevCPS.Get(sym); FormalParameters(proc.link, proc.typ, name); + IF name # NIL THEN err(0) END + END; + CheckForwardTypes; userList := NIL; + IF fwd # NIL THEN + DevCPB.CheckParameters(proc.link, fwd.link, TRUE); + IF ~DevCPT.EqualType(proc.typ, fwd.typ) THEN err(117) END ; + proc := fwd; DevCPT.topScope := proc.scope; + IF mode = IProc THEN proc.mode := IProc END + END + END GetParams; + + PROCEDURE Body; + VAR procdec, statseq: DevCPT.Node; c: INTEGER; + BEGIN + c := DevCPM.errpos; + INCL(proc.conval.setval, hasBody); + CheckSym(semicolon); Block(procdec, statseq); + DevCPB.Enter(procdec, statseq, proc); x := procdec; + x.conval := DevCPT.NewConst(); x.conval.intval := c; x.conval.intval2 := DevCPM.startpos; + CheckSym(end); + IF sym = ident THEN + IF DevCPS.name # proc.name^ THEN err(4) END ; + DevCPS.Get(sym) + ELSE err(ident) + END + END Body; + + PROCEDURE TProcDecl; + VAR baseProc, o, bo: DevCPT.Object; + objTyp, recTyp: DevCPT.Struct; + objMode, objVis: BYTE; + objName: DevCPT.Name; + pnode: DevCPT.Node; + fwdAttr: SET; + BEGIN + DevCPS.Get(sym); mode := TProc; + IF level > 0 THEN err(73) END; + Receiver(objMode, objVis, objName, objTyp, recTyp); + IF sym = ident THEN + name := DevCPS.name; + DevCPT.FindField(name, recTyp, fwd); + DevCPT.FindBaseField(name, recTyp, baseProc); + IF (baseProc # NIL) & (baseProc.mode # TProc) THEN baseProc := NIL; err(1) END ; + IF fwd = baseProc THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mnolev # level) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mode = TProc) & (fwd.conval.setval * {hasBody, absAttr, empAttr} = {}) THEN + (* there exists a corresponding forward declaration *) + proc := DevCPT.NewObj(); proc.leaf := TRUE; + proc.mode := TProc; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF fwd.vis # proc.vis THEN err(118) END; + fwdAttr := fwd.conval.setval + ELSE + IF fwd # NIL THEN err(1); fwd := NIL END ; + DevCPT.InsertField(name, recTyp, proc); + proc.mode := TProc; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF recTyp.strobj # NIL THEN (* preserve declaration order *) + o := recTyp.strobj.link; + IF o = NIL THEN recTyp.strobj.link := proc + ELSE + WHILE o.nlink # NIL DO o := o.nlink END; + o.nlink := proc + END + END + END; + INC(level); DevCPT.OpenScope(level, proc); + DevCPT.Insert(objName, proc.link); proc.link.mode := objMode; proc.link.vis := objVis; proc.link.typ := objTyp; + ASSERT(DevCPT.topScope # NIL); + GetParams; (* may change proc := fwd !!! *) + ASSERT(DevCPT.topScope # NIL); + GetAttributes(proc, baseProc, recTyp); + IF (fwd # NIL) & (fwdAttr / proc.conval.setval * {absAttr, empAttr, extAttr} # {}) THEN err(184) END; + CheckOverwrite(proc, baseProc, recTyp); + IF ~forward THEN + IF empAttr IN proc.conval.setval THEN (* insert empty procedure *) + pnode := NIL; DevCPB.Enter(pnode, NIL, proc); + pnode.conval := DevCPT.NewConst(); + pnode.conval.intval := DevCPM.errpos; + pnode.conval.intval2 := DevCPM.errpos; + x := pnode; + ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody) + ELSIF ~(absAttr IN proc.conval.setval) THEN Body + END; + proc.adr := 0 + ELSE + proc.adr := DevCPM.errpos; + IF proc.conval.setval * {empAttr, absAttr} # {} THEN err(184) END + END; + DEC(level); DevCPT.CloseScope; + ELSE err(ident) + END; + END TProcDecl; + + BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; sys := 0; + IF (sym # ident) & (sym # lparen) THEN + CheckSysFlag(sys, DevCPM.GetProcSysFlag); + IF sys # 0 THEN + IF ODD(sys DIV DevCPM.CProcFlag) THEN mode := CProc END + ELSE + IF sym = times THEN (* mode set later in DevCPB.CheckAssign *) + ELSIF sym = arrow THEN forward := TRUE + ELSE err(ident) + END; + DevCPS.Get(sym) + END + END ; + IF sym = lparen THEN TProcDecl + ELSIF sym = ident THEN DevCPT.Find(DevCPS.name, fwd); + name := DevCPS.name; + IF (fwd # NIL) & ((fwd.mnolev # level) OR (fwd.mode = SProc)) THEN fwd := NIL END ; + IF (fwd # NIL) & (fwd.mode IN {LProc, XProc}) & ~(hasBody IN fwd.conval.setval) THEN + (* there exists a corresponding forward declaration *) + proc := DevCPT.NewObj(); proc.leaf := TRUE; + proc.mode := mode; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + IF fwd.vis # proc.vis THEN err(118) END + ELSE + IF fwd # NIL THEN err(1); fwd := NIL END ; + DevCPT.Insert(name, proc); + proc.mode := mode; proc.conval := DevCPT.NewConst(); + CheckMark(proc); + END ; + IF (proc.vis # internal) & (mode = LProc) THEN mode := XProc END ; + IF (mode # LProc) & (level > 0) THEN err(73) END ; + INC(level); DevCPT.OpenScope(level, proc); + proc.link := NIL; GetParams; (* may change proc := fwd !!! *) + IF mode = CProc THEN GetCode + ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody) + ELSIF ~forward THEN Body; proc.adr := 0 + ELSE proc.adr := DevCPM.errpos + END ; + DEC(level); DevCPT.CloseScope + ELSE err(ident) + END + END ProcedureDeclaration; + + PROCEDURE CaseLabelList(VAR lab, root: DevCPT.Node; LabelForm: SHORTINT; VAR min, max: INTEGER); + VAR x, y, lastlab: DevCPT.Node; i, f: SHORTINT; xval, yval: INTEGER; + + PROCEDURE Insert(VAR n: DevCPT.Node); (* build binary tree of label ranges *) (* !!! *) + BEGIN + IF n = NIL THEN + IF x.hint # 1 THEN n := x END + ELSIF yval < n.conval.intval THEN Insert(n.left) + ELSIF xval > n.conval.intval2 THEN Insert(n.right) + ELSE err(63) + END + END Insert; + + BEGIN lab := NIL; lastlab := NIL; + LOOP ConstExpression(x); f := x.typ.form; + IF f IN {Int8..Int32} + charSet THEN xval := x.conval.intval + ELSE err(61); xval := 1 + END ; + IF (f IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END; + IF sym = upto THEN + DevCPS.Get(sym); ConstExpression(y); yval := y.conval.intval; + IF (y.typ.form IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END; + IF yval < xval THEN err(63); yval := xval END + ELSE yval := xval + END ; + x.conval.intval2 := yval; + IF xval < min THEN min := xval END; + IF yval > max THEN max := yval END; + IF lab = NIL THEN lab := x; Insert(root) + ELSIF yval < lab.conval.intval - 1 THEN x.link := lab; lab := x; Insert(root) + ELSIF yval = lab.conval.intval - 1 THEN x.hint := 1; Insert(root); lab.conval.intval := xval + ELSIF xval = lab.conval.intval2 + 1 THEN x.hint := 1; Insert(root); lab.conval.intval2 := yval + ELSE + y := lab; + WHILE (y.link # NIL) & (xval > y.link.conval.intval2 + 1) DO y := y.link END; + IF y.link = NIL THEN y.link := x; Insert(root) + ELSIF yval < y.link.conval.intval - 1 THEN x.link := y.link; y.link := x; Insert(root) + ELSIF yval = y.link.conval.intval - 1 THEN x.hint := 1; Insert(root); y.link.conval.intval := xval + ELSIF xval = y.link.conval.intval2 + 1 THEN x.hint := 1; Insert(root); y.link.conval.intval2 := yval + END + END; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF (sym = number) OR (sym = ident) THEN err(comma) + ELSE EXIT + END + END + END CaseLabelList; + + PROCEDURE StatSeq(VAR stat: DevCPT.Node); + VAR fpar, id, t, obj: DevCPT.Object; idtyp: DevCPT.Struct; e: BOOLEAN; + s, x, y, z, apar, last, lastif, pre, lastp: DevCPT.Node; pos, p: INTEGER; name: DevCPT.Name; + + PROCEDURE CasePart(VAR x: DevCPT.Node); + VAR low, high: INTEGER; e: BOOLEAN; cases, lab, y, lastcase, root: DevCPT.Node; + BEGIN + Expression(x); + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ.form = Int64 THEN err(260) + ELSIF ~(x.typ.form IN {Int8..Int32} + charSet) THEN err(125) + END ; + CheckSym(of); cases := NIL; lastcase := NIL; root := NIL; + low := MAX(INTEGER); high := MIN(INTEGER); + LOOP + IF sym < bar THEN + CaseLabelList(lab, root, x.typ.form, low, high); + CheckSym(colon); StatSeq(y); + DevCPB.Construct(Ncasedo, lab, y); DevCPB.Link(cases, lastcase, lab) + END ; + IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END + END; + e := sym = else; + IF e THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + DevCPB.Construct(Ncaselse, cases, y); DevCPB.Construct(Ncase, x, cases); + cases.conval := DevCPT.NewConst(); + cases.conval.intval := low; cases.conval.intval2 := high; + IF e THEN cases.conval.setval := {1} ELSE cases.conval.setval := {} END; + DevCPB.OptimizeCase(root); cases.link := root (* !!! *) + END CasePart; + + PROCEDURE SetPos(x: DevCPT.Node); + BEGIN + x.conval := DevCPT.NewConst(); x.conval.intval := pos + END SetPos; + + PROCEDURE CheckBool(VAR x: DevCPT.Node); + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := DevCPB.NewBoolConst(FALSE) + ELSIF x.typ.form # Bool THEN err(120); x := DevCPB.NewBoolConst(FALSE) + END + END CheckBool; + + BEGIN stat := NIL; last := NIL; + LOOP x := NIL; + IF sym < ident THEN err(14); + REPEAT DevCPS.Get(sym) UNTIL sym >= ident + END ; + pos := DevCPM.startpos; + IF sym = ident THEN + qualident(id); x := DevCPB.NewLeaf(id); selector(x); + IF sym = becomes THEN + DevCPS.Get(sym); Expression(y); + IF (y.typ.form = Pointer) & (x.typ.form = Comp) THEN DevCPB.DeRef(y) END; + pre := NIL; lastp := NIL; + DevCPB.CheckBuffering(y, x, NIL, pre, lastp); + DevCPB.Assign(x, y); + IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END; + ELSIF sym = eql THEN + err(becomes); DevCPS.Get(sym); Expression(y); DevCPB.Assign(x, y) + ELSIF (x.class = Nproc) & (x.obj.mode = SProc) THEN + StandProcCall(x); + IF (x # NIL) & (x.typ # DevCPT.notyp) THEN err(55) END; + IF (x # NIL) & (x.class = Nifelse) THEN (* error pos for ASSERT *) + SetPos(x.left); SetPos(x.left.right) + END + ELSIF x.class = Ncall THEN err(55) + ELSE + pre := NIL; lastp := NIL; + DevCPB.PrepCall(x, fpar); + IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) END; + IF sym = lparen THEN + DevCPS.Get(sym); ActualParameters(apar, fpar, pre, lastp); CheckSym(rparen) + ELSE apar := NIL; + IF fpar # NIL THEN err(65) END + END ; + DevCPB.Call(x, apar, fpar); + IF x.typ # DevCPT.notyp THEN err(55) END; + IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END; + IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END + END + ELSIF sym = if THEN + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(then); StatSeq(y); + DevCPB.Construct(Nif, x, y); SetPos(x); lastif := x; + WHILE sym = elsif DO + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y); CheckSym(then); StatSeq(z); + DevCPB.Construct(Nif, y, z); SetPos(y); DevCPB.Link(x, lastif, y) + END ; + pos := DevCPM.startpos; + IF sym = else THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ; + DevCPB.Construct(Nifelse, x, y); CheckSym(end); DevCPB.OptIf(x); + ELSIF sym = case THEN + DevCPS.Get(sym); pos := DevCPM.startpos; CasePart(x); CheckSym(end) + ELSIF sym = while THEN + DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(do); StatSeq(y); + DevCPB.Construct(Nwhile, x, y); CheckSym(end) + ELSIF sym = repeat THEN + DevCPS.Get(sym); StatSeq(x); + IF sym = until THEN DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y) + ELSE err(43) + END ; + DevCPB.Construct(Nrepeat, x, y) + ELSIF sym = for THEN + DevCPS.Get(sym); pos := DevCPM.startpos; + IF sym = ident THEN qualident(id); + IF ~(id.typ.form IN intSet) THEN err(68) END ; + CheckSym(becomes); Expression(y); + x := DevCPB.NewLeaf(id); DevCPB.Assign(x, y); SetPos(x); + CheckSym(to); pos := DevCPM.startpos; Expression(y); + IF y.class # Nconst THEN + DevCPB.GetTempVar("@for", x.left.typ, t); + z := DevCPB.NewLeaf(t); DevCPB.Assign(z, y); SetPos(z); DevCPB.Link(stat, last, z); + y := DevCPB.NewLeaf(t) + ELSE + DevCPB.CheckAssign(x.left.typ, y) + END ; + DevCPB.Link(stat, last, x); + p := DevCPM.startpos; + IF sym = by THEN DevCPS.Get(sym); ConstExpression(z) ELSE z := DevCPB.NewIntConst(1) END ; + x := DevCPB.NewLeaf(id); + IF z.conval.intval > 0 THEN DevCPB.Op(leq, x, y) + ELSIF z.conval.intval < 0 THEN DevCPB.Op(geq, x, y) + ELSE err(63); DevCPB.Op(geq, x, y) + END ; + CheckSym(do); StatSeq(s); + y := DevCPB.NewLeaf(id); DevCPB.StPar1(y, z, incfn); pos := DevCPM.startpos; SetPos(y); + IF s = NIL THEN s := y + ELSE z := s; + WHILE z.link # NIL DO z := z.link END ; + z.link := y + END ; + CheckSym(end); DevCPB.Construct(Nwhile, x, s); pos := p + ELSE err(ident) + END + ELSIF sym = loop THEN + DevCPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel); + DevCPB.Construct(Nloop, x, NIL); CheckSym(end) + ELSIF sym = with THEN + DevCPS.Get(sym); idtyp := NIL; x := NIL; + LOOP + IF sym < bar THEN + pos := DevCPM.startpos; + IF sym = ident THEN + qualident(id); y := DevCPB.NewLeaf(id); + IF (id # NIL) & (id.typ.form = Pointer) & ((id.mode = VarPar) OR ~id.leaf) THEN + err(-302) (* warning 302 *) + END ; + CheckSym(colon); + IF sym = ident THEN qualident(t); + IF t.mode = Typ THEN + IF id # NIL THEN + idtyp := id.typ; DevCPB.TypTest(y, t, FALSE); id.typ := t.typ; + IF id.ptyp = NIL THEN id.ptyp := idtyp END + ELSE err(130) + END + ELSE err(52) + END + ELSE err(ident) + END + ELSE err(ident) + END ; + CheckSym(do); StatSeq(s); DevCPB.Construct(Nif, y, s); SetPos(y); + IF idtyp # NIL THEN + IF id.ptyp = idtyp THEN id.ptyp := NIL END; + id.typ := idtyp; idtyp := NIL + END ; + IF x = NIL THEN x := y; lastif := x ELSE DevCPB.Link(x, lastif, y) END + END; + IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END + END; + e := sym = else; pos := DevCPM.startpos; + IF e THEN DevCPS.Get(sym); StatSeq(s) ELSE s := NIL END ; + DevCPB.Construct(Nwith, x, s); CheckSym(end); + IF e THEN x.subcl := 1 END + ELSIF sym = exit THEN + DevCPS.Get(sym); + IF LoopLevel = 0 THEN err(46) END ; + DevCPB.Construct(Nexit, x, NIL) + ELSIF sym = return THEN DevCPS.Get(sym); + IF sym < semicolon THEN Expression(x) END ; + IF level > 0 THEN DevCPB.Return(x, DevCPT.topScope.link) + ELSE (* not standard Oberon *) DevCPB.Return(x, NIL) + END; + hasReturn := TRUE + END ; + IF x # NIL THEN SetPos(x); DevCPB.Link(stat, last, x) END ; + IF sym = semicolon THEN DevCPS.Get(sym) + ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon) + ELSE EXIT + END + END + END StatSeq; + + PROCEDURE Block(VAR procdec, statseq: DevCPT.Node); + VAR typ: DevCPT.Struct; + obj, first, last, o: DevCPT.Object; + x, lastdec: DevCPT.Node; + i: SHORTINT; + rname: DevCPT.Name; + name: DevCPT.String; + rec: Elem; + + BEGIN + IF ((sym < begin) OR (sym > var)) & (sym # procedure) & (sym # end) & (sym # close) THEN err(36) END; + first := NIL; last := NIL; userList := NIL; recList := NIL; + LOOP + IF sym = const THEN + DevCPS.Get(sym); + WHILE sym = ident DO + DevCPT.Insert(DevCPS.name, obj); + obj.mode := Con; CheckMark(obj); + obj.typ := DevCPT.int8typ; obj.mode := Var; (* Var to avoid recursive definition *) + IF sym = eql THEN + DevCPS.Get(sym); ConstExpression(x) + ELSIF sym = becomes THEN + err(eql); DevCPS.Get(sym); ConstExpression(x) + ELSE err(eql); x := DevCPB.NewIntConst(1) + END ; + obj.mode := Con; obj.typ := x.typ; obj.conval := x.conval; (* ConstDesc ist not copied *) + CheckSym(semicolon) + END + END ; + IF sym = type THEN + DevCPS.Get(sym); + WHILE sym = ident DO + DevCPT.Insert(DevCPS.name, obj); obj.mode := Typ; obj.typ := DevCPT.undftyp; + CheckMark(obj); obj.mode := -1; + IF sym # eql THEN err(eql) END; + IF (sym = eql) OR (sym = becomes) OR (sym = colon) THEN + DevCPS.Get(sym); Type(obj.typ, name); SetType(NIL, obj, obj.typ, name); + END; + obj.mode := Typ; + IF obj.typ.form IN {Byte..Set, Char16, Int64} THEN (* make alias structure *) + typ := DevCPT.NewStr(obj.typ.form, Basic); i := typ.ref; + typ^ := obj.typ^; typ.ref := i; typ.strobj := NIL; typ.mno := 0; typ.txtpos := DevCPM.errpos; + typ.BaseTyp := obj.typ; obj.typ := typ; + END; + IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END ; + IF obj.typ.form = Pointer THEN (* !!! *) + typ := obj.typ.BaseTyp; + IF (typ # NIL) & (typ.comp = Record) & (typ.strobj = NIL) THEN + (* pointer to unnamed record: name record as "pointerName^" *) + rname := obj.name^$; i := 0; + WHILE rname[i] # 0X DO INC(i) END; + rname[i] := "^"; rname[i+1] := 0X; + DevCPT.Insert(rname, o); o.mode := Typ; o.typ := typ; typ.strobj := o + END + END; + IF obj.vis # internal THEN + typ := obj.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF typ.comp = Record THEN typ.exp := TRUE END + END; + CheckSym(semicolon) + END + END ; + IF sym = var THEN + DevCPS.Get(sym); + WHILE sym = ident DO + LOOP + IF sym = ident THEN + DevCPT.Insert(DevCPS.name, obj); + obj.mode := Var; obj.link := NIL; obj.leaf := obj.vis = internal; obj.typ := DevCPT.undftyp; + CheckMark(obj); + IF first = NIL THEN first := obj END ; + IF last = NIL THEN DevCPT.topScope.scope := obj ELSE last.link := obj END ; + last := obj + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(colon); Type(typ, name); + CheckAlloc(typ, FALSE, DevCPM.errpos); + WHILE first # NIL DO SetType(NIL, first, typ, name); first := first.link END ; + CheckSym(semicolon) + END + END ; + IF (sym < const) OR (sym > var) THEN EXIT END ; + END ; + CheckForwardTypes; + userList := NIL; rec := recList; recList := NIL; + DevCPT.topScope.adr := DevCPM.errpos; + procdec := NIL; lastdec := NIL; + IF (sym # procedure) & (sym # begin) & (sym # end) & (sym # close) THEN err(37) END; + WHILE sym = procedure DO + DevCPS.Get(sym); ProcedureDeclaration(x); + IF x # NIL THEN + IF lastdec = NIL THEN procdec := x ELSE lastdec.link := x END ; + lastdec := x + END ; + CheckSym(semicolon) + END ; + IF DevCPM.noerr & ~(DevCPM.oberon IN DevCPM.options) THEN CheckRecords(rec) END; + hasReturn := FALSE; + IF (sym # begin) & (sym # end) & (sym # close) THEN err(38) END; + IF sym = begin THEN DevCPS.Get(sym); StatSeq(statseq) + ELSE statseq := NIL + END ; + IF (DevCPT.topScope.link # NIL) & (DevCPT.topScope.link.typ # DevCPT.notyp) + & ~hasReturn & (DevCPT.topScope.link.sysflag = 0) THEN err(133) END; + IF (level = 0) & (TDinit # NIL) THEN + lastTDinit.link := statseq; statseq := TDinit + END + END Block; + + PROCEDURE Module*(VAR prog: DevCPT.Node); + VAR impName, aliasName: DevCPT.Name; + procdec, statseq: DevCPT.Node; + c, sf: INTEGER; done: BOOLEAN; + BEGIN + DevCPS.Init; LoopLevel := 0; level := 0; DevCPS.Get(sym); + IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END ; + IF sym = ident THEN + DevCPT.Open(DevCPS.name); DevCPS.Get(sym); + DevCPT.libName := ""; + IF sym = lbrak THEN + INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym); + IF sym = eql THEN DevCPS.Get(sym) + ELSE INCL(DevCPM.options, DevCPM.noCode) + END; + IF sym = string THEN DevCPT.libName := DevCPS.str^$; DevCPS.Get(sym) + ELSE err(string) + END; + CheckSym(rbrak) + END; + CheckSym(semicolon); + IF sym = import THEN DevCPS.Get(sym); + LOOP + IF sym = ident THEN + aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym); + IF sym = becomes THEN DevCPS.Get(sym); + IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END + END ; + DevCPT.Import(aliasName, impName, done) + ELSE err(ident) + END ; + IF sym = comma THEN DevCPS.Get(sym) + ELSIF sym = ident THEN err(comma) + ELSE EXIT + END + END ; + CheckSym(semicolon) + END ; + IF DevCPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := DevCPM.errpos; + Block(procdec, statseq); DevCPB.Enter(procdec, statseq, NIL); prog := procdec; + prog.conval := DevCPT.NewConst(); prog.conval.intval := c; prog.conval.intval2 := DevCPM.startpos; + IF sym = close THEN DevCPS.Get(sym); StatSeq(prog.link) END; + prog.conval.realval := DevCPM.startpos; + CheckSym(end); + IF sym = ident THEN + IF DevCPS.name # DevCPT.SelfName THEN err(4) END ; + DevCPS.Get(sym) + ELSE err(ident) + END; + IF sym # period THEN err(period) END + END + ELSE err(ident) + END ; + TDinit := NIL; lastTDinit := NIL; + DevCPS.str := NIL + END Module; + +END DevCPP. diff --git a/Trurl-based/Dev/Mod/CPS.txt b/Trurl-based/Dev/Mod/CPS.txt new file mode 100644 index 0000000..ea2d746 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPS.txt @@ -0,0 +1,367 @@ +MODULE DevCPS; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPS.odc *) + (* DO NOT EDIT *) + (* SEE XXX *) + + IMPORT SYSTEM, Math, DevCPM, DevCPT; + + CONST + MaxIdLen = 256; + + TYPE +(* + Name* = ARRAY MaxIdLen OF SHORTCHAR; + String* = POINTER TO ARRAY OF SHORTCHAR; +*) + + (* name, str, numtyp, intval, realval, realval are implicit results of Get *) + + VAR + name*: DevCPT.Name; + str*: DevCPT.String; + lstr*: POINTER TO ARRAY OF CHAR; + numtyp*: SHORTINT; (* 1 = char, 2 = integer, 4 = real, 5 = int64, 6 = real32, 7 = real64 *) + intval*: INTEGER; (* integer value or string length (incl. 0X) *) + realval*: REAL; + + + CONST + (* numtyp values *) + char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7; + + (*symbol values*) + null = 0; times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; arrow = 17; dollar = 18; period = 19; + comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24; + rbrace = 25; of = 26; then = 27; do = 28; to = 29; + by = 30; not = 33; + lparen = 40; lbrak = 41; lbrace = 42; becomes = 44; + number = 45; nil = 46; string = 47; ident = 48; semicolon = 49; + bar = 50; end = 51; else = 52; elsif = 53; until = 54; + if = 55; case = 56; while = 57; repeat = 58; for = 59; + loop = 60; with = 61; exit = 62; return = 63; array = 64; + record = 65; pointer = 66; begin = 67; const = 68; type = 69; + var = 70; out = 71; procedure = 72; close = 73; import = 74; + module = 75; eof = 76; + + VAR + ch: SHORTCHAR; (*current character*) + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE Str(VAR sym: BYTE); + VAR i: SHORTINT; och: SHORTCHAR; lch: CHAR; long: BOOLEAN; + s: ARRAY 256 OF CHAR; t: POINTER TO ARRAY OF CHAR; + BEGIN i := 0; och := ch; long := FALSE; + LOOP DevCPM.GetL(lch); + IF lch = och THEN EXIT END ; + IF (lch < " ") & (lch # 9X) THEN err(3); EXIT END; + IF lch > 0FFX THEN long := TRUE END; + IF i < LEN(s) - 1 THEN s[i] := lch + ELSIF i = LEN(s) - 1 THEN s[i] := 0X; NEW(lstr, 2 * LEN(s)); lstr^ := s$; lstr[i] := lch + ELSIF i < LEN(lstr^) - 1 THEN lstr[i] := lch + ELSE t := lstr; t[i] := 0X; NEW(lstr, 2 * LEN(t^)); lstr^ := t^$; lstr[i] := lch + END; + INC(i) + END ; + IF i = 1 THEN sym := number; numtyp := 1; intval := ORD(s[0]) + ELSE + sym := string; numtyp := 0; intval := i + 1; NEW(str, intval); + IF long THEN + IF i < LEN(s) THEN s[i] := 0X; NEW(lstr, intval); lstr^ := s$ + ELSE lstr[i] := 0X + END; + str^ := SHORT(lstr$) + ELSE + IF i < LEN(s) THEN s[i] := 0X; str^ := SHORT(s$); + ELSE lstr[i] := 0X; str^ := SHORT(lstr$) + END; + lstr := NIL + END + END; + DevCPM.Get(ch) + END Str; + + PROCEDURE Identifier(VAR sym: BYTE); + VAR i: SHORTINT; + BEGIN i := 0; + REPEAT + name[i] := ch; INC(i); DevCPM.Get(ch) + UNTIL (ch < "0") + OR ("9" < ch) & (CAP(ch) < "A") + OR ("Z" < CAP(ch)) & (ch # "_") & (ch < "À") + OR (ch = "×") + OR (ch = "÷") + OR (i = MaxIdLen); + IF i = MaxIdLen THEN err(240); DEC(i) END ; + name[i] := 0X; sym := ident + END Identifier; + + PROCEDURE Number; + VAR i, j, m, n, d, e, a: INTEGER; f, g, x: REAL; expCh, tch: SHORTCHAR; neg: BOOLEAN; r: SHORTREAL; + dig: ARRAY 30 OF SHORTCHAR; arr: ARRAY 2 OF INTEGER; + + PROCEDURE Ord(ch: SHORTCHAR; hex: BOOLEAN): SHORTINT; + BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *) + IF ch <= "9" THEN RETURN SHORT(ORD(ch) - ORD("0")) + ELSIF hex THEN RETURN SHORT(ORD(ch) - ORD("A") + 10) + ELSE err(2); RETURN 0 + END + END Ord; + + BEGIN (* ("0" <= ch) & (ch <= "9") *) + i := 0; m := 0; n := 0; d := 0; + LOOP (* read mantissa *) + IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN + IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *) + IF n < LEN(dig) THEN dig[n] := ch; INC(n) END; + INC(m) + END; + DevCPM.Get(ch); INC(i) + ELSIF ch = "." THEN DevCPM.Get(ch); + IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT + ELSIF d = 0 THEN (* i > 0 *) d := i + ELSE err(2) + END + ELSE EXIT + END + END; (* 0 <= n <= m <= i, 0 <= d <= i *) + IF d = 0 THEN (* integer *) realval := 0; numtyp := integer; + IF n = m THEN intval := 0; i := 0; + IF ch = "X" THEN (* character *) DevCPM.Get(ch); numtyp := char; + IF n <= 4 THEN + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END + ELSE err(203) + END + ELSIF (ch = "H") OR (ch = "S") THEN (* hex 32bit *) + tch := ch; DevCPM.Get(ch); + IF (ch = "L") & (DevCPM.oberon IN DevCPM.options) THEN (* old syntax: hex 64bit *) + DevCPM.searchpos := DevCPM.curpos - 2; DevCPM.Get(ch); + IF n <= 16 THEN + IF (n = 16) & (dig[0] > "7") THEN realval := -1 END; + WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END; + WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END; + numtyp := int64 + ELSE err(203) + END + ELSIF n <= 8 THEN + IF (n = 8) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END; + WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END; + IF tch = "S" THEN (* 32 bit hex float *) + r := SYSTEM.VAL(SHORTREAL, intval); + realval := r; intval := 0; numtyp := real32 + END + ELSE err(203) + END + ELSIF ch = "L" THEN (* hex 64bit *) + DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); + IF n <= 16 THEN + IF (n = 16) & (dig[0] > "7") THEN realval := -1 END; + WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END; + WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END; + numtyp := int64 + ELSE err(203) + END + ELSIF ch = "R" THEN (* hex float 64bit *) + DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); + IF n <= 16 THEN + a := 0; IF (n = 16) & (dig[0] > "7") THEN (* prevent overflow *) a := -1 END; + WHILE i < n-8 DO a := a*10H + Ord(dig[i], TRUE); INC(i) END; + IF DevCPM.LEHost THEN arr[1] := a ELSE arr[0] := a END; + a := 0; IF (n >= 8) & (dig[i] > "7") THEN (* prevent overflow *) a := -1 END; + WHILE i < n DO a := a*10H + Ord(dig[i], TRUE); INC(i) END; + IF DevCPM.LEHost THEN arr[0] := a ELSE arr[1] := a END; + realval := SYSTEM.VAL(REAL, arr); + intval := 0; numtyp := real64 + ELSE err(203) + END + ELSE (* decimal *) + WHILE i < n DO d := Ord(dig[i], FALSE); INC(i); + a := (MAX(INTEGER) - d) DIV 10; + IF intval > a THEN + a := (intval - a + 65535) DIV 65536 * 65536; + realval := realval + a; intval := intval - a + END; + realval := realval * 10; intval := intval * 10 + d + END; + IF realval = 0 THEN numtyp := integer + ELSIF intval < 9223372036854775808.0E0 - realval THEN numtyp := int64 (* 2^63 *) + ELSE intval := 0; err(203) + END + END + ELSE err(203) + END + ELSE (* fraction *) + f := 0; g := 0; e := 0; j := 0; expCh := "E"; + WHILE (j < 15) & (j < n) DO g := g * 10 + Ord(dig[j], FALSE); INC(j) END; (* !!! *) + WHILE n > j DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END; + IF (ch = "E") OR (ch = "D") & (DevCPM.oberon IN DevCPM.options) THEN + expCh := ch; DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); neg := FALSE; + IF ch = "-" THEN neg := TRUE; DevCPM.Get(ch) + ELSIF ch = "+" THEN DevCPM.Get(ch) + END; + IF ("0" <= ch) & (ch <= "9") THEN + REPEAT n := Ord(ch, FALSE); DevCPM.Get(ch); + IF e <= (MAX(SHORTINT) - n) DIV 10 THEN e := SHORT(e*10 + n) + ELSE err(203) + END + UNTIL (ch < "0") OR ("9" < ch); + IF neg THEN e := -e END + ELSE err(2) + END + END; + DEC(e, i-d-m); (* decimal point shift *) + IF e < -308 - 16 THEN + realval := 0.0 + ELSIF e < -308 + 14 THEN + realval := (f + g) / Math.IntPower(10, j-e-30) / 1.0E15 / 1.0E15 + ELSIF e < j THEN + realval := (f + g) / Math.IntPower(10, j-e) (* Ten(j-e) *) + ELSIF e <= 308 THEN + realval := (f + g) * Math.IntPower(10, e-j) (* Ten(e-j) *) + ELSIF e = 308 + 1 THEN + realval := (f + g) * (Math.IntPower(10, e-j) / 16); + IF realval <= DevCPM.MaxReal64 / 16 THEN realval := realval * 16 + ELSE err(203) + END + ELSE err(203) + END; + numtyp := real + END + END Number; + + PROCEDURE Get*(VAR sym: BYTE); + VAR s: BYTE; old: INTEGER; + + PROCEDURE Comment; (* do not read after end of file *) + BEGIN DevCPM.Get(ch); + LOOP + LOOP + WHILE ch = "(" DO DevCPM.Get(ch); + IF ch = "*" THEN Comment END + END ; + IF ch = "*" THEN DevCPM.Get(ch); EXIT END ; + IF ch = DevCPM.Eot THEN EXIT END ; + DevCPM.Get(ch) + END ; + IF ch = ")" THEN DevCPM.Get(ch); EXIT END ; + IF ch = DevCPM.Eot THEN err(5); EXIT END + END + END Comment; + + BEGIN + DevCPM.errpos := DevCPM.curpos-1; + WHILE (ch <= " ") OR (ch = 0A0X) DO (*ignore control characters*) + IF ch = DevCPM.Eot THEN sym := eof; RETURN + ELSE DevCPM.Get(ch) + END + END ; + DevCPM.startpos := DevCPM.curpos - 1; + CASE ch OF (* ch > " " *) + | 22X, 27X : Str(s) + | "#" : s := neq; DevCPM.Get(ch) + | "&" : s := and; DevCPM.Get(ch) + | "(" : DevCPM.Get(ch); + IF ch = "*" THEN Comment; old := DevCPM.errpos; Get(s); DevCPM.errpos := old; + ELSE s := lparen + END + | ")" : s := rparen; DevCPM.Get(ch) + | "*" : s := times; DevCPM.Get(ch) + | "+" : s := plus; DevCPM.Get(ch) + | "," : s := comma; DevCPM.Get(ch) + | "-" : s := minus; DevCPM.Get(ch) + | "." : DevCPM.Get(ch); + IF ch = "." THEN DevCPM.Get(ch); s := upto ELSE s := period END + | "/" : s := slash; DevCPM.Get(ch) + | "0".."9": Number; s := number + | ":" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := becomes ELSE s := colon END + | ";" : s := semicolon; DevCPM.Get(ch) + | "<" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := leq ELSE s := lss END + | "=" : s := eql; DevCPM.Get(ch) + | ">" : DevCPM.Get(ch); + IF ch = "=" THEN DevCPM.Get(ch); s := geq ELSE s := gtr END + | "A": Identifier(s); IF name = "ARRAY" THEN s := array END + | "B": Identifier(s); + IF name = "BEGIN" THEN s := begin + ELSIF name = "BY" THEN s := by + END + | "C": Identifier(s); + IF name = "CASE" THEN s := case + ELSIF name = "CONST" THEN s := const + ELSIF name = "CLOSE" THEN s := close + END + | "D": Identifier(s); + IF name = "DO" THEN s := do + ELSIF name = "DIV" THEN s := div + END + | "E": Identifier(s); + IF name = "END" THEN s := end + ELSIF name = "ELSE" THEN s := else + ELSIF name = "ELSIF" THEN s := elsif + ELSIF name = "EXIT" THEN s := exit + END + | "F": Identifier(s); IF name = "FOR" THEN s := for END + | "I": Identifier(s); + IF name = "IF" THEN s := if + ELSIF name = "IN" THEN s := in + ELSIF name = "IS" THEN s := is + ELSIF name = "IMPORT" THEN s := import + END + | "L": Identifier(s); IF name = "LOOP" THEN s := loop END + | "M": Identifier(s); + IF name = "MOD" THEN s := mod + ELSIF name = "MODULE" THEN s := module + END + | "N": Identifier(s); IF name = "NIL" THEN s := nil END + | "O": Identifier(s); + IF name = "OR" THEN s := or + ELSIF name = "OF" THEN s := of + ELSIF name = "OUT" THEN s := out + END + | "P": Identifier(s); + IF name = "PROCEDURE" THEN s := procedure + ELSIF name = "POINTER" THEN s := pointer + END + | "R": Identifier(s); + IF name = "RECORD" THEN s := record + ELSIF name = "REPEAT" THEN s := repeat + ELSIF name = "RETURN" THEN s := return + END + | "T": Identifier(s); + IF name = "THEN" THEN s := then + ELSIF name = "TO" THEN s := to + ELSIF name = "TYPE" THEN s := type + END + | "U": Identifier(s); IF name = "UNTIL" THEN s := until END + | "V": Identifier(s); IF name = "VAR" THEN s := var END + | "W": Identifier(s); + IF name = "WHILE" THEN s := while + ELSIF name = "WITH" THEN s := with + END + | "G".."H", "J", "K", "Q", "S", "X".."Z", "a".."z", "_" (* XXX *): Identifier(s) + | "[" : s := lbrak; DevCPM.Get(ch) + | "]" : s := rbrak; DevCPM.Get(ch) + | "^" : s := arrow; DevCPM.Get(ch) + | "$" : s := dollar; DevCPM.Get(ch) + | "{" : s := lbrace; DevCPM.Get(ch); + | "|" : s := bar; DevCPM.Get(ch) + | "}" : s := rbrace; DevCPM.Get(ch) + | "~" : s := not; DevCPM.Get(ch) + | 7FX : s := upto; DevCPM.Get(ch) + ELSE s := null; DevCPM.Get(ch) + END ; + sym := s + END Get; + + PROCEDURE Init*; + BEGIN ch := " " + END Init; + +END DevCPS. \ No newline at end of file diff --git a/Trurl-based/Dev/Mod/CPT.txt b/Trurl-based/Dev/Mod/CPT.txt new file mode 100644 index 0000000..2fdbc03 --- /dev/null +++ b/Trurl-based/Dev/Mod/CPT.txt @@ -0,0 +1,1890 @@ +MODULE DevCPT; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPT.odc *) + (* DO NOT EDIT *) + + IMPORT DevCPM; + + CONST + MaxIdLen = 256; + + TYPE + Name* = ARRAY MaxIdLen OF SHORTCHAR; + String* = POINTER TO ARRAY OF SHORTCHAR; + Const* = POINTER TO ConstDesc; + Object* = POINTER TO ObjDesc; + Struct* = POINTER TO StrDesc; + Node* = POINTER TO NodeDesc; + ConstExt* = String; + LinkList* = POINTER TO LinkDesc; + + ConstDesc* = RECORD + ext*: ConstExt; (* string or code for code proc (longstring in utf8) *) + intval*: INTEGER; (* constant value or adr, proc par size, text position or least case label *) + intval2*: INTEGER; (* string length (#char, incl 0X), proc var size or larger case label *) + setval*: SET; (* constant value, procedure body present or "ELSE" present in case *) + realval*: REAL; (* real or longreal constant value *) + link*: Const (* chain of constants present in obj file *) + END ; + + LinkDesc* = RECORD + offset*, linkadr*: INTEGER; + next*: LinkList; + END; + + ObjDesc* = RECORD + left*, right*, link*, scope*: Object; + name*: String; (* name = null OR name^ # "" *) + leaf*: BOOLEAN; + sysflag*: BYTE; + mode*, mnolev*: BYTE; (* mnolev < 0 -> mno = -mnolev *) + vis*: BYTE; (* internal, external, externalR, inPar, outPar *) + history*: BYTE; (* relevant if name # "" *) + used*, fpdone*: BOOLEAN; + fprint*: INTEGER; + typ*: Struct; (* actual type, changed in with statements *) + ptyp*: Struct; (* original type if typ is changed *) + conval*: Const; + adr*, num*: INTEGER; (* mthno *) + links*: LinkList; + nlink*: Object; (* link for name list, declaration order for methods, library link for imp obj *) + library*, entry*: String; (* library name, entry name *) + modifiers*: POINTER TO ARRAY OF String; (* additional interface strings *) + linkadr*: INTEGER; (* used in ofront *) + red: BOOLEAN; + END ; + + StrDesc* = RECORD + form*, comp*, mno*, extlev*: BYTE; + ref*, sysflag*: SHORTINT; + n*, size*, align*, txtpos*: INTEGER; (* align is alignment for records and len offset for dynarrs *) + untagged*, allocated*, pbused*, pvused*, exp*, fpdone, idfpdone: BOOLEAN; + attribute*: BYTE; + idfp, pbfp*, pvfp*:INTEGER; + BaseTyp*: Struct; + link*, strobj*: Object; + ext*: ConstExt (* id string for interface records *) + END ; + + NodeDesc* = RECORD + left*, right*, link*: Node; + class*, subcl*, hint*: BYTE; + readonly*: BOOLEAN; + typ*: Struct; + obj*: Object; + conval*: Const + END ; + + CONST + maxImps = 127; (* must be <= MAX(SHORTINT) *) + maxStruct = DevCPM.MaxStruct; (* must be < MAX(INTEGER) DIV 2 *) + FirstRef = 32; + FirstRef0 = 16; (* correction for version 0 *) + actVersion = 1; + + VAR + topScope*: Object; + undftyp*, bytetyp*, booltyp*, char8typ*, int8typ*, int16typ*, int32typ*, + real32typ*, real64typ*, settyp*, string8typ*, niltyp*, notyp*, sysptrtyp*, + anytyp*, anyptrtyp*, char16typ*, string16typ*, int64typ*, + restyp*, iunktyp*, punktyp*, guidtyp*, + intrealtyp*, lreal64typ*, lint64typ*, lchar16typ*: Struct; + nofGmod*: BYTE; (*nof imports*) + GlbMod*: ARRAY maxImps OF Object; (* .right = first object, .name = module import name (not alias) *) + SelfName*: Name; (* name of module being compiled *) + SYSimported*: BOOLEAN; + processor*, impProc*: SHORTINT; + libName*: Name; (* library alias of module being compiled *) + null*: String; (* "" *) + + CONST + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + AnyPtr = 14; AnyRec = 15; (* sym file only *) + Char16 = 16; String16 = 17; Int64 = 18; + Res = 20; IUnk = 21; PUnk = 22; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (*function number*) + assign = 0; + haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4; + entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9; + shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32; + lchrfn = 33; lentierfcn = 34; typfn = 36; bitsfn = 37; bytesfn = 38; + + (*SYSTEM function number*) + adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; + bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31; + thisrecfn = 45; thisarrfn = 46; + + (* COM function number *) + validfn = 40; iidfn = 41; queryfn = 42; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* procedure flags (conval.setval) *) + isHidden = 29; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* history of imported objects *) + inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; + + (* sysflags *) + inBit = 2; outBit = 4; interface = 10; + + (* symbol file items *) + Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22; + Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30; + Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40; + Shdutptr = 41; Slib = 42; Sentry = 43; Sinpar = 25; Soutpar = 26; + Slimrec = 25; Sabsrec = 26; Sextrec = 27; Slimpro = 31; Sabspro = 32; Semppro = 33; Sextpro = 34; Simpo = 22; + + TYPE + ImpCtxt = RECORD + nextTag, reffp: INTEGER; + nofr, minr, nofm: SHORTINT; + self: BOOLEAN; + ref: ARRAY maxStruct OF Struct; + old: ARRAY maxStruct OF Object; + pvfp: ARRAY maxStruct OF INTEGER; (* set only if old # NIL *) + glbmno: ARRAY maxImps OF BYTE (* index is local mno *) + END ; + + ExpCtxt = RECORD + reffp: INTEGER; + ref: SHORTINT; + nofm: BYTE; + locmno: ARRAY maxImps OF BYTE (* index is global mno *) + END ; + + VAR + universe, syslink, comlink, infinity: Object; + impCtxt: ImpCtxt; + expCtxt: ExpCtxt; + nofhdfld: INTEGER; + sfpresent, symExtended, symNew: BOOLEAN; + version: INTEGER; + symChanges: INTEGER; + portable: BOOLEAN; + depth: INTEGER; + + + PROCEDURE err(n: SHORTINT); + BEGIN DevCPM.err(n) + END err; + + PROCEDURE NewConst*(): Const; + VAR const: Const; + BEGIN NEW(const); RETURN const + END NewConst; + + PROCEDURE NewObj*(): Object; + VAR obj: Object; + BEGIN NEW(obj); obj.name := null; RETURN obj + END NewObj; + + PROCEDURE NewStr*(form, comp: BYTE): Struct; + VAR typ: Struct; + BEGIN NEW(typ); typ.form := form; typ.comp := comp; typ.ref := maxStruct; (* ref >= maxStruct: not exported yet *) + typ.txtpos := DevCPM.errpos; typ.size := -1; typ.BaseTyp := undftyp; RETURN typ + END NewStr; + + PROCEDURE NewNode*(class: BYTE): Node; + VAR node: Node; + BEGIN + NEW(node); node.class := class; RETURN node + END NewNode; +(* + PROCEDURE NewExt*(): ConstExt; + VAR ext: ConstExt; + BEGIN NEW(ext); RETURN ext + END NewExt; +*) + PROCEDURE NewName* ((*IN*) name: ARRAY OF SHORTCHAR): String; + VAR i: INTEGER; p: String; + BEGIN + i := 0; WHILE name[i] # 0X DO INC(i) END; + IF i > 0 THEN NEW(p, i + 1); p^ := name$; RETURN p + ELSE RETURN null + END + END NewName; + + PROCEDURE OpenScope*(level: BYTE; owner: Object); + VAR head: Object; + BEGIN head := NewObj(); + head.mode := Head; head.mnolev := level; head.link := owner; + IF owner # NIL THEN owner.scope := head END ; + head.left := topScope; head.right := NIL; head.scope := NIL; topScope := head + END OpenScope; + + PROCEDURE CloseScope*; + BEGIN topScope := topScope.left + END CloseScope; + + PROCEDURE Init*(opt: SET); + BEGIN + topScope := universe; OpenScope(0, NIL); SYSimported := FALSE; + GlbMod[0] := topScope; nofGmod := 1; + sfpresent := TRUE; (* !!! *) + symChanges := 0; + infinity.conval.intval := DevCPM.ConstNotAlloc; + depth := 0 + END Init; + + PROCEDURE Open* (name: Name); + BEGIN + SelfName := name$; topScope.name := NewName(name); + END Open; + + PROCEDURE Close*; + VAR i: SHORTINT; + BEGIN (* garbage collection *) + CloseScope; + i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ; + i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END + END Close; + + PROCEDURE SameType* (x, y: Struct): BOOLEAN; + BEGIN + RETURN (x = y) OR (x.form = y.form) & ~(x.form IN {Pointer, ProcTyp, Comp}) OR (x = undftyp) OR (y = undftyp) + END SameType; + + PROCEDURE EqualType* (x, y: Struct): BOOLEAN; + VAR xp, yp: Object; n: INTEGER; + BEGIN + n := 0; + WHILE (n < 100) & (x # y) + & (((x.comp = DynArr) & (y.comp = DynArr) & (x.sysflag = y.sysflag)) + OR ((x.form = Pointer) & (y.form = Pointer)) + OR ((x.form = ProcTyp) & (y.form = ProcTyp))) DO + IF x.form = ProcTyp THEN + IF x.sysflag # y.sysflag THEN RETURN FALSE END; + xp := x.link; yp := y.link; + INC(depth); + WHILE (xp # NIL) & (yp # NIL) & (xp.mode = yp.mode) & (xp.sysflag = yp.sysflag) + & (xp.vis = yp.vis) & (depth < 100) & EqualType(xp.typ, yp.typ) DO + xp := xp.link; yp := yp.link + END; + DEC(depth); + IF (xp # NIL) OR (yp # NIL) THEN RETURN FALSE END + END; + x := x.BaseTyp; y := y.BaseTyp; INC(n) + END; + RETURN SameType(x, y) + END EqualType; + + PROCEDURE Extends* (x, y: Struct): BOOLEAN; + BEGIN + IF (x.form = Pointer) & (y.form = Pointer) THEN x := x.BaseTyp; y := y.BaseTyp END; + IF (x.comp = Record) & (y.comp = Record) THEN + IF (y = anytyp) & ~x.untagged THEN RETURN TRUE END; + WHILE (x # NIL) & (x # undftyp) & (x # y) DO x := x.BaseTyp END + END; + RETURN (x # NIL) & EqualType(x, y) + END Extends; + + PROCEDURE Includes* (xform, yform: INTEGER): BOOLEAN; + BEGIN + CASE xform OF + | Char16: RETURN yform IN {Char8, Char16, Int8} + | Int16: RETURN yform IN {Char8, Int8, Int16} + | Int32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32} + | Int64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64} + | Real32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32} + | Real64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32, Real64} + | String16: RETURN yform IN {String8, String16} + ELSE RETURN xform = yform + END + END Includes; + + PROCEDURE FindImport*(VAR name: Name; mod: Object; VAR res: Object); + VAR obj: Object; (* i: INTEGER; n: Name; *) + BEGIN obj := mod.scope.right; + LOOP + IF obj = NIL THEN EXIT END ; + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (*found*) + IF (obj.mode = Typ) & (obj.vis = internal) THEN obj := NIL + ELSE obj.used := TRUE + END ; + EXIT + END + END ; + res := obj; +(* bh: checks usage of non Unicode WinApi functions and types + IF (res # NIL) & (mod.scope.library # NIL) + & ~(DevCPM.interface IN DevCPM.options) + & (SelfName # "Kernel") & (SelfName # "HostPorts") THEN + n := name + "W"; + FindImport(n, mod, obj); + IF obj # NIL THEN + DevCPM.err(733) + ELSE + i := LEN(name$); + IF name[i - 1] = "A" THEN + n[i - 1] := "W"; n[i] := 0X; + FindImport(n, mod, obj); + IF obj # NIL THEN + DevCPM.err(734) + END + END + END + END; +*) + END FindImport; + + PROCEDURE Find*(VAR name: Name; VAR res: Object); + VAR obj, head: Object; + BEGIN head := topScope; + LOOP obj := head.right; + LOOP + IF obj = NIL THEN EXIT END ; + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (* found, obj.used not set for local objects *) EXIT + END + END ; + IF obj # NIL THEN EXIT END ; + head := head.left; + IF head = NIL THEN EXIT END + END ; + res := obj + END Find; + + PROCEDURE FindFld (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + VAR obj: Object; + BEGIN + WHILE (typ # NIL) & (typ # undftyp) DO obj := typ.link; + WHILE obj # NIL DO + IF name < obj.name^ THEN obj := obj.left + ELSIF name > obj.name^ THEN obj := obj.right + ELSE (*found*) res := obj; RETURN + END + END ; + typ := typ.BaseTyp + END; + res := NIL + END FindFld; + + PROCEDURE FindField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + BEGIN + FindFld(name, typ, res); + IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END + END FindField; + + PROCEDURE FindBaseField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object); + BEGIN + FindFld(name, typ.BaseTyp, res); + IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END + END FindBaseField; + +(* + PROCEDURE Rotated (y: Object; name: String): Object; + VAR c, gc: Object; + BEGIN + IF name^ < y.name^ THEN + c := y.left; + IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c + ELSE gc := c.right; c.right := gc.left; gc.left := c + END; + y.left := gc + ELSE + c := y.right; + IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c + ELSE gc := c.right; c.right := gc.left; gc.left := c + END; + y.right := gc + END; + RETURN gc + END Rotated; + + PROCEDURE InsertIn (obj, scope: Object; VAR old: Object); + VAR gg, g, p, x: Object; name, sname: String; + BEGIN + sname := scope.name; scope.name := null; + gg := scope; g := gg; p := g; x := p.right; name := obj.name; + WHILE x # NIL DO + IF (x.left # NIL) & (x.right # NIL) & x.left.red & x.right.red THEN + x.red := TRUE; x.left.red := FALSE; x.right.red := FALSE; + IF p.red THEN + g.red := TRUE; + IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END; + x := Rotated(gg, name); x.red := FALSE + END + END; + gg := g; g := p; p := x; + IF name^ < x.name^ THEN x := x.left + ELSIF name^ > x.name^ THEN x := x.right + ELSE old := x; scope.right.red := FALSE; scope.name := sname; RETURN + END + END; + x := obj; old := NIL; + IF name^ < p.name^ THEN p.left := x ELSE p.right := x END; + x.red := TRUE; + IF p.red THEN + g.red := TRUE; + IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END; + x := Rotated(gg, name); + x.red := FALSE + END; + scope.right.red := FALSE; scope.name := sname + END InsertIn; +*) + PROCEDURE InsertIn (obj, scope: Object; VAR old: Object); + VAR ob0, ob1: Object; left: BOOLEAN; name: String; + BEGIN + ASSERT((scope # NIL) & (scope.mode = Head), 100); + ob0 := scope; ob1 := scope.right; left := FALSE; name := obj.name; + WHILE ob1 # NIL DO + IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE + ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE + ELSE old := ob1; RETURN + END + END; + IF left THEN ob0.left := obj ELSE ob0.right := obj END ; + obj.left := NIL; obj.right := NIL; old := NIL + END InsertIn; + + PROCEDURE Insert* (VAR name: Name; VAR obj: Object); + VAR old: Object; + BEGIN + obj := NewObj(); obj.leaf := TRUE; + obj.name := NewName(name); + obj.mnolev := topScope.mnolev; + InsertIn(obj, topScope, old); + IF old # NIL THEN err(1) END (*double def*) + END Insert; + + PROCEDURE InsertThisField (obj: Object; typ: Struct; VAR old: Object); + VAR ob0, ob1: Object; left: BOOLEAN; name: String; + BEGIN + IF typ.link = NIL THEN typ.link := obj + ELSE + ob1 := typ.link; name := obj.name; + REPEAT + IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE + ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE + ELSE old := ob1; RETURN + END + UNTIL ob1 = NIL; + IF left THEN ob0.left := obj ELSE ob0.right := obj END + END + END InsertThisField; + + PROCEDURE InsertField* (VAR name: Name; typ: Struct; VAR obj: Object); + VAR old: Object; + BEGIN + obj := NewObj(); obj.leaf := TRUE; + obj.name := NewName(name); + InsertThisField(obj, typ, old); + IF old # NIL THEN err(1) END (*double def*) + END InsertField; + + +(*-------------------------- Fingerprinting --------------------------*) + + PROCEDURE FPrintName(VAR fp: INTEGER; VAR name: ARRAY OF SHORTCHAR); + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X + END FPrintName; + + PROCEDURE ^IdFPrint*(typ: Struct); + + PROCEDURE FPrintSign*(VAR fp: INTEGER; result: Struct; par: Object); + (* depends on assignment compatibility of params only *) + BEGIN + IdFPrint(result); DevCPM.FPrint(fp, result.idfp); + WHILE par # NIL DO + DevCPM.FPrint(fp, par.mode); IdFPrint(par.typ); DevCPM.FPrint(fp, par.typ.idfp); + IF (par.mode = VarPar) & (par.vis # 0) THEN DevCPM.FPrint(fp, par.vis) END; (* IN / OUT *) + IF par.sysflag # 0 THEN DevCPM.FPrint(fp, par.sysflag) END; + (* par.name and par.adr not considered *) + par := par.link + END + END FPrintSign; + + PROCEDURE IdFPrint*(typ: Struct); (* idfp codifies assignment compatibility *) + VAR btyp: Struct; strobj: Object; idfp: INTEGER; f, c: SHORTINT; + BEGIN + IF ~typ.idfpdone THEN + typ.idfpdone := TRUE; (* may be recursive, temporary idfp is 0 in that case *) + idfp := 0; f := typ.form; c := typ.comp; DevCPM.FPrint(idfp, f); DevCPM.FPrint(idfp, c); + btyp := typ.BaseTyp; strobj := typ.strobj; + IF (strobj # NIL) & (strobj.name # null) THEN + FPrintName(idfp, GlbMod[typ.mno].name^); FPrintName(idfp, strobj.name^) + END ; + IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN + IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp) + ELSIF c = Array THEN IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp); DevCPM.FPrint(idfp, typ.n) + ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ.link) + END ; + typ.idfp := idfp + END + END IdFPrint; + + PROCEDURE FPrintStr*(typ: Struct); + VAR f, c: SHORTINT; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: INTEGER; + + PROCEDURE ^FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + + PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: INTEGER); (* modifies pvfp only *) + VAR i, j, n: INTEGER; btyp: Struct; + BEGIN + IF typ.comp = Record THEN FPrintFlds(typ.link, adr, FALSE) + ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + j := nofhdfld; FPrintHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO (* !!! *) + INC(adr, btyp.size); FPrintHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF DevCPM.ExpHdPtrFld & + ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN (* !!! *) + DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld) + ELSIF DevCPM.ExpHdUtPtrFld & + ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN (* !!! *) + DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld); + IF typ.form = Pointer THEN DevCPM.FPrint(pvfp, typ.sysflag) ELSE DevCPM.FPrint(pvfp, fld.sysflag) END + ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN + DevCPM.FPrint(pvfp, ProcTyp); DevCPM.FPrint(pvfp, adr); INC(nofhdfld) + END + END FPrintHdFld; + + PROCEDURE FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); (* modifies pbfp and pvfp *) + BEGIN + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.vis # internal) & visible THEN + DevCPM.FPrint(pvfp, fld.vis); FPrintName(pvfp, fld.name^); DevCPM.FPrint(pvfp, fld.adr); + DevCPM.FPrint(pbfp, fld.vis); FPrintName(pbfp, fld.name^); DevCPM.FPrint(pbfp, fld.adr); + FPrintStr(fld.typ); DevCPM.FPrint(pbfp, fld.typ.pbfp); DevCPM.FPrint(pvfp, fld.typ.pvfp) + ELSE FPrintHdFld(fld.typ, fld, fld.adr + adr) + END ; + fld := fld.link + END + END FPrintFlds; + + PROCEDURE FPrintTProcs(obj: Object); (* modifies pbfp and pvfp *) + VAR fp: INTEGER; + BEGIN + IF obj # NIL THEN + FPrintTProcs(obj.left); + IF obj.mode = TProc THEN + IF obj.vis # internal THEN + fp := 0; + IF obj.vis = externalR THEN DevCPM.FPrint(fp, externalR) END; + IF limAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, limAttr) + ELSIF absAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, absAttr) + ELSIF empAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, empAttr) + ELSIF extAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, extAttr) + END; + DevCPM.FPrint(fp, TProc); DevCPM.FPrint(fp, obj.num); + FPrintSign(fp, obj.typ, obj.link); FPrintName(fp, obj.name^); + IF obj.entry # NIL THEN FPrintName(fp, obj.entry^) END; + DevCPM.FPrint(pvfp, fp); DevCPM.FPrint(pbfp, fp) + ELSIF DevCPM.ExpHdTProc THEN + DevCPM.FPrint(pvfp, TProc); DevCPM.FPrint(pvfp, obj.num) + END + END; + FPrintTProcs(obj.right) + END + END FPrintTProcs; + + BEGIN + IF ~typ.fpdone THEN + IdFPrint(typ); pbfp := typ.idfp; + IF typ.sysflag # 0 THEN DevCPM.FPrint(pbfp, typ.sysflag) END; + IF typ.ext # NIL THEN FPrintName(pbfp, typ.ext^) END; + IF typ.attribute # 0 THEN DevCPM.FPrint(pbfp, typ.attribute) END; + pvfp := pbfp; typ.pbfp := pbfp; typ.pvfp := pvfp; (* initial fprints may be used recursively *) + typ.fpdone := TRUE; + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF f = Pointer THEN + strobj := typ.strobj; bstrobj := btyp.strobj; + IF (strobj = NIL) OR (strobj.name = null) OR (bstrobj = NIL) OR (bstrobj.name = null) THEN + FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); pvfp := pbfp + (* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *) + END + ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *) + ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pvfp); pvfp := pbfp + ELSE (* c = Record *) + IF btyp # NIL THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); DevCPM.FPrint(pvfp, btyp.pvfp) END ; + DevCPM.FPrint(pvfp, typ.size); DevCPM.FPrint(pvfp, typ.align); DevCPM.FPrint(pvfp, typ.n); + nofhdfld := 0; FPrintFlds(typ.link, 0, TRUE); + FPrintTProcs(typ.link); (* DevCPM.FPrint(pvfp, pbfp); *) strobj := typ.strobj; + IF (strobj = NIL) OR (strobj.name = null) THEN pbfp := pvfp END + END ; + typ.pbfp := pbfp; typ.pvfp := pvfp + END + END FPrintStr; + + PROCEDURE FPrintObj*(obj: Object); + VAR fprint: INTEGER; f, m: SHORTINT; rval: SHORTREAL; ext: ConstExt; mod: Object; r: REAL; x: INTEGER; + BEGIN + IF ~obj.fpdone THEN + fprint := 0; obj.fpdone := TRUE; + DevCPM.FPrint(fprint, obj.mode); + IF obj.mode = Con THEN + f := obj.typ.form; DevCPM.FPrint(fprint, f); + CASE f OF + | Bool, Char8, Char16, Int8, Int16, Int32: + DevCPM.FPrint(fprint, obj.conval.intval) + | Int64: + x := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4294967296.0)); + r := obj.conval.realval + obj.conval.intval - x * 4294967296.0; + IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; + DevCPM.FPrint(fprint, SHORT(ENTIER(r))); + DevCPM.FPrint(fprint, x) + | Set: + DevCPM.FPrintSet(fprint, obj.conval.setval) + | Real32: + rval := SHORT(obj.conval.realval); DevCPM.FPrintReal(fprint, rval) + | Real64: + DevCPM.FPrintLReal(fprint, obj.conval.realval) + | String8, String16: + FPrintName(fprint, obj.conval.ext^) + | NilTyp: + ELSE err(127) + END + ELSIF obj.mode = Var THEN + DevCPM.FPrint(fprint, obj.vis); FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp) + ELSIF obj.mode IN {XProc, IProc} THEN + FPrintSign(fprint, obj.typ, obj.link) + ELSIF obj.mode = CProc THEN + FPrintSign(fprint, obj.typ, obj.link); ext := obj.conval.ext; + m := ORD(ext^[0]); f := 1; DevCPM.FPrint(fprint, m); + WHILE f <= m DO DevCPM.FPrint(fprint, ORD(ext^[f])); INC(f) END + ELSIF obj.mode = Typ THEN + FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp) + END ; + IF obj.sysflag < 0 THEN DevCPM.FPrint(fprint, obj.sysflag) END; + IF obj.mode IN {LProc, XProc, CProc, Var, Typ, Con} THEN + IF obj.library # NIL THEN + FPrintName(fprint, obj.library^) + ELSIF obj.mnolev < 0 THEN + mod := GlbMod[-obj.mnolev]; + IF (mod.library # NIL) THEN + FPrintName(fprint, mod.library^) + END + ELSIF obj.mnolev = 0 THEN + IF libName # "" THEN FPrintName(fprint, libName) END + END; + IF obj.entry # NIL THEN FPrintName(fprint, obj.entry^) END + END; + obj.fprint := fprint + END + END FPrintObj; + + PROCEDURE FPrintErr* (obj: Object; errno: SHORTINT); (* !!! *) + BEGIN + IF errno = 249 THEN + DevCPM.LogWLn; DevCPM.LogWStr(" "); + DevCPM.LogWStr(GlbMod[-obj.mnolev].name^); + DevCPM.LogW("."); DevCPM.LogWStr(obj.name^); + DevCPM.LogWStr(" is not consistently imported"); + err(249) + ELSIF obj = NIL THEN (* changed module sys flags *) + IF ~symNew & sfpresent THEN + DevCPM.LogWLn; DevCPM.LogWStr(" changed library flag") + END + ELSIF obj.mnolev = 0 THEN (* don't report changes in imported modules *) + IF sfpresent THEN + IF symChanges < 20 THEN + DevCPM.LogWLn; DevCPM.LogWStr(" "); DevCPM.LogWStr(obj.name^); + IF errno = 250 THEN DevCPM.LogWStr(" is no longer in symbol file") + ELSIF errno = 251 THEN DevCPM.LogWStr(" is redefined internally ") + ELSIF errno = 252 THEN DevCPM.LogWStr(" is redefined") + ELSIF errno = 253 THEN DevCPM.LogWStr(" is new in symbol file") + END + ELSIF symChanges = 20 THEN + DevCPM.LogWLn; DevCPM.LogWStr(" ...") + END; + INC(symChanges) + ELSIF (errno = 253) & ~symExtended THEN + DevCPM.LogWLn; + DevCPM.LogWStr(" new symbol file") + END + END; + IF errno = 253 THEN symExtended := TRUE ELSE symNew := TRUE END + END FPrintErr; + +(*-------------------------- Import --------------------------*) + + PROCEDURE InName(VAR name: String); + VAR i: SHORTINT; ch: SHORTCHAR; n: Name; + BEGIN i := 0; + REPEAT + DevCPM.SymRCh(ch); n[i] := ch; INC(i) + UNTIL ch = 0X; + IF i > 1 THEN NEW(name, i); name^ := n$ ELSE name := null END + END InName; + + PROCEDURE InMod(tag: INTEGER; VAR mno: BYTE); (* mno is global *) + VAR head: Object; name: String; mn: INTEGER; i: BYTE; lib: String; + BEGIN + IF tag = 0 THEN mno := impCtxt.glbmno[0] + ELSIF tag > 0 THEN + lib := NIL; + IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END; + ASSERT(tag = Smname); + InName(name); + IF (name^ = SelfName) & ~impCtxt.self & ~(DevCPM.interface IN DevCPM.options) THEN err(154) END ; + i := 0; + WHILE (i < nofGmod) & (name^ # GlbMod[i].name^) DO INC(i) END ; + IF i < nofGmod THEN mno := i (*module already present*) + ELSE + head := NewObj(); head.mode := Head; head.name := name; + mno := nofGmod; head.mnolev := SHORT(SHORT(-mno)); + head.library := lib; + IF nofGmod < maxImps THEN + GlbMod[mno] := head; INC(nofGmod) + ELSE err(227) + END + END ; + impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm) + ELSE + mno := impCtxt.glbmno[-tag] + END + END InMod; + + PROCEDURE InConstant(f: INTEGER; conval: Const); + VAR ch, ch1: SHORTCHAR; ext, t: ConstExt; rval: SHORTREAL; r, s: REAL; i, x, y: INTEGER; str: Name; + BEGIN + CASE f OF + | Byte, Char8, Bool: + DevCPM.SymRCh(ch); conval.intval := ORD(ch) + | Char16: + DevCPM.SymRCh(ch); conval.intval := ORD(ch); + DevCPM.SymRCh(ch); conval.intval := conval.intval + ORD(ch) * 256 + | Int8, Int16, Int32: + conval.intval := DevCPM.SymRInt() + | Int64: + DevCPM.SymRCh(ch); x := 0; y := 1; r := 0; s := 268435456 (*2^28*); + WHILE (y < 268435456 (*2^28*)) & (ch >= 80X) DO + x := x + (ORD(ch) - 128) * y; y := y * 128; DevCPM.SymRCh(ch) + END; + WHILE ch >= 80X DO r := r + (ORD(ch) - 128) * s; s := s * 128; DevCPM.SymRCh(ch) END; + conval.realval := r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s; + conval.intval := SHORT(ENTIER(r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s - conval.realval)) + | Set: + DevCPM.SymRSet(conval.setval) + | Real32: + DevCPM.SymRReal(rval); conval.realval := rval; + conval.intval := DevCPM.ConstNotAlloc + | Real64: + DevCPM.SymRLReal(conval.realval); + conval.intval := DevCPM.ConstNotAlloc + | String8, String16: + i := 0; + REPEAT + DevCPM.SymRCh(ch); + IF i < LEN(str) - 1 THEN str[i] := ch + ELSIF i = LEN(str) - 1 THEN str[i] := 0X; NEW(ext, 2 * LEN(str)); ext^ := str$; ext[i] := ch + ELSIF i < LEN(ext^) - 1 THEN ext[i] := ch + ELSE t := ext; t[i] := 0X; NEW(ext, 2 * LEN(t^)); ext^ := t^$; ext[i] := ch + END; + INC(i) + UNTIL ch = 0X; + IF i < LEN(str) THEN NEW(ext, i); ext^ := str$ END; + conval.ext := ext; conval.intval := DevCPM.ConstNotAlloc; + IF f = String8 THEN conval.intval2 := i + ELSE + i := 0; y := 0; + REPEAT DevCPM.GetUtf8(ext^, x, i); INC(y) UNTIL x = 0; + conval.intval2 := y + END +(* + ext := NewExt(); conval.ext := ext; i := 0; + REPEAT + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i) + UNTIL ch = 0X; + conval.intval2 := i; + conval.intval := DevCPM.ConstNotAlloc + | String16: + ext := NewExt(); conval.ext := ext; i := 0; + REPEAT + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i); + DevCPM.SymRCh(ch1); ext^[i] := ch1; INC(i) + UNTIL (ch = 0X) & (ch1 = 0X); + conval.intval2 := i; + conval.intval := DevCPM.ConstNotAlloc +*) + | NilTyp: + conval.intval := 0 +(* + | Guid: + ext := NewExt(); conval.ext := ext; i := 0; + WHILE i < 16 DO + DevCPM.SymRCh(ch); ext^[i] := ch; INC(i) + END; + ext[16] := 0X; + conval.intval2 := 16; + conval.intval := DevCPM.ConstNotAlloc; +*) + END + END InConstant; + + PROCEDURE ^InStruct(VAR typ: Struct); + + PROCEDURE InSign(mno: BYTE; VAR res: Struct; VAR par: Object); + VAR last, new: Object; tag: INTEGER; + BEGIN + InStruct(res); + tag := DevCPM.SymRInt(); last := NIL; + WHILE tag # Send DO + new := NewObj(); new.mnolev := SHORT(SHORT(-mno)); + IF last = NIL THEN par := new ELSE last.link := new END ; + IF tag = Ssys THEN + new.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt(); + IF ODD(new.sysflag DIV inBit) THEN new.vis := inPar + ELSIF ODD(new.sysflag DIV inBit) THEN new.vis := outPar + END + END; + IF tag = Svalpar THEN new.mode := Var + ELSE new.mode := VarPar; + IF tag = Sinpar THEN new.vis := inPar + ELSIF tag = Soutpar THEN new.vis := outPar + END + END ; + InStruct(new.typ); new.adr := DevCPM.SymRInt(); InName(new.name); + last := new; tag := DevCPM.SymRInt() + END + END InSign; + + PROCEDURE InFld(): Object; (* first number in impCtxt.nextTag, mno set outside *) + VAR tag: INTEGER; obj: Object; + BEGIN + tag := impCtxt.nextTag; obj := NewObj(); + IF tag <= Srfld THEN + obj.mode := Fld; + IF tag = Srfld THEN obj.vis := externalR ELSE obj.vis := external END ; + InStruct(obj.typ); InName(obj.name); + obj.adr := DevCPM.SymRInt() + ELSE + obj.mode := Fld; + IF tag = Shdptr THEN obj.name := NewName(DevCPM.HdPtrName) + ELSIF tag = Shdutptr THEN obj.name := NewName(DevCPM.HdUtPtrName); (* !!! *) + obj.sysflag := 1 + ELSIF tag = Ssys THEN + obj.name := NewName(DevCPM.HdUtPtrName); obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())) + ELSE obj.name := NewName(DevCPM.HdProcName) + END; + obj.typ := undftyp; obj.vis := internal; + obj.adr := DevCPM.SymRInt() + END; + RETURN obj + END InFld; + + PROCEDURE InTProc(mno: BYTE): Object; (* first number in impCtxt.nextTag *) + VAR tag: INTEGER; obj: Object; + BEGIN + tag := impCtxt.nextTag; + obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); + IF tag = Shdtpro THEN + obj.mode := TProc; obj.name := NewName(DevCPM.HdTProcName); + obj.link := NewObj(); (* dummy, easier in Browser *) + obj.typ := undftyp; obj.vis := internal; + obj.num := DevCPM.SymRInt() + ELSE + obj.vis := external; + IF tag = Simpo THEN obj.vis := externalR; tag := DevCPM.SymRInt() END; + obj.mode := TProc; obj.conval := NewConst(); obj.conval.intval := -1; + IF tag = Sentry THEN InName(obj.entry); tag := DevCPM.SymRInt() END; + InSign(mno, obj.typ, obj.link); InName(obj.name); + obj.num := DevCPM.SymRInt(); + IF tag = Slimpro THEN INCL(obj.conval.setval, limAttr) + ELSIF tag = Sabspro THEN INCL(obj.conval.setval, absAttr) + ELSIF tag = Semppro THEN INCL(obj.conval.setval, empAttr) + ELSIF tag = Sextpro THEN INCL(obj.conval.setval, extAttr) + END + END ; + RETURN obj + END InTProc; + + PROCEDURE InStruct(VAR typ: Struct); + VAR mno: BYTE; ref: SHORTINT; tag: INTEGER; name: String; + t: Struct; obj, last, fld, old, dummy: Object; + BEGIN + tag := DevCPM.SymRInt(); + IF tag # Sstruct THEN + tag := -tag; + IF (version = 0) & (tag >= FirstRef0) THEN tag := tag + FirstRef - FirstRef0 END; (* correction for new FirstRef *) + typ := impCtxt.ref[tag] + ELSE + ref := impCtxt.nofr; INC(impCtxt.nofr); + IF ref < impCtxt.minr THEN impCtxt.minr := ref END ; + tag := DevCPM.SymRInt(); + InMod(tag, mno); InName(name); obj := NewObj(); + IF name = null THEN + IF impCtxt.self THEN old := NIL (* do not insert type desc anchor here, but in OPL *) + ELSE obj.name := NewName("@"); InsertIn(obj, GlbMod[mno], old(*=NIL*)); obj.name := null + END ; + typ := NewStr(Undef, Basic) + ELSE obj.name := name; InsertIn(obj, GlbMod[mno], old); + IF old # NIL THEN (* recalculate fprints to compare with old fprints *) + FPrintObj(old); impCtxt.pvfp[ref] := old.typ.pvfp; + IF impCtxt.self THEN (* do not overwrite old typ *) + typ := NewStr(Undef, Basic) + ELSE (* overwrite old typ for compatibility reason *) + typ := old.typ; typ.link := NIL; typ.sysflag := 0; typ.ext := NIL; + typ.fpdone := FALSE; typ.idfpdone := FALSE + END + ELSE typ := NewStr(Undef, Basic) + END + END ; + impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; typ.ref := SHORT(ref + maxStruct); + (* ref >= maxStruct: not exported yet, ref used for err 155 *) + typ.mno := mno; typ.allocated := TRUE; + typ.strobj := obj; obj.mode := Typ; obj.typ := typ; + obj.mnolev := SHORT(SHORT(-mno)); obj.vis := internal; (* name not visible here *) + tag := DevCPM.SymRInt(); + IF tag = Ssys THEN + typ.sysflag := SHORT(DevCPM.SymRInt()); tag := DevCPM.SymRInt() + END; + typ.untagged := typ.sysflag > 0; + IF tag = Slib THEN + InName(obj.library); tag := DevCPM.SymRInt() + END; + IF tag = Sentry THEN + InName(obj.entry); tag := DevCPM.SymRInt() + END; + IF tag = String8 THEN + InName(typ.ext); tag := DevCPM.SymRInt() + END; + CASE tag OF + | Sptr: + typ.form := Pointer; typ.size := DevCPM.PointerSize; typ.n := 0; InStruct(typ.BaseTyp) + | Sarr: + typ.form := Comp; typ.comp := Array; InStruct(typ.BaseTyp); typ.n := DevCPM.SymRInt(); + typ.size := typ.n * typ.BaseTyp.size (* !!! *) + | Sdarr: + typ.form := Comp; typ.comp := DynArr; InStruct(typ.BaseTyp); + IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 + ELSE typ.n := 0 + END ; + typ.size := DevCPM.DArrSizeA + DevCPM.DArrSizeB * typ.n; (* !!! *) + IF typ.untagged THEN typ.size := DevCPM.PointerSize END + | Srec, Sabsrec, Slimrec, Sextrec: + typ.form := Comp; typ.comp := Record; InStruct(typ.BaseTyp); + (* correction by ETH 18.1.96 *) + IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL END; + typ.extlev := 0; t := typ.BaseTyp; + WHILE (t # NIL) & (t.comp = Record) DO INC(typ.extlev); t := t.BaseTyp END; + typ.size := DevCPM.SymRInt(); typ.align := DevCPM.SymRInt(); + typ.n := DevCPM.SymRInt(); + IF tag = Sabsrec THEN typ.attribute := absAttr + ELSIF tag = Slimrec THEN typ.attribute := limAttr + ELSIF tag = Sextrec THEN typ.attribute := extAttr + END; + impCtxt.nextTag := DevCPM.SymRInt(); last := NIL; + WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro) + OR (impCtxt.nextTag = Shdutptr) OR (impCtxt.nextTag = Ssys) DO + fld := InFld(); fld.mnolev := SHORT(SHORT(-mno)); + IF last # NIL THEN last.link := fld END ; + last := fld; + InsertThisField(fld, typ, dummy); + impCtxt.nextTag := DevCPM.SymRInt() + END ; + WHILE impCtxt.nextTag # Send DO fld := InTProc(mno); + InsertThisField(fld, typ, dummy); + impCtxt.nextTag := DevCPM.SymRInt() + END + | Spro: + typ.form := ProcTyp; typ.size := DevCPM.ProcSize; InSign(mno, typ.BaseTyp, typ.link) + | Salias: + InStruct(t); + typ.form := t.form; typ.comp := Basic; typ.size := t.size; + typ.pbfp := t.pbfp; typ.pvfp := t.pvfp; typ.fpdone := TRUE; + typ.idfp := t.idfp; typ.idfpdone := TRUE; typ.BaseTyp := t + END ; + IF ref = impCtxt.minr THEN + WHILE ref < impCtxt.nofr DO + t := impCtxt.ref[ref]; FPrintStr(t); + obj := t.strobj; (* obj.typ.strobj = obj, else obj.fprint differs (alias) *) + IF obj.name # null THEN FPrintObj(obj) END ; + old := impCtxt.old[ref]; + IF old # NIL THEN t.strobj := old; (* restore strobj *) + IF impCtxt.self THEN + IF old.mnolev < 0 THEN + IF old.history # inconsistent THEN + IF old.fprint # obj.fprint THEN old.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified + END + (* ELSE remain inconsistent *) + END + ELSIF old.fprint # obj.fprint THEN old.history := pbmodified + ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified + ELSIF old.vis = internal THEN old.history := same (* may be changed to "removed" in InObj *) + ELSE old.history := inserted (* may be changed to "same" in InObj *) + END + ELSE + (* check private part, delay error message until really used *) + IF impCtxt.pvfp[ref] # t.pvfp THEN old.history := inconsistent END ; + IF old.fprint # obj.fprint THEN FPrintErr(old, 249) END + END + ELSIF impCtxt.self THEN obj.history := removed + ELSE obj.history := same + END ; + INC(ref) + END ; + impCtxt.minr := maxStruct + END + END + END InStruct; + + PROCEDURE InObj(mno: BYTE): Object; (* first number in impCtxt.nextTag *) + VAR ch: SHORTCHAR; obj, old: Object; typ: Struct; + tag, i, s: INTEGER; ext: ConstExt; + BEGIN + tag := impCtxt.nextTag; + IF tag = Stype THEN + InStruct(typ); obj := typ.strobj; + IF ~impCtxt.self THEN obj.vis := external END (* type name visible now, obj.fprint already done *) + ELSE + obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); obj.vis := external; + IF tag = Ssys THEN obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt() END; + IF tag = Slib THEN + InName(obj.library); tag := DevCPM.SymRInt() + END; + IF tag = Sentry THEN + InName(obj.entry); tag := DevCPM.SymRInt() + END; + IF tag >= Sxpro THEN + IF obj.conval = NIL THEN obj.conval := NewConst() END; + obj.conval.intval := -1; + InSign(mno, obj.typ, obj.link); + CASE tag OF + | Sxpro: obj.mode := XProc + | Sipro: obj.mode := IProc + | Scpro: obj.mode := CProc; + s := DevCPM.SymRInt(); + NEW(ext, s + 1); obj.conval.ext := ext; + ext^[0] := SHORT(CHR(s)); i := 1; + WHILE i <= s DO DevCPM.SymRCh(ext^[i]); INC(i) END + END + ELSIF tag = Salias THEN + obj.mode := Typ; InStruct(obj.typ) + ELSIF (tag = Svar) OR (tag = Srvar) THEN + obj.mode := Var; + IF tag = Srvar THEN obj.vis := externalR END ; + InStruct(obj.typ) + ELSE (* Constant *) + obj.conval := NewConst(); InConstant(tag, obj.conval); + IF (tag = Int8) OR (tag = Int16) THEN tag := Int32 END; + obj.mode := Con; obj.typ := impCtxt.ref[tag]; + END ; + InName(obj.name) + END ; + FPrintObj(obj); + IF (obj.mode = Var) & ((obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null)) THEN + (* compute a global fingerprint to avoid structural type equivalence for anonymous types *) + DevCPM.FPrint(impCtxt.reffp, obj.typ.ref - maxStruct) + END ; + IF tag # Stype THEN + InsertIn(obj, GlbMod[mno], old); + IF impCtxt.self THEN + IF old # NIL THEN + (* obj is from old symbol file, old is new declaration *) + IF old.vis = internal THEN old.history := removed + ELSE FPrintObj(old); FPrintStr(old.typ); (* FPrint(obj) already called *) + IF obj.fprint # old.fprint THEN old.history := pbmodified + ELSIF obj.typ.pvfp # old.typ.pvfp THEN old.history := pvmodified + ELSE old.history := same + END + END + ELSE obj.history := removed (* OutObj not called if mnolev < 0 *) + END + (* ELSE old = NIL, or file read twice, consistent, OutObj not called *) + END + ELSE (* obj already inserted in InStruct *) + IF impCtxt.self THEN (* obj.mnolev = 0 *) + IF obj.vis = internal THEN obj.history := removed + ELSIF obj.history = inserted THEN obj.history := same + END + (* ELSE OutObj not called for obj with mnolev < 0 *) + END + END ; + RETURN obj + END InObj; + + PROCEDURE Import*(aliasName: Name; VAR name: Name; VAR done: BOOLEAN); + VAR obj, h: Object; mno: BYTE; tag, p: INTEGER; lib: String; (* done used in Browser *) + BEGIN + IF name = "SYSTEM" THEN + SYSimported := TRUE; + p := processor; + IF (p < 10) OR (p > 30) THEN p := DevCPM.sysImp END; + INCL(DevCPM.options, p); (* for sysflag handling *) + Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := syslink; obj.typ := notyp; + h := NewObj(); h.mode := Head; h.right := syslink; obj.scope := h + ELSIF name = "COM" THEN + IF DevCPM.comAware IN DevCPM.options THEN + INCL(DevCPM.options, DevCPM.com); (* for sysflag handling *) + Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := comlink; obj.typ := notyp; + h := NewObj(); h.mode := Head; h.right := comlink; obj.scope := h; + ELSE err(151) + END; + ELSIF name = "JAVA" THEN + INCL(DevCPM.options, DevCPM.java) + ELSE + impCtxt.nofr := FirstRef; impCtxt.minr := maxStruct; impCtxt.nofm := 0; + impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0; + DevCPM.OldSym(name, done); + IF done THEN + lib := NIL; + impProc := SHORT(DevCPM.SymRInt()); + IF (impProc # 0) & (processor # 0) & (impProc # processor) THEN err(151) END; + DevCPM.checksum := 0; (* start checksum here to avoid problems with proc id fixup *) + tag := DevCPM.SymRInt(); + IF tag < Smname THEN version := tag; tag := DevCPM.SymRInt() + ELSE version := 0 + END; + IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END; + InMod(tag, mno); + IF (name[0] # "@") & (GlbMod[mno].name^ # name) THEN (* symbol file name conflict *) + GlbMod[mno] := NIL; nofGmod := mno; DEC(impCtxt.nofm); + DevCPM.CloseOldSym; done := FALSE + END; + END; + IF done THEN + GlbMod[mno].library := lib; + impCtxt.nextTag := DevCPM.SymRInt(); + WHILE ~DevCPM.eofSF() DO + obj := InObj(mno); impCtxt.nextTag := DevCPM.SymRInt() + END ; + Insert(aliasName, obj); + obj.mode := Mod; obj.scope := GlbMod[mno](*.right*); + GlbMod[mno].link := obj; + obj.mnolev := SHORT(SHORT(-mno)); obj.typ := notyp; + DevCPM.CloseOldSym + ELSIF impCtxt.self THEN + sfpresent := FALSE + ELSE err(152) (*sym file not found*) + END + END + END Import; + +(*-------------------------- Export --------------------------*) + + PROCEDURE OutName(VAR name: ARRAY OF SHORTCHAR); + VAR i: SHORTINT; ch: SHORTCHAR; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.SymWCh(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE OutMod(mno: SHORTINT); + VAR mod: Object; + BEGIN + IF expCtxt.locmno[mno] < 0 THEN (* new mod *) + mod := GlbMod[mno]; + IF mod.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(mod.library^) + END; + DevCPM.SymWInt(Smname); + expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm); + OutName(mod.name^) + ELSE DevCPM.SymWInt(-expCtxt.locmno[mno]) + END + END OutMod; + + PROCEDURE ^OutStr(typ: Struct); + PROCEDURE ^OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + + PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: INTEGER); + VAR i, j, n: INTEGER; btyp: Struct; + BEGIN + IF typ.comp = Record THEN OutFlds(typ.link, adr, FALSE) + ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + j := nofhdfld; OutHdFld(btyp, fld, adr); + IF j # nofhdfld THEN i := 1; + WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO (* !!! *) + INC(adr, btyp.size); OutHdFld(btyp, fld, adr); INC(i) + END + END + END + ELSIF DevCPM.ExpHdPtrFld & + ((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN (* !!! *) + DevCPM.SymWInt(Shdptr); DevCPM.SymWInt(adr); INC(nofhdfld) + ELSIF DevCPM.ExpHdUtPtrFld & + ((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN (* !!! *) + DevCPM.SymWInt(Ssys); (* DevCPM.SymWInt(Shdutptr); *) + IF typ.form = Pointer THEN n := typ.sysflag ELSE n := fld.sysflag END; + DevCPM.SymWInt(n); + DevCPM.SymWInt(adr); INC(nofhdfld); + IF n > 1 THEN portable := FALSE END (* hidden untagged pointer are portable *) + ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN + DevCPM.SymWInt(Shdpro); DevCPM.SymWInt(adr); INC(nofhdfld) + END + END OutHdFld; + + PROCEDURE OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN); + BEGIN + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.vis # internal) & visible THEN + IF fld.vis = externalR THEN DevCPM.SymWInt(Srfld) ELSE DevCPM.SymWInt(Sfld) END ; + OutStr(fld.typ); OutName(fld.name^); DevCPM.SymWInt(fld.adr) + ELSE OutHdFld(fld.typ, fld, fld.adr + adr) + END ; + fld := fld.link + END + END OutFlds; + + PROCEDURE OutSign(result: Struct; par: Object); + BEGIN + OutStr(result); + WHILE par # NIL DO + IF par.sysflag # 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(par.sysflag) END; + IF par.mode = Var THEN DevCPM.SymWInt(Svalpar) + ELSIF par.vis = inPar THEN DevCPM.SymWInt(Sinpar) + ELSIF par.vis = outPar THEN DevCPM.SymWInt(Soutpar) + ELSE DevCPM.SymWInt(Svarpar) + END ; + OutStr(par.typ); + DevCPM.SymWInt(par.adr); + OutName(par.name^); par := par.link + END ; + DevCPM.SymWInt(Send) + END OutSign; + + PROCEDURE OutTProcs(typ: Struct; obj: Object); + VAR bObj: Object; + BEGIN + IF obj # NIL THEN + IF obj.mode = TProc THEN +(* + IF (typ.BaseTyp # NIL) & (obj.num < typ.BaseTyp.n) & (obj.vis = internal) & (obj.scope # NIL) THEN + FindBaseField(obj.name^, typ, bObj); + ASSERT((bObj # NIL) & (bObj.num = obj.num)); + IF bObj.vis # internal THEN DevCPM.Mark(109, typ.txtpos) END + (* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *) + END; +*) + IF obj.vis # internal THEN + IF obj.vis = externalR THEN DevCPM.SymWInt(Simpo) END; + IF obj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE + END; + IF limAttr IN obj.conval.setval THEN DevCPM.SymWInt(Slimpro) + ELSIF absAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sabspro) + ELSIF empAttr IN obj.conval.setval THEN DevCPM.SymWInt(Semppro) + ELSIF extAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sextpro) + ELSE DevCPM.SymWInt(Stpro) + END; + OutSign(obj.typ, obj.link); OutName(obj.name^); + DevCPM.SymWInt(obj.num) + ELSIF DevCPM.ExpHdTProc THEN + DevCPM.SymWInt(Shdtpro); + DevCPM.SymWInt(obj.num) + END + END; + OutTProcs(typ, obj.left); + OutTProcs(typ, obj.right) + END + END OutTProcs; + + PROCEDURE OutStr(typ: Struct); (* OPV.TypeAlloc already applied *) + VAR strobj: Object; + BEGIN + IF typ.ref < expCtxt.ref THEN DevCPM.SymWInt(-typ.ref) + ELSE + DevCPM.SymWInt(Sstruct); + typ.ref := expCtxt.ref; INC(expCtxt.ref); + IF expCtxt.ref >= maxStruct THEN err(228) END ; + OutMod(typ.mno); strobj := typ.strobj; + IF (strobj # NIL) & (strobj.name # null) THEN OutName(strobj.name^); + CASE strobj.history OF + | pbmodified: FPrintErr(strobj, 252) + | pvmodified: FPrintErr(strobj, 251) + | inconsistent: FPrintErr(strobj, 249) + ELSE (* checked in OutObj or correct indirect export *) + END + ELSE DevCPM.SymWCh(0X) (* anonymous => never inconsistent, pvfp influences the client fp *) + END; + IF typ.sysflag # 0 THEN (* !!! *) + DevCPM.SymWInt(Ssys); DevCPM.SymWInt(typ.sysflag); + IF typ.sysflag > 0 THEN portable := FALSE END + END; + IF strobj # NIL THEN + IF strobj.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(strobj.library^); portable := FALSE + END; + IF strobj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(strobj.entry^); portable := FALSE + END + END; + IF typ.ext # NIL THEN + DevCPM.SymWInt(String8); OutName(typ.ext^); portable := FALSE + END; + CASE typ.form OF + | Pointer: + DevCPM.SymWInt(Sptr); OutStr(typ.BaseTyp) + | ProcTyp: + DevCPM.SymWInt(Spro); OutSign(typ.BaseTyp, typ.link) + | Comp: + CASE typ.comp OF + | Array: + DevCPM.SymWInt(Sarr); OutStr(typ.BaseTyp); DevCPM.SymWInt(typ.n) + | DynArr: + DevCPM.SymWInt(Sdarr); OutStr(typ.BaseTyp) + | Record: + IF typ.attribute = limAttr THEN DevCPM.SymWInt(Slimrec) + ELSIF typ.attribute = absAttr THEN DevCPM.SymWInt(Sabsrec) + ELSIF typ.attribute = extAttr THEN DevCPM.SymWInt(Sextrec) + ELSE DevCPM.SymWInt(Srec) + END; + IF typ.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ.BaseTyp) END ; + (* BaseTyp should be Notyp, too late to change *) + DevCPM.SymWInt(typ.size); DevCPM.SymWInt(typ.align); DevCPM.SymWInt(typ.n); + nofhdfld := 0; OutFlds(typ.link, 0, TRUE); +(* + IF nofhdfld > DevCPM.MaxHdFld THEN DevCPM.Mark(223, typ.txtpos) END ; (* !!! *) +*) + OutTProcs(typ, typ.link); DevCPM.SymWInt(Send) + END + ELSE (* alias structure *) + DevCPM.SymWInt(Salias); OutStr(typ.BaseTyp) + END + END + END OutStr; + + PROCEDURE OutConstant(obj: Object); + VAR f, i: SHORTINT; rval: SHORTREAL; a, b, c: INTEGER; r: REAL; + BEGIN + f := obj.typ.form; +(* + IF obj.typ = guidtyp THEN f := Guid END; +*) + IF f = Int32 THEN + IF (obj.conval.intval >= -128) & (obj.conval.intval <= -127) THEN f := Int8 + ELSIF (obj.conval.intval >= -32768) & (obj.conval.intval <= -32767) THEN f := Int16 + END + END; + DevCPM.SymWInt(f); + CASE f OF + | Bool, Char8: + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval))) + | Char16: + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval MOD 256))); + DevCPM.SymWCh(SHORT(CHR(obj.conval.intval DIV 256))) + | Int8, Int16, Int32: + DevCPM.SymWInt(obj.conval.intval) + | Int64: + IF ABS(obj.conval.realval + obj.conval.intval) <= MAX(INTEGER) THEN + a := SHORT(ENTIER(obj.conval.realval + obj.conval.intval)); b := -1; c := -1 + ELSIF ABS(obj.conval.realval + obj.conval.intval) <= 1125899906842624.0 (*2^50*) THEN + a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 2097152.0 (*2^21*))); + b := SHORT(ENTIER(obj.conval.realval + obj.conval.intval - a * 2097152.0 (*2^21*))); c := -1 + ELSE + a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4398046511104.0 (*2^42*))); + r := obj.conval.realval + obj.conval.intval - a * 4398046511104.0 (*2^42*); + b := SHORT(ENTIER(r / 2097152.0 (*2^21*))); + c := SHORT(ENTIER(r - b * 2097152.0 (*2^21*))) + END; + IF c >= 0 THEN + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128; + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128; + DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))) + END; + IF b >= 0 THEN + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128; + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128; + DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))) + END; + DevCPM.SymWInt(a) + | Set: + DevCPM.SymWSet(obj.conval.setval) + | Real32: + rval := SHORT(obj.conval.realval); DevCPM.SymWReal(rval) + | Real64: + DevCPM.SymWLReal(obj.conval.realval) + | String8, String16: + OutName(obj.conval.ext^) + | NilTyp: +(* + | Guid: + i := 0; + WHILE i < 16 DO DevCPM.SymWCh(obj.conval.ext[i]); INC(i) END +*) + ELSE err(127) + END + END OutConstant; + + PROCEDURE OutObj(obj: Object); + VAR i, j: SHORTINT; ext: ConstExt; + BEGIN + IF obj # NIL THEN + OutObj(obj.left); + IF obj.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN + IF obj.history = removed THEN FPrintErr(obj, 250) + ELSIF obj.vis # internal THEN + CASE obj.history OF + | inserted: FPrintErr(obj, 253) + | same: (* ok *) + | pbmodified: + IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 252) END + | pvmodified: + IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 251) END + END ; + IF obj.sysflag < 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(obj.sysflag); portable := FALSE END; + IF obj.mode IN {LProc, XProc, CProc, Var, Con} THEN + (* name alias for types handled in OutStr *) + IF obj.library # NIL THEN + DevCPM.SymWInt(Slib); OutName(obj.library^); portable := FALSE + END; + IF obj.entry # NIL THEN + DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE + END + END; + CASE obj.mode OF + | Con: + OutConstant(obj); OutName(obj.name^) + | Typ: + IF obj.typ.strobj = obj THEN DevCPM.SymWInt(Stype); OutStr(obj.typ) + ELSE DevCPM.SymWInt(Salias); OutStr(obj.typ); OutName(obj.name^) + END + | Var: + IF obj.vis = externalR THEN DevCPM.SymWInt(Srvar) ELSE DevCPM.SymWInt(Svar) END ; + OutStr(obj.typ); OutName(obj.name^); + IF (obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null) THEN + (* compute fingerprint to avoid structural type equivalence *) + DevCPM.FPrint(expCtxt.reffp, obj.typ.ref) + END + | XProc: + DevCPM.SymWInt(Sxpro); OutSign(obj.typ, obj.link); OutName(obj.name^) + | IProc: + DevCPM.SymWInt(Sipro); OutSign(obj.typ, obj.link); OutName(obj.name^) + | CProc: + DevCPM.SymWInt(Scpro); OutSign(obj.typ, obj.link); ext := obj.conval.ext; + j := ORD(ext^[0]); i := 1; DevCPM.SymWInt(j); + WHILE i <= j DO DevCPM.SymWCh(ext^[i]); INC(i) END ; + OutName(obj.name^); portable := FALSE + END + END + END ; + OutObj(obj.right) + END + END OutObj; + + PROCEDURE Export*(VAR ext, new: BOOLEAN); + VAR i: SHORTINT; nofmod: BYTE; done: BOOLEAN; old: Object; oldCSum: INTEGER; + BEGIN + symExtended := FALSE; symNew := FALSE; nofmod := nofGmod; + Import("@self", SelfName, done); nofGmod := nofmod; + oldCSum := DevCPM.checksum; + ASSERT(GlbMod[0].name^ = SelfName); + IF DevCPM.noerr THEN (* ~DevCPM.noerr => ~done *) + DevCPM.NewSym(SelfName); + IF DevCPM.noerr THEN + DevCPM.SymWInt(0); (* portable symfile *) + DevCPM.checksum := 0; (* start checksum here to avoid problems with proc id fixup *) + DevCPM.SymWInt(actVersion); + old := GlbMod[0]; portable := TRUE; + IF libName # "" THEN + DevCPM.SymWInt(Slib); OutName(libName); portable := FALSE; + IF done & ((old.library = NIL) OR (old.library^ # libName)) THEN + FPrintErr(NIL, 252) + END + ELSIF done & (old.library # NIL) THEN FPrintErr(NIL, 252) + END; + DevCPM.SymWInt(Smname); OutName(SelfName); + expCtxt.reffp := 0; expCtxt.ref := FirstRef; + expCtxt.nofm := 1; expCtxt.locmno[0] := 0; + i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ; + OutObj(topScope.right); + ext := sfpresent & symExtended; + new := ~sfpresent OR symNew OR (DevCPM.checksum # oldCSum); + IF DevCPM.noerr & ~portable THEN + DevCPM.SymReset; + DevCPM.SymWInt(processor) (* nonportable symfile *) + END; + IF DevCPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN + new := TRUE + END ; + IF ~DevCPM.noerr THEN DevCPM.DeleteNewSym END + (* DevCPM.RegisterNewSym is called in OP2 after writing the object file *) + END + END + END Export; (* no new symbol file if ~DevCPM.noerr *) + + + PROCEDURE InitStruct(VAR typ: Struct; form: BYTE); + BEGIN + typ := NewStr(form, Basic); typ.ref := form; typ.size := 1; typ.allocated := TRUE; + typ.strobj := NewObj(); typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE; + typ.idfp := form; typ.idfpdone := TRUE + END InitStruct; + + PROCEDURE EnterBoolConst(name: Name; val: INTEGER); + VAR obj: Object; + BEGIN + Insert(name, obj); obj.conval := NewConst(); + obj.mode := Con; obj.typ := booltyp; obj.conval.intval := val + END EnterBoolConst; + + PROCEDURE EnterRealConst(name: Name; val: REAL; VAR obj: Object); + BEGIN + Insert(name, obj); obj.conval := NewConst(); + obj.mode := Con; obj.typ := real32typ; obj.conval.realval := val + END EnterRealConst; + + PROCEDURE EnterTyp(name: Name; form: BYTE; size: SHORTINT; VAR res: Struct); + VAR obj: Object; typ: Struct; + BEGIN + Insert(name, obj); + typ := NewStr(form, Basic); obj.mode := Typ; obj.typ := typ; obj.vis := external; + typ.strobj := obj; typ.size := size; typ.ref := form; typ.allocated := TRUE; + typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE; + typ.idfp := form; typ.idfpdone := TRUE; res := typ + END EnterTyp; + + PROCEDURE EnterProc(name: Name; num: SHORTINT); + VAR obj: Object; + BEGIN Insert(name, obj); + obj.mode := SProc; obj.typ := notyp; obj.adr := num + END EnterProc; + + PROCEDURE EnterAttr(name: Name; num: SHORTINT); + VAR obj: Object; + BEGIN Insert(name, obj); + obj.mode := Attr; obj.adr := num + END EnterAttr; + + PROCEDURE EnterTProc(ptr, rec: Struct; name: Name; num, typ: SHORTINT); + VAR obj, par: Object; + BEGIN + InsertField(name, rec, obj); + obj.mnolev := -128; (* for correct implement only behaviour *) + obj.mode := TProc; obj.num := num; obj.conval := NewConst(); + obj.conval.setval := obj.conval.setval + {newAttr}; + IF typ = 0 THEN (* FINALIZE, RELEASE *) + obj.typ := notyp; obj.vis := externalR; + INCL(obj.conval.setval, empAttr) + ELSIF typ = 1 THEN (* QueryInterface *) + par := NewObj(); par.name := NewName("int"); par.mode := VarPar; par.vis := outPar; + par.sysflag := 8; par.adr := 16; par.typ := punktyp; + par.link := obj.link; obj.link := par; + par := NewObj(); par.name := NewName("iid"); par.mode := VarPar; par.vis := inPar; + par.sysflag := 16; par.adr := 12; par.typ := guidtyp; + par.link := obj.link; obj.link := par; + obj.typ := restyp; obj.vis := external; + INCL(obj.conval.setval, extAttr) + ELSIF typ = 2 THEN (* AddRef, Release *) + obj.typ := notyp; obj.vis := externalR; + INCL(obj.conval.setval, isHidden); + INCL(obj.conval.setval, extAttr) + END; + par := NewObj(); par.name := NewName("this"); par.mode := Var; + par.adr := 8; par.typ := ptr; + par.link := obj.link; obj.link := par; + END EnterTProc; + + PROCEDURE EnterHdField(VAR root: Object; offs: SHORTINT); + VAR obj: Object; + BEGIN + obj := NewObj(); obj.mode := Fld; + obj.name := NewName(DevCPM.HdPtrName); obj.typ := undftyp; obj.adr := offs; + obj.link := root; root := obj + END EnterHdField; + +BEGIN + NEW(null, 1); null^ := ""; + topScope := NIL; OpenScope(0, NIL); DevCPM.errpos := 0; + InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp); + InitStruct(string8typ, String8); InitStruct(niltyp, NilTyp); niltyp.size := DevCPM.PointerSize; + InitStruct(string16typ, String16); + undftyp.BaseTyp := undftyp; + + (*initialization of module SYSTEM*) +(* + EnterTyp("BYTE", Byte, 1, bytetyp); + EnterProc("NEW", sysnewfn); +*) + EnterTyp("PTR", Pointer, DevCPM.PointerSize, sysptrtyp); + EnterProc("ADR", adrfn); + EnterProc("TYP", typfn); + EnterProc("CC", ccfn); + EnterProc("LSH", lshfn); + EnterProc("ROT", rotfn); + EnterProc("GET", getfn); + EnterProc("PUT", putfn); + EnterProc("GETREG", getrfn); + EnterProc("PUTREG", putrfn); + EnterProc("BIT", bitfn); + EnterProc("VAL", valfn); + EnterProc("MOVE", movefn); + EnterProc("THISRECORD", thisrecfn); + EnterProc("THISARRAY", thisarrfn); + syslink := topScope.right; topScope.right := NIL; + + (* initialization of module COM *) + EnterProc("ID", iidfn); + EnterProc("QUERY", queryfn); + EnterTyp("RESULT", Int32, 4, restyp); + restyp.ref := Res; + EnterTyp("GUID", Guid, 16, guidtyp); + guidtyp.form := Comp; guidtyp.comp := Array; guidtyp.n := 16; + EnterTyp("IUnknown^", IUnk, 12, iunktyp); + iunktyp.form := Comp; iunktyp.comp := Record; iunktyp.n := 3; + iunktyp.attribute := absAttr; +(* + EnterHdField(iunktyp.link, 12); +*) + iunktyp.BaseTyp := NIL; iunktyp.align := 4; + iunktyp.sysflag := interface; iunktyp.untagged := TRUE; + NEW(iunktyp.ext, 40); iunktyp.ext^ := "{00000000-0000-0000-C000-000000000046}"; + EnterTyp("IUnknown", PUnk, DevCPM.PointerSize, punktyp); + punktyp.form := Pointer; punktyp.BaseTyp := iunktyp; + punktyp.sysflag := interface; punktyp.untagged := TRUE; + EnterTProc(punktyp, iunktyp, "QueryInterface", 0, 1); + EnterTProc(punktyp, iunktyp, "AddRef", 1, 2); + EnterTProc(punktyp, iunktyp, "Release", 2, 2); + comlink := topScope.right; topScope.right := NIL; + + universe := topScope; + EnterProc("LCHR", lchrfn); + EnterProc("LENTIER", lentierfcn); + EnterTyp("ANYREC", AnyRec, 0, anytyp); + anytyp.form := Comp; anytyp.comp := Record; anytyp.n := 1; + anytyp.BaseTyp := NIL; anytyp.extlev := -1; (* !!! *) + anytyp.attribute := absAttr; + EnterTyp("ANYPTR", AnyPtr, DevCPM.PointerSize, anyptrtyp); + anyptrtyp.form := Pointer; anyptrtyp.BaseTyp := anytyp; + EnterTProc(anyptrtyp, anytyp, "FINALIZE", 0, 0); + EnterTProc(anyptrtyp, iunktyp, "RELEASE", 1, 0); + EnterProc("VALID", validfn); + + EnterTyp("SHORTCHAR", Char8, 1, char8typ); + string8typ.BaseTyp := char8typ; + EnterTyp("CHAR", Char16, 2, char16typ); + EnterTyp("LONGCHAR", Char16, 2, lchar16typ); + string16typ.BaseTyp := char16typ; + EnterTyp("SET", Set, 4, settyp); + EnterTyp("BYTE", Int8, 1, int8typ); + guidtyp.BaseTyp := int8typ; + EnterTyp("SHORTINT", Int16, 2, int16typ); + EnterTyp("INTEGER", Int32, 4, int32typ); + EnterTyp("LONGINT", Int64, 8, int64typ); + EnterTyp("LARGEINT", Int64, 8, lint64typ); + EnterTyp("SHORTREAL", Real32, 4, real32typ); + EnterTyp("REAL", Real64, 8, real64typ); + EnterTyp("LONGREAL", Real64, 8, lreal64typ); + EnterTyp("BOOLEAN", Bool, 1, booltyp); + EnterBoolConst("FALSE", 0); (* 0 and 1 are compiler internal representation only *) + EnterBoolConst("TRUE", 1); + EnterRealConst("INF", DevCPM.InfReal, infinity); + EnterProc("HALT", haltfn); + EnterProc("NEW", newfn); + EnterProc("ABS", absfn); + EnterProc("CAP", capfn); + EnterProc("ORD", ordfn); + EnterProc("ENTIER", entierfn); + EnterProc("ODD", oddfn); + EnterProc("MIN", minfn); + EnterProc("MAX", maxfn); + EnterProc("CHR", chrfn); + EnterProc("SHORT", shortfn); + EnterProc("LONG", longfn); + EnterProc("SIZE", sizefn); + EnterProc("INC", incfn); + EnterProc("DEC", decfn); + EnterProc("INCL", inclfn); + EnterProc("EXCL", exclfn); + EnterProc("LEN", lenfn); + EnterProc("COPY", copyfn); + EnterProc("ASH", ashfn); + EnterProc("ASSERT", assertfn); +(* + EnterProc("ADR", adrfn); + EnterProc("TYP", typfn); +*) + EnterProc("BITS", bitsfn); + EnterAttr("ABSTRACT", absAttr); + EnterAttr("LIMITED", limAttr); + EnterAttr("EMPTY", empAttr); + EnterAttr("EXTENSIBLE", extAttr); + NEW(intrealtyp); intrealtyp^ := real64typ^; + impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp; + impCtxt.ref[Bool] := booltyp; impCtxt.ref[Char8] := char8typ; + impCtxt.ref[Int8] := int8typ; impCtxt.ref[Int16] := int16typ; + impCtxt.ref[Int32] := int32typ; impCtxt.ref[Real32] := real32typ; + impCtxt.ref[Real64] := real64typ; impCtxt.ref[Set] := settyp; + impCtxt.ref[String8] := string8typ; impCtxt.ref[NilTyp] := niltyp; + impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp; + impCtxt.ref[AnyPtr] := anyptrtyp; impCtxt.ref[AnyRec] := anytyp; + impCtxt.ref[Char16] := char16typ; impCtxt.ref[String16] := string16typ; + impCtxt.ref[Int64] := int64typ; + impCtxt.ref[IUnk] := iunktyp; impCtxt.ref[PUnk] := punktyp; + impCtxt.ref[Guid] := guidtyp; impCtxt.ref[Res] := restyp; +END DevCPT. + +Objects: + + mode | adr conval link scope leaf + ------------------------------------------------ + Undef | Not used + Var | vadr next regopt Glob or loc var or proc value parameter + VarPar| vadr next regopt Var parameter (vis = 0 | inPar | outPar) + Con | val Constant + Fld | off next Record field + Typ | Named type + LProc | entry sizes firstpar scope leaf Local procedure, entry adr set in back-end + XProc | entry sizes firstpar scope leaf External procedure, entry adr set in back-end + SProc | fno sizes Standard procedure + CProc | code firstpar scope Code procedure + IProc | entry sizes scope leaf Interrupt procedure, entry adr set in back-end + Mod | scope Module + Head | txtpos owner firstvar Scope anchor + TProc | entry sizes firstpar scope leaf Bound procedure, mthno = obj.num + + Structures: + + form comp | n BaseTyp link mno txtpos sysflag + ---------------------------------------------------------------------------------- + Undef Basic | + Byte Basic | + Bool Basic | + Char8 Basic | + Int8 Basic | + Int16 Basic | + Int32 Basic | + Real32 Basic | + Real64 Basic | + Set Basic | + String8 Basic | + NilTyp Basic | + NoTyp Basic | + Pointer Basic | PBaseTyp mno txtpos sysflag + ProcTyp Basic | ResTyp params mno txtpos sysflag + Comp Array | nofel ElemTyp mno txtpos sysflag + Comp DynArr| dim ElemTyp mno txtpos sysflag + Comp Record| nofmth RBaseTyp fields mno txtpos sysflag + Char16 Basic | + String16Basic | + Int64 Basic | + +Nodes: + +design = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc. +expr = design|Nconst|Nupto|Nmop|Ndop|Ncall. +nextexpr = NIL|expr. +ifstat = NIL|Nif. +casestat = Ncaselse. +sglcase = NIL|Ncasedo. +stat = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat| + Nloop|Nexit|Nreturn|Nwith|Ntrap. + + + class subcl obj left right link + --------------------------------------------------------- + +design Nvar var nextexpr + Nvarpar varpar nextexpr + Nfield field design nextexpr + Nderef ptr/str design nextexpr + Nindex design expr nextexpr + Nguard design nextexpr (typ = guard type) + Neguard design nextexpr (typ = guard type) + Ntype type nextexpr + Nproc normal proc nextexpr + super proc nextexpr + + +expr design + Nconst const (val = node.conval) + Nupto expr expr nextexpr + Nmop not expr nextexpr + minus expr nextexpr + is tsttype expr nextexpr + conv expr nextexpr + abs expr nextexpr + cap expr nextexpr + odd expr nextexpr + bit expr nextexpr {x} + adr expr nextexpr SYSTEM.ADR + typ expr nextexpr SYSTEM.TYP + cc Nconst nextexpr SYSTEM.CC + val expr nextexpr SYSTEM.VAL + Ndop times expr expr nextexpr + slash expr expr nextexpr + div expr expr nextexpr + mod expr expr nextexpr + and expr expr nextexpr + plus expr expr nextexpr + minus expr expr nextexpr + or expr expr nextexpr + eql expr expr nextexpr + neq expr expr nextexpr + lss expr expr nextexpr + leq expr expr nextexpr + grt expr expr nextexpr + geq expr expr nextexpr + in expr expr nextexpr + ash expr expr nextexpr + msk expr Nconst nextexpr + len design Nconst nextexpr + min expr expr nextexpr MIN + max expr expr nextexpr MAX + bit expr expr nextexpr SYSTEM.BIT + lsh expr expr nextexpr SYSTEM.LSH + rot expr expr nextexpr SYSTEM.ROT + Ncall fpar design nextexpr nextexpr + Ncomp stat expr nextexpr + +nextexpr NIL + expr + +ifstat NIL + Nif expr stat ifstat + +casestat Ncaselse sglcase stat (minmax = node.conval) + +sglcase NIL + Ncasedo Nconst stat sglcase + +stat NIL + Ninittd stat (of node.typ) + Nenter proc stat stat stat (proc=NIL for mod) + Nassign assign design expr stat + newfn design nextexp stat + incfn design expr stat + decfn design expr stat + inclfn design expr stat + exclfn design expr stat + copyfn design expr stat + getfn design expr stat SYSTEM.GET + putfn expr expr stat SYSTEM.PUT + getrfn design Nconst stat SYSTEM.GETREG + putrfn Nconst expr stat SYSTEM.PUTREG + sysnewfn design expr stat SYSTEM.NEW + movefn expr expr stat SYSTEM.MOVE + (right.link = 3rd par) + Ncall fpar design nextexpr stat + Nifelse ifstat stat stat + Ncase expr casestat stat + Nwhile expr stat stat + Nrepeat stat expr stat + Nloop stat stat + Nexit stat + Nreturn proc nextexpr stat (proc = NIL for mod) + Nwith ifstat stat stat + Ntrap expr stat + Ncomp stat stat stat diff --git a/Trurl-based/Dev/Mod/CPV486.txt b/Trurl-based/Dev/Mod/CPV486.txt new file mode 100644 index 0000000..96851ea --- /dev/null +++ b/Trurl-based/Dev/Mod/CPV486.txt @@ -0,0 +1,1774 @@ +MODULE DevCPV486; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPV486.odc *) + (* DO NOT EDIT *) + + IMPORT SYSTEM, DevCPM, DevCPT, DevCPE, DevCPH, DevCPL486, DevCPC486; + + CONST + processor* = 10; (* for i386 *) + + (* object modes *) + Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; + SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; + + (* item modes for i386 *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + (*SYSTEM*) + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; + thisrecfn = 45; thisarrfn = 46; + shl = 50; shr = 51; lshr = 52; xor = 53; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + VString16to8 = 29; VString8 = 30; VString16 = 31; + realSet = {Real32, Real64}; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55; + + (*function number*) + assign = 0; newfn = 1; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; + + (*SYSTEM function number*) + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; + + (* COM function number *) + validfn = 40; queryfn = 42; + + (* procedure flags (conval.setval) *) + hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isHidden = 29; isGuarded = 30; isCallback = 31; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* case statement flags (conval.setval) *) + useTable = 1; useTree = 2; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; loaded = 24; + wreg = {AX, BX, CX, DX, SI, DI}; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* sysflag *) + untagged = 1; noAlign = 3; align2 = 4; align8 = 6; union = 7; + interface = 10; guarded = 8; noframe = 16; + nilBit = 1; enumBits = 8; new = 1; iid = 2; + stackArray = 120; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + ParOff = 8; + interfaceSize = 16; (* SIZE(Kernel.Interface) *) + addRefFP = 4E27A847H; (* fingerprint of AddRef and Release procedures *) + intHandlerFP = 24B0EAE3H; (* fingerprint of InterfaceTrapHandler *) + numPreIntProc = 2; + + + VAR + Exit, Return: DevCPL486.Label; + assert, sequential: BOOLEAN; + nesting, actual: INTEGER; + query, addRef, release, release2: DevCPT.Object; + + PROCEDURE Init*(opt: SET); + CONST ass = 2; + BEGIN + DevCPL486.Init(opt); DevCPC486.Init(opt); + assert := ass IN opt; + DevCPM.breakpc := MAX(INTEGER); + query := NIL; addRef := NIL; release := NIL; release2 := NIL; DevCPC486.intHandler := NIL; + END Init; + + PROCEDURE Close*; + BEGIN + DevCPL486.Close + END Close; + + PROCEDURE Align(VAR offset: INTEGER; align: INTEGER); + BEGIN + CASE align OF + 1: (* ok *) + | 2: INC(offset, offset MOD 2) + | 4: INC(offset, (-offset) MOD 4) + | 8: INC(offset, (-offset) MOD 8) + END + END Align; + + PROCEDURE NegAlign(VAR offset: INTEGER; align: INTEGER); + BEGIN + CASE align OF + 1: (* ok *) + | 2: DEC(offset, offset MOD 2) + | 4: DEC(offset, offset MOD 4) + | 8: DEC(offset, offset MOD 8) + END + END NegAlign; + + PROCEDURE Base(typ: DevCPT.Struct; limit: INTEGER): INTEGER; (* typ.comp # DynArr *) + VAR align: INTEGER; + BEGIN + WHILE typ.comp = Array DO typ := typ.BaseTyp END ; + IF typ.comp = Record THEN + align := typ.align + ELSE + align := typ.size; + END; + IF align > limit THEN RETURN limit ELSE RETURN align END + END Base; + +(* ----------------------------------------------------- + reference implementation of TypeSize for portable symbol files + mandatory for all non-system structures + + PROCEDURE TypeSize (typ: DevCPT.Struct); + VAR f, c: SHORTINT; offset: LONGINT; fld: DevCPT.Object; btyp: DevCPT.Struct; + BEGIN + IF typ.size = -1 THEN + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF btyp = NIL THEN offset := 0 ELSE TypeSize(btyp); offset := btyp.size END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + btyp := fld.typ; TypeSize(btyp); + IF btyp.size >= 4 THEN INC(offset, (-offset) MOD 4) + ELSIF btyp.size >= 2 THEN INC(offset, offset MOD 2) + END; + fld.adr := offset; INC(offset, btyp.size); + fld := fld.link + END; + IF offset > 2 THEN INC(offset, (-offset) MOD 4) END; + typ.size := offset; typ.align := 4; + typ.n := -1 (* methods not counted yet *) + ELSIF c = Array THEN + TypeSize(btyp); + typ.size := typ.n * btyp.size + ELSIF f = Pointer THEN + typ.size := DevCPM.PointerSize + ELSIF f = ProcTyp THEN + typ.size := DevCPM.ProcSize + ELSE (* c = DynArr *) + TypeSize(btyp); + IF btyp.comp = DynArr THEN typ.size := btyp.size + 4 + ELSE typ.size := 8 + END + END + END + END TypeSize; + +----------------------------------------------------- *) + + PROCEDURE GTypeSize (typ: DevCPT.Struct; guarded: BOOLEAN); + VAR f, c: BYTE; offset, align, falign, alignLimit: INTEGER; + fld: DevCPT.Object; btyp: DevCPT.Struct; name: DevCPT.Name; + BEGIN + IF typ.untagged THEN guarded := TRUE END; + IF typ = DevCPT.undftyp THEN DevCPM.err(58) + ELSIF typ.size = -1 THEN + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF btyp = NIL THEN offset := 0; align := 1; + ELSE GTypeSize(btyp, guarded); offset := btyp.size; align := btyp.align + END ; + IF typ.sysflag = noAlign THEN alignLimit := 1 + ELSIF typ.sysflag = align2 THEN alignLimit := 2 + ELSIF typ.sysflag = align8 THEN alignLimit := 8 + ELSE alignLimit := 4 + END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + btyp := fld.typ; GTypeSize(btyp, guarded); + IF typ.sysflag > 0 THEN falign := Base(btyp, alignLimit) + ELSIF btyp.size >= 4 THEN falign := 4 + ELSIF btyp.size >= 2 THEN falign := 2 + ELSE falign := 1 + END; + IF typ.sysflag = union THEN + fld.adr := 0; + IF btyp.size > offset THEN offset := btyp.size END; + ELSE + Align(offset, falign); + fld.adr := offset; + IF offset <= MAX(INTEGER) - 4 - btyp.size THEN INC(offset, btyp.size) + ELSE offset := 4; DevCPM.Mark(214, typ.txtpos) + END + END; + IF falign > align THEN align := falign END ; + fld := fld.link + END; +(* + IF (typ.sysflag = interface) & (typ.BaseTyp = NIL) THEN + fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld; + fld.typ := DevCPT.undftyp; fld.adr := 8; + fld.right := typ.link; typ.link := fld; + fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld; + fld.typ := DevCPT.undftyp; fld.adr := 12; + typ.link.link := fld; typ.link.left := fld; + offset := interfaceSize; align := 4 + END; +*) + IF typ.sysflag <= 0 THEN align := 4 END; + typ.align := align; + IF (typ.sysflag > 0) OR (offset > 2) THEN Align(offset, align) END; + typ.size := offset; + typ.n := -1 (* methods not counted yet *) + ELSIF c = Array THEN + GTypeSize(btyp, guarded); + IF (btyp.size = 0) OR (typ.n <= MAX(INTEGER) DIV btyp.size) THEN typ.size := typ.n * btyp.size + ELSE typ.size := 4; DevCPM.Mark(214, typ.txtpos) + END + ELSIF f = Pointer THEN + typ.size := DevCPM.PointerSize; + IF guarded & ~typ.untagged THEN DevCPM.Mark(143, typ.txtpos) END + ELSIF f = ProcTyp THEN + typ.size := DevCPM.ProcSize + ELSE (* c = DynArr *) + GTypeSize(btyp, guarded); + IF (typ.sysflag = untagged) OR typ.untagged THEN typ.size := 4 + ELSE + IF btyp.comp = DynArr THEN typ.size := btyp.size + 4 + ELSE typ.size := 8 + END + END + END + END + END GTypeSize; + + PROCEDURE TypeSize*(typ: DevCPT.Struct); (* also called from DevCPT.InStruct for arrays *) + BEGIN + GTypeSize(typ, FALSE) + END TypeSize; + + PROCEDURE GetComKernel; + VAR name: DevCPT.Name; mod: DevCPT.Object; + BEGIN + IF addRef = NIL THEN + DevCPT.OpenScope(SHORT(SHORT(-DevCPT.nofGmod)), NIL); + DevCPT.topScope.name := DevCPT.NewName("$$"); + name := "AddRef"; DevCPT.Insert(name, addRef); + addRef.mode := XProc; + addRef.fprint := addRefFP; + addRef.fpdone := TRUE; + name := "Release"; DevCPT.Insert(name, release); + release.mode := XProc; + release.fprint := addRefFP; + release.fpdone := TRUE; + name := "Release2"; DevCPT.Insert(name, release2); + release2.mode := XProc; + release2.fprint := addRefFP; + release2.fpdone := TRUE; + name := "InterfaceTrapHandler"; DevCPT.Insert(name, DevCPC486.intHandler); + DevCPC486.intHandler.mode := XProc; + DevCPC486.intHandler.fprint := intHandlerFP; + DevCPC486.intHandler.fpdone := TRUE; + DevCPT.GlbMod[DevCPT.nofGmod] := DevCPT.topScope; + INC(DevCPT.nofGmod); + DevCPT.CloseScope; + END + END GetComKernel; + + PROCEDURE EnumTProcs(rec: DevCPT.Struct); (* method numbers in declaration order *) + VAR btyp: DevCPT.Struct; obj, redef: DevCPT.Object; + BEGIN + IF rec.n = -1 THEN + rec.n := 0; btyp := rec.BaseTyp; + IF btyp # NIL THEN + EnumTProcs(btyp); rec.n := btyp.n; + END; + obj := rec.strobj.link; + WHILE obj # NIL DO + DevCPT.FindBaseField(obj.name^, rec, redef); + IF redef # NIL THEN obj.num := redef.num (*mthno*); + IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN + DevCPM.Mark(119, rec.txtpos) + END + ELSE obj.num := rec.n; INC(rec.n) + END ; + IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END; + obj := obj.nlink + END + END + END EnumTProcs; + + PROCEDURE CountTProcs(rec: DevCPT.Struct); + VAR btyp: DevCPT.Struct; comProc: INTEGER; m, rel: DevCPT.Object; name: DevCPT.Name; + + PROCEDURE TProcs(obj: DevCPT.Object); (* obj.mnolev = 0, TProcs of base type already counted *) + VAR redef: DevCPT.Object; + BEGIN + IF obj # NIL THEN + TProcs(obj.left); + IF obj.mode = TProc THEN + DevCPT.FindBaseField(obj.name^, rec, redef); + (* obj.adr := 0 *) + IF redef # NIL THEN + obj.num := redef.num (*mthno*); + IF (redef.link # NIL) & (redef.link.typ.sysflag = interface) THEN + obj.num := numPreIntProc + comProc - 1 - obj.num + END; + IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN + DevCPM.Mark(119, rec.txtpos) + END + ELSE obj.num := rec.n; INC(rec.n) + END ; + IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END + END ; + TProcs(obj.right) + END + END TProcs; + + BEGIN + IF rec.n = -1 THEN + comProc := 0; + IF rec.untagged THEN rec.n := 0 ELSE rec.n := DevCPT.anytyp.n END; + btyp := rec.BaseTyp; + IF btyp # NIL THEN + IF btyp.sysflag = interface THEN + EnumTProcs(btyp); rec.n := btyp.n + numPreIntProc; comProc := btyp.n; + ELSE + CountTProcs(btyp); rec.n := btyp.n + END + END; + WHILE (btyp # NIL) & (btyp # DevCPT.undftyp) & (btyp.sysflag # interface) DO btyp := btyp.BaseTyp END; + IF (btyp # NIL) & (btyp.sysflag = interface) THEN + IF comProc > 0 THEN + name := "QueryInterface"; DevCPT.FindField(name, rec, m); + IF m.link.typ.sysflag = interface THEN + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.typ := rec; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, extAttr}; + m.nlink := query; query := m + END; + name := "AddRef"; + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr}; + GetComKernel; addRef.used := TRUE; m.adr := -1; m.nlink := addRef; + END; + name := "RELEASE"; + DevCPT.FindField(name, rec, rel); + IF (rel # NIL) & (rel.link.typ = DevCPT.anyptrtyp) THEN rel := NIL END; + IF (comProc > 0) OR (rel # NIL) THEN + name := "Release"; + DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0; + m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr}; + GetComKernel; m.adr := -1; + IF rel # NIL THEN release2.used := TRUE; m.nlink := release2 + ELSE release.used := TRUE; m.nlink := release + END + END + END; + TProcs(rec.link); + END + END CountTProcs; + + PROCEDURE ^Parameters(firstPar, proc: DevCPT.Object); + + PROCEDURE ^TProcedures(obj: DevCPT.Object); + + PROCEDURE TypeAlloc(typ: DevCPT.Struct); + VAR f, c: SHORTINT; fld: DevCPT.Object; btyp: DevCPT.Struct; + BEGIN + IF ~typ.allocated THEN (* not imported, not predefined, not allocated yet *) + typ.allocated := TRUE; + TypeSize(typ); + f := typ.form; c := typ.comp; btyp := typ.BaseTyp; + IF c = Record THEN + IF typ.sysflag = interface THEN + EnumTProcs(typ); + ELSE + CountTProcs(typ) + END; + IF typ.extlev > 14 THEN DevCPM.Mark(233, typ.txtpos) END; + IF btyp # NIL THEN TypeAlloc(btyp) END; + IF ~typ.untagged THEN DevCPE.AllocTypDesc(typ) END; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + TypeAlloc(fld.typ); fld := fld.link + END; + TProcedures(typ.link) + ELSIF f = Pointer THEN + IF btyp = DevCPT.undftyp THEN DevCPM.Mark(128, typ.txtpos) + ELSE TypeAlloc(btyp); + END + ELSIF f = ProcTyp THEN + TypeAlloc(btyp); + Parameters(typ.link, NIL) + ELSE (* c IN {Array, DynArr} *) + TypeAlloc(btyp); + IF (btyp.comp = DynArr) & btyp.untagged & ~typ.untagged THEN DevCPM.Mark(225, typ.txtpos) END; + END + END + END TypeAlloc; + + PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER; + BEGIN + WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END; + IF typ # NIL THEN RETURN typ.n + ELSE RETURN 0 + END + END NumOfIntProc; + + PROCEDURE Parameters(firstPar, proc: DevCPT.Object); + (* firstPar.mnolev = 0 *) + VAR par: DevCPT.Object; typ: DevCPT.Struct; padr, vadr: INTEGER; + BEGIN + padr := ParOff; par := firstPar; + WHILE par # NIL DO + typ := par.typ; TypeAlloc(typ); + par.adr := padr; + IF (par.mode = VarPar) & (typ.comp # DynArr) THEN + IF (typ.comp = Record) & ~typ.untagged THEN INC(padr, 8) + ELSE INC(padr, 4) + END + ELSE + IF (par.mode = Var) & (typ.comp = DynArr) & typ.untagged THEN DevCPM.err(145) END; + INC(padr, typ.size); Align(padr, 4) + END; + par := par.link + END; + IF proc # NIL THEN + IF proc.mode = XProc THEN + INCL(proc.conval.setval, isCallback) + ELSIF (proc.mode = TProc) + & (proc.num >= numPreIntProc) + & (proc.num < numPreIntProc + NumOfIntProc(proc.link.typ)) + THEN + INCL(proc.conval.setval, isCallback); + INCL(proc.conval.setval, isGuarded) + END; + IF proc.sysflag = guarded THEN INCL(proc.conval.setval, isGuarded) END; + IF isGuarded IN proc.conval.setval THEN + GetComKernel; vadr := -24 + ELSE + vadr := 0; + IF imVar IN proc.conval.setval THEN DEC(vadr, 4) END; + IF isCallback IN proc.conval.setval THEN DEC(vadr, 8) END + END; + proc.conval.intval := padr; proc.conval.intval2 := vadr; + END + END Parameters; + + PROCEDURE Variables(var: DevCPT.Object; VAR varSize: INTEGER); + (* allocates only offsets, regs allocated in DevCPC486.Enter *) + VAR adr: INTEGER; typ: DevCPT.Struct; + BEGIN + adr := varSize; + WHILE var # NIL DO + typ := var.typ; TypeAlloc(typ); + DEC(adr, typ.size); NegAlign(adr, Base(typ, 4)); + var.adr := adr; + var := var.link + END; + NegAlign(adr, 4); varSize := adr + END Variables; + + PROCEDURE ^Objects(obj: DevCPT.Object); + + PROCEDURE Procedure(obj: DevCPT.Object); + (* obj.mnolev = 0 *) + VAR oldPos: INTEGER; + BEGIN + oldPos := DevCPM.errpos; DevCPM.errpos := obj.scope.adr; + TypeAlloc(obj.typ); + Parameters(obj.link, obj); + IF ~(hasBody IN obj.conval.setval) THEN DevCPM.Mark(129, obj.adr) END ; + Variables(obj.scope.scope, obj.conval.intval2); (* local variables *) + Objects(obj.scope.right); + DevCPM.errpos := oldPos + END Procedure; + + PROCEDURE TProcedures(obj: DevCPT.Object); + (* obj.mnolev = 0 *) + VAR par: DevCPT.Object; psize: INTEGER; + BEGIN + IF obj # NIL THEN + TProcedures(obj.left); + IF (obj.mode = TProc) & (obj.scope # NIL) THEN + TypeAlloc(obj.typ); + Parameters(obj.link, obj); + Variables(obj.scope.scope, obj.conval.intval2); (* local variables *) + Objects(obj.scope.right); + END ; + TProcedures(obj.right) + END + END TProcedures; + + PROCEDURE Objects(obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + Objects(obj.left); + IF obj.mode IN {Con, Typ, LProc, XProc, CProc, IProc} THEN + IF (obj.mode IN {Con, Typ}) THEN TypeAlloc(obj.typ); + ELSE Procedure(obj) + END + END ; + Objects(obj.right) + END + END Objects; + + PROCEDURE Allocate*; + VAR gvarSize: INTEGER; name: DevCPT.Name; + BEGIN + DevCPM.errpos := DevCPT.topScope.adr; (* text position of scope used if error *) + gvarSize := 0; + Variables(DevCPT.topScope.scope, gvarSize); DevCPE.dsize := -gvarSize; + Objects(DevCPT.topScope.right) + END Allocate; + + (************************) + + PROCEDURE SameExp (n1, n2: DevCPT.Node): BOOLEAN; + BEGIN + WHILE (n1.class = n2.class) & (n1.typ = n2.typ) DO + CASE n1.class OF + | Nvar, Nvarpar, Nproc: RETURN n1.obj = n2.obj + | Nconst: RETURN (n1.typ.form IN {Int8..Int32}) & (n1.conval.intval = n2.conval.intval) + | Nfield: IF n1.obj # n2.obj THEN RETURN FALSE END + | Nderef, Nguard: + | Nindex: IF ~SameExp(n1.right, n2.right) THEN RETURN FALSE END + | Nmop: IF (n1.subcl # n2.subcl) OR (n1.subcl = is) THEN RETURN FALSE END + | Ndop: IF (n1.subcl # n2.subcl) OR ~SameExp(n1.right, n2.right) THEN RETURN FALSE END + ELSE RETURN FALSE + END ; + n1 := n1.left; n2 := n2.left + END; + RETURN FALSE + END SameExp; + + PROCEDURE Check (n: DevCPT.Node; VAR used: SET; VAR size: INTEGER); + VAR ux, uy: SET; sx, sy, sf: INTEGER; f: BYTE; + BEGIN + used := {}; size := 0; + WHILE n # NIL DO + IF n.class # Ncomp THEN + Check(n.left, ux, sx); + Check(n.right, uy, sy) + END; + ux := ux + uy; sf := 0; + CASE n.class OF + | Nvar, Nvarpar: + IF (n.class = Nvarpar) OR (n.typ.comp = DynArr) OR + (n.obj.mnolev > 0) & + (DevCPC486.imLevel[n.obj.mnolev] < DevCPC486.imLevel[DevCPL486.level]) THEN sf := 1 END + | Nguard: sf := 2 + | Neguard, Nderef: sf := 1 + | Nindex: + IF (n.right.class # Nconst) OR (n.left.typ.comp = DynArr) THEN sf := 1 END; + IF sx > 0 THEN INC(sy) END + | Nmop: + CASE n.subcl OF + | is, adr, typfn, minus, abs, cap, val: sf := 1 + | bit: sf := 2; INCL(ux, CX) + | conv: + IF n.typ.form = Int64 THEN sf := 2 + ELSIF ~(n.typ.form IN realSet) THEN sf := 1; + IF n.left.typ.form IN realSet THEN INCL(ux, AX) END + END + | odd, cc, not: + END + | Ndop: + f := n.left.typ.form; + IF f # Bool THEN + CASE n.subcl OF + | times: + sf := 1; + IF f = Int8 THEN INCL(ux, AX) END + | div, mod: + sf := 3; INCL(ux, AX); + IF f > Int8 THEN INCL(ux, DX) END + | eql..geq: + IF f IN {String8, String16, Comp} THEN ux := ux + {AX, CX, SI, DI}; sf := 4 + ELSIF f IN realSet THEN INCL(ux, AX); sf := 1 + ELSE sf := 1 + END + | ash, lsh, rot: + IF n.right.class = Nconst THEN sf := 1 ELSE sf := 2; INCL(ux, CX) END + | slash, plus, minus, msk, in, bit: + sf := 1 + | len: + IF f IN {String8, String16} THEN ux := ux + {AX, CX, DI}; sf := 3 + ELSE sf := 1 + END + | min, max: + sf := 1; + IF f IN realSet THEN INCL(ux, AX) END + | queryfn: + ux := ux + {CX, SI, DI}; sf := 4 + END; + IF sy > sx THEN INC(sx) ELSE INC(sy) END + END + | Nupto: + IF (n.right.class = Nconst) OR (n.left.class = Nconst) THEN sf := 2 + ELSE sf := 3 + END; + INCL(ux, CX); INC(sx) + | Ncall, Ncomp: + sf := 10; ux := wreg + {float} + | Nfield, Nconst, Nproc, Ntype: + END; + used := used + ux; + IF sx > size THEN size := sx END; + IF sy > size THEN size := sy END; + IF sf > size THEN size := sf END; + n := n.link + END; + IF size > 10 THEN size := 10 END + END Check; + + PROCEDURE^ expr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + + PROCEDURE DualExp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; hx, hy, stpx, stpy: SET); + VAR ux, uy: SET; sx, sy: INTEGER; + BEGIN + Check(left, ux, sx); Check(right, uy, sy); + IF sy > sx THEN + expr(right, y, hy + stpy, ux + stpy * {AX, CX}); + expr(left, x, hx, stpx); + DevCPC486.Assert(y, hy, stpy) + ELSE + expr(left, x, hx + stpx, uy); + expr(right, y, hy, stpy); + DevCPC486.Assert(x, hx, stpx) + END; + END DualExp; + + PROCEDURE IntDOp (n: DevCPT.Node; VAR x: DevCPL486.Item; hint: SET); + VAR y: DevCPL486.Item; rev: BOOLEAN; + BEGIN + DualExp(n.left, n.right, x, y, hint, hint, {stk}, {stk}); + IF (x.mode = Reg) & DevCPC486.Fits(x, hint) THEN + DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF (y.mode = Reg) & DevCPC486.Fits(y, hint) THEN + DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSIF x.mode # Reg THEN + DevCPC486.Load(x, hint, {con}); DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF y.mode # Reg THEN + DevCPC486.Load(y, hint, {con}); DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSE + DevCPC486.IntDOp(x, y, n.subcl, FALSE) + END + END IntDOp; + + PROCEDURE FloatDOp (n: DevCPT.Node; VAR x: DevCPL486.Item); + VAR y: DevCPL486.Item; ux, uy, uf: SET; sx, sy: INTEGER; + BEGIN + Check(n.left, ux, sx); Check(n.right, uy, sy); + IF (n.subcl = min) OR (n.subcl = max) THEN uf := {AX} ELSE uf := {} END; + IF (sy > sx) OR (sy = sx) & ((n.subcl = mod) OR (n.subcl = ash)) THEN + expr(n.right, x, {}, ux + {mem, stk}); + expr(n.left, y, {}, uf); + DevCPC486.FloatDOp(x, y, n.subcl, TRUE) + ELSIF float IN uy THEN (* function calls in both operands *) + expr(n.left, y, {}, uy + {mem}); + expr(n.right, x, {}, {mem, stk}); + DevCPC486.FloatDOp(x, y, n.subcl, TRUE) + ELSE + expr(n.left, x, {}, uy + {mem, stk}); + expr(n.right, y, {}, uf); + DevCPC486.FloatDOp(x, y, n.subcl, FALSE) + END + END FloatDOp; + + PROCEDURE design (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + VAR obj: DevCPT.Object; y: DevCPL486.Item; ux, uy: SET; sx, sy: INTEGER; + BEGIN + CASE n.class OF + Nvar, Nvarpar: + obj := n.obj; x.mode := obj.mode; x.obj := obj; x.scale := 0; + IF obj.typ.comp = DynArr THEN x.mode := VarPar END; + IF obj.mnolev < 0 THEN x.offset := 0; x.tmode := Con + ELSIF x.mode = Var THEN x.offset := obj.adr; x.tmode := Con + ELSE x.offset := 0; x.tmode := VarPar + END + | Nfield: + design(n.left, x, hint, stop); DevCPC486.Field(x, n.obj) + | Nderef: + IF n.subcl # 0 THEN + expr(n.left, x, hint, stop); + IF n.typ.form = String8 THEN x.form := VString8 ELSE x.form := VString16 END + ELSE + expr(n.left, x, hint, stop + {mem} - {loaded}); DevCPC486.DeRef(x) + END + | Nindex: + Check(n.left, ux, sx); Check(n.right, uy, sy); + IF wreg - uy = {} THEN + expr(n.right, y, hint + stop, ux); + design(n.left, x, hint, stop); + IF x.scale # 0 THEN DevCPC486.Index(x, y, {}, {}) ELSE DevCPC486.Index(x, y, hint, stop) END + ELSE + design(n.left, x, hint, stop + uy); + IF x.scale # 0 THEN expr(n.right, y, {}, {}); DevCPC486.Index(x, y, {}, {}) + ELSE expr(n.right, y, hint, stop); DevCPC486.Index(x, y, hint, stop) + END + END + | Nguard, Neguard: + IF n.typ.form = Pointer THEN + IF loaded IN stop THEN expr(n.left, x, hint, stop) ELSE expr(n.left, x, hint, stop + {mem}) END + ELSE design(n.left, x, hint, stop) + END; + DevCPC486.TypTest(x, n.typ, TRUE, n.class = Neguard) + | Nproc: + obj := n.obj; x.mode := obj.mode; x.obj := obj; + IF x.mode = TProc THEN x.offset := obj.num; (*mthno*) x.scale := n.subcl (* super *) END + END; + x.typ := n.typ + END design; + + PROCEDURE IsAllocDynArr (x: DevCPT.Node): BOOLEAN; + BEGIN + IF (x.typ.comp = DynArr) & ~x.typ.untagged THEN + WHILE x.class = Nindex DO x := x.left END; + IF x.class = Nderef THEN RETURN TRUE END + END; + RETURN FALSE + END IsAllocDynArr; + + PROCEDURE StringOp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; useLen: BOOLEAN); + VAR ax, ay: DevCPL486.Item; ux: SET; sx: INTEGER; + BEGIN + Check(left, ux, sx); + expr(right, y, wreg - {SI} + ux, {}); + ay := y; DevCPC486.GetAdr(ay, wreg - {SI} + ux, {}); DevCPC486.Assert(ay, wreg - {SI}, ux); + IF useLen & IsAllocDynArr(left) THEN (* keep len descriptor *) + design(left, x, wreg - {CX}, {loaded}); + DevCPC486.Prepare(x, wreg - {CX} + {deref}, {DI}) + ELSE + expr(left, x, wreg - {DI}, {}) + END; + ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI} + {stk, con}); + DevCPC486.Load(ay, {}, wreg - {SI} + {con}); + DevCPC486.Free(ax); DevCPC486.Free(ay) + END StringOp; + + PROCEDURE AdrExpr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + BEGIN + IF n.class < Nconst THEN + design(n, x, hint + stop, {loaded}); DevCPC486.Prepare(x, hint + {deref}, stop) + ELSE expr(n, x, hint, stop) + END + END AdrExpr; + + (* ---------- interface pointer reference counting ---------- *) + + PROCEDURE HandleIPtrs (typ: DevCPT.Struct; VAR x, y: DevCPL486.Item; add, rel, init: BOOLEAN); + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF (typ.form = Pointer) & (typ.sysflag = interface) THEN + IF add THEN DevCPC486.IPAddRef(y, adr, TRUE) END; + IF rel THEN DevCPC486.IPRelease(x, adr, TRUE, init) END + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) THEN + IF add THEN DevCPC486.IPAddRef(y, fld.adr + adr, TRUE) END; + IF rel THEN DevCPC486.IPRelease(x, fld.adr + adr, TRUE, init) END + ELSE FindPtrs(fld.typ, fld.adr + adr) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF DevCPC486.ContainsIPtrs(btyp) THEN + i := 0; + WHILE i < n DO FindPtrs(btyp, adr); INC(adr, btyp.size); INC(i) END + END + ELSIF typ.comp = DynArr THEN + IF DevCPC486.ContainsIPtrs(typ) THEN DevCPM.err(221) END + END + END FindPtrs; + + BEGIN + FindPtrs(typ, 0) + END HandleIPtrs; + + PROCEDURE CountedPtr (n: DevCPT.Node): BOOLEAN; + BEGIN + RETURN (n.typ.form = Pointer) & (n.typ.sysflag = interface) + & ((n.class = Ncall) OR (n.class = Ncomp) & (n.right.class = Ncall)) + END CountedPtr; + + PROCEDURE IPAssign (nx, ny: DevCPT.Node; VAR x, y: DevCPL486.Item; ux: SET); + (* nx.typ.form = Pointer & nx.typ.sysflag = interface *) + BEGIN + expr(ny, y, {}, wreg - {SI} + {mem, stk}); + IF (ny.class # Nconst) & ~CountedPtr(ny) THEN + DevCPC486.IPAddRef(y, 0, TRUE) + END; + IF nx # NIL THEN + DevCPC486.Assert(y, {}, wreg - {SI} + ux); + expr(nx, x, wreg - {DI}, {loaded}); + IF (x.mode = Ind) & (x.reg IN wreg - {SI, DI}) OR (x.scale # 0) THEN + DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + x.mode := Ind; x.offset := 0; x.scale := 0 + END; + DevCPC486.IPRelease(x, 0, TRUE, FALSE); + END + END IPAssign; + + PROCEDURE IPStructAssign (typ: DevCPT.Struct); + VAR x, y: DevCPL486.Item; + BEGIN + IF typ.comp = DynArr THEN DevCPM.err(270) END; + (* addresses in SI and DI *) + x.mode := Ind; x.reg := DI; x.offset := 0; x.scale := 0; + y.mode := Ind; y.reg := SI; y.offset := 0; y.scale := 0; + HandleIPtrs(typ, x, y, TRUE, TRUE, FALSE) + END IPStructAssign; + + PROCEDURE IPFree (nx: DevCPT.Node; VAR x: DevCPL486.Item); + BEGIN + expr(nx, x, wreg - {DI}, {loaded}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + x.mode := Ind; x.offset := 0; x.scale := 0; + IF nx.typ.form = Comp THEN + HandleIPtrs(nx.typ, x, x, FALSE, TRUE, TRUE) + ELSE (* nx.typ.form = Pointer & nx.typ.sysflag = interface *) + DevCPC486.IPRelease(x, 0, TRUE, TRUE); + END + END IPFree; + + (* unchanged val parameters allways counted because of aliasing problems REMOVED! *) + + PROCEDURE InitializeIPVars (proc: DevCPT.Object); + VAR x: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = Var) & obj.used THEN (* changed value parameters *) + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, TRUE, FALSE, FALSE) + END; + obj := obj.link + END + END InitializeIPVars; + + PROCEDURE ReleaseIPVars (proc: DevCPT.Object); + VAR x, ax, dx, si, di: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + obj := proc.link; + WHILE (obj # NIL) & ((obj.mode # Var) OR ~obj.used OR ~DevCPC486.ContainsIPtrs(obj.typ)) DO + obj := obj.link + END; + IF obj = NIL THEN + obj := proc.scope.scope; + WHILE (obj # NIL) & ~DevCPC486.ContainsIPtrs(obj.typ) DO obj := obj.link END; + IF obj = NIL THEN RETURN END + END; + DevCPL486.MakeReg(ax, AX, Int32); DevCPL486.MakeReg(si, SI, Int32); + DevCPL486.MakeReg(dx, DX, Int32); DevCPL486.MakeReg(di, DI, Int32); + IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(ax, si) END; + IF proc.typ.form = Int64 THEN DevCPL486.GenMove(dx, di) END; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = Var) & obj.used THEN (* value parameters *) + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE) + END; + obj := obj.link + END; + obj := proc.scope.scope; + WHILE obj # NIL DO (* local variables *) + IF obj.used THEN + x.offset := obj.adr; + HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE); + END; + obj := obj.link + END; + IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(si, ax) END; + IF proc.typ.form = Int64 THEN DevCPL486.GenMove(di, dx) END + END ReleaseIPVars; + + PROCEDURE CompareIntTypes ( + typ: DevCPT.Struct; VAR id: DevCPL486.Item; VAR exit: DevCPL486.Label; VAR num: INTEGER + ); + VAR x, y: DevCPL486.Item; local: DevCPL486.Label; + BEGIN + local := DevCPL486.NewLbl; + typ := typ.BaseTyp; num := 0; + WHILE (typ # NIL) & (typ # DevCPT.undftyp) DO + IF (typ.sysflag = interface) & (typ.ext # NIL) THEN + IF num > 0 THEN DevCPC486.JumpT(x, local) END; + DevCPC486.GuidFromString(typ.ext, y); + x := id; DevCPC486.GetAdr(x, wreg - {SI}, {mem}); + x := y; DevCPC486.GetAdr(x, wreg - {DI}, {}); + x := id; DevCPC486.CmpString(x, y, eql, FALSE); + INC(num) + END; + typ := typ.BaseTyp + END; + IF num > 0 THEN DevCPC486.JumpF(x, exit) END; + IF num > 1 THEN DevCPL486.SetLabel(local) END + END CompareIntTypes; + + PROCEDURE InstallQueryInterface (typ: DevCPT.Struct; proc: DevCPT.Object); + VAR this, id, int, unk, c: DevCPL486.Item; nil, end: DevCPL486.Label; num: INTEGER; + BEGIN + nil := DevCPL486.NewLbl; end := DevCPL486.NewLbl; + this.mode := Ind; this.reg := BP; this.offset := 8; this.scale := 0; this.form := Pointer; this.typ := DevCPT.anyptrtyp; + id.mode := DInd; id.reg := BP; id.offset := 12; id.scale := 0; id.form := Pointer; + int.mode := DInd; int.reg := BP; int.offset := 16; int.scale := 0; int.form := Pointer; + DevCPC486.GetAdr(int, {}, {AX, CX, SI, DI, mem}); int.mode := Ind; int.offset := 0; + DevCPL486.MakeConst(c, 0, Pointer); DevCPC486.Assign(int, c); + unk.mode := Ind; unk.reg := BP; unk.offset := 8; unk.scale := 0; unk.form := Pointer; unk.typ := DevCPT.punktyp; + DevCPC486.Load(unk, {}, {}); + unk.mode := Ind; unk.offset := 8; + DevCPC486.Load(unk, {}, {}); + DevCPL486.GenComp(c, unk); + DevCPL486.GenJump(4, nil, TRUE); + DevCPL486.MakeReg(c, int.reg, Pointer); + DevCPL486.GenPush(c); + c.mode := Ind; c.reg := BP; c.offset := 12; c.scale := 0; c.form := Pointer; + DevCPL486.GenPush(c); + DevCPL486.GenPush(unk); + c.mode := Ind; c.reg := unk.reg; c.offset := 0; c.scale := 0; c.form := Pointer; + DevCPL486.GenMove(c, unk); + unk.mode := Ind; unk.offset := 0; unk.scale := 0; unk.form := Pointer; + DevCPL486.GenCall(unk); + DevCPC486.Free(unk); + DevCPL486.GenJump(-1, end, FALSE); + DevCPL486.SetLabel(nil); + DevCPL486.MakeConst(c, 80004002H, Int32); (* E_NOINTERFACE *) + DevCPC486.Result(proc, c); + CompareIntTypes(typ, id, end, num); + IF num > 0 THEN + DevCPC486.Load(this, {}, {}); + DevCPC486.Assign(int, this); + DevCPC486.IPAddRef(this, 0, FALSE); + DevCPL486.MakeConst(c, 0, Int32); (* S_OK *) + DevCPC486.Result(proc, c); + END; + DevCPL486.SetLabel(end) + END InstallQueryInterface; + + (* -------------------- *) + + PROCEDURE ActualPar (n: DevCPT.Node; fp: DevCPT.Object; rec: BOOLEAN; VAR tag: DevCPL486.Item); + VAR ap: DevCPL486.Item; x: DevCPT.Node; niltest: BOOLEAN; + BEGIN + IF n # NIL THEN + ActualPar(n.link, fp.link, FALSE, ap); + niltest := FALSE; + IF fp.mode = VarPar THEN + IF (n.class = Ndop) & ((n.subcl = thisarrfn) OR (n.subcl = thisrecfn)) THEN + expr(n.right, ap, {}, {}); DevCPC486.Push(ap); (* push type/length *) + expr(n.left, ap, {}, {}); DevCPC486.Push(ap); (* push adr *) + RETURN + ELSIF (fp.vis = outPar) & DevCPC486.ContainsIPtrs(fp.typ) & (ap.typ # DevCPT.niltyp) THEN + IPFree(n, ap) + ELSE + x := n; + WHILE (x.class = Nfield) OR (x.class = Nindex) DO x := x.left END; + niltest := x.class = Nderef; (* explicit nil test needed *) + AdrExpr(n, ap, {}, {}) + END + ELSIF (n.class = Nmop) & (n.subcl = conv) THEN + IF n.typ.form IN {String8, String16} THEN expr(n, ap, {}, {}); DevCPM.err(265) + ELSIF (DevCPT.Includes(n.typ.form, n.left.typ.form) OR DevCPT.Includes(n.typ.form, fp.typ.form)) + & (n.typ.form # Set) & (fp.typ # DevCPT.bytetyp) THEN expr(n.left, ap, {}, {high}); + ELSE expr(n, ap, {}, {high}); + END + ELSE expr(n, ap, {}, {high}); + IF CountedPtr(n) THEN DevCPM.err(270) END + END; + DevCPC486.Param(fp, rec, niltest, ap, tag) + END + END ActualPar; + + PROCEDURE Call (n: DevCPT.Node; VAR x: DevCPL486.Item); + VAR tag: DevCPL486.Item; proc: DevCPT.Object; m: BYTE; + BEGIN + IF n.left.class = Nproc THEN + proc := n.left.obj; m := proc.mode; + ELSE proc := NIL; m := 0 + END; + IF (m = CProc) & (n.right # NIL) THEN + ActualPar(n.right.link, n.obj.link, FALSE, tag); + expr(n.right, tag, wreg - {AX}, {}); (* tag = first param *) + ELSE + IF proc # NIL THEN DevCPC486.PrepCall(proc) END; + ActualPar(n.right, n.obj, (m = TProc) & (n.left.subcl = 0), tag); + END; + IF proc # NIL THEN design(n.left, x, {}, {}) ELSE expr(n.left, x, {}, {}) END; + DevCPC486.Call(x, tag) + END Call; + + PROCEDURE Mem (n: DevCPT.Node; VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET); + VAR offset: INTEGER; + BEGIN + IF (n.class = Ndop) & (n.subcl IN {plus, minus}) & (n.right.class = Nconst) THEN + expr(n.left, x, hint, stop + {mem}); offset := n.right.conval.intval; + IF n.subcl = minus THEN offset := -offset END + ELSE + expr(n, x, hint, stop + {mem}); offset := 0 + END; + DevCPC486.Mem(x, offset, typ) + END Mem; + + PROCEDURE^ CompStat (n: DevCPT.Node); + PROCEDURE^ CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item); + + PROCEDURE condition (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR false, true: DevCPL486.Label); + VAR local: DevCPL486.Label; y, z: DevCPL486.Item; ux: SET; sx, num: INTEGER; f: BYTE; typ: DevCPT.Struct; + BEGIN + IF n.class = Nmop THEN + CASE n.subcl OF + not: condition(n.left, x, true, false); DevCPC486.Not(x) + | is: IF n.left.typ.form = Pointer THEN expr(n.left, x, {}, {mem}) + ELSE design(n.left, x, {}, {}) + END; + DevCPC486.TypTest(x, n.obj.typ, FALSE, FALSE) + | odd: expr(n.left, x, {}, {}); DevCPC486.Odd(x) + | cc: expr(n.left, x, {}, {}); x.mode := Cond; x.form := Bool + | val: DevCPM.err(220) + END + ELSIF n.class = Ndop THEN + CASE n.subcl OF + and: local := DevCPL486.NewLbl; condition(n.left, y, false, local); + DevCPC486.JumpF(y, false); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + condition(n.right, x, false, true) + | or: local := DevCPL486.NewLbl; condition(n.left, y, local, true); + DevCPC486.JumpT(y, true); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + condition(n.right, x, false, true) + | eql..geq: + f := n.left.typ.form; + IF f = Int64 THEN DevCPM.err(260) + ELSIF f IN {String8, String16, Comp} THEN + IF (n.left.class = Nmop) & (n.left.subcl = conv) THEN (* converted must be source *) + StringOp(n.right, n.left, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, TRUE) + ELSE + StringOp(n.left, n.right, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, FALSE) + END + ELSIF f IN {Real32, Real64} THEN FloatDOp(n, x) + ELSE + IF CountedPtr(n.left) OR CountedPtr(n.right) THEN DevCPM.err(270) END; + DualExp(n.left, n.right, x, y, {}, {}, {stk}, {stk}); + IF (x.mode = Reg) OR (y.mode = Con) THEN DevCPC486.IntDOp(x, y, n.subcl, FALSE) + ELSIF (y.mode = Reg) OR (x.mode = Con) THEN DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y + ELSE DevCPC486.Load(x, {}, {}); DevCPC486.IntDOp(x, y, n.subcl, FALSE) + END + END + | in: DualExp(n.left, n.right, x, y, {}, {}, {short, mem, stk}, {con, stk}); + DevCPC486.In(x, y) + | bit: Check(n.left, ux, sx); + expr(n.right, x, {}, ux + {short}); + Mem(n.left, y, DevCPT.notyp, {}, {}); + DevCPC486.Load(x, {}, {short}); + DevCPC486.In(x, y) + | queryfn: + AdrExpr(n.right, x, {}, {CX, SI, DI}); + CompareIntTypes(n.left.typ, x, false, num); + IF num > 0 THEN + Check(n.right.link, ux, sx); IPAssign(n.right.link, n.left, x, y, ux); DevCPC486.Assign(x, y); + x.offset := 1 (* true *) + ELSE x.offset := 0 (* false *) + END; + x.mode := Con; DevCPC486.MakeCond(x) + END + ELSIF n.class = Ncomp THEN + CompStat(n.left); condition(n.right, x, false, true); CompRelease(n.left, x); + IF x.mode = Stk THEN DevCPL486.GenCode(9DH); (* pop flags *) x.mode := Cond END + ELSE expr(n, x, {}, {}); DevCPC486.MakeCond(x) (* const, var, or call *) + END + END condition; + + PROCEDURE expr(n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET); + VAR y, z: DevCPL486.Item; f, g: BYTE; cval: DevCPT.Const; false, true: DevCPL486.Label; + uy: SET; sy: INTEGER; r: REAL; + BEGIN + f := n.typ.form; + IF (f = Bool) & (n.class IN {Ndop, Nmop}) THEN + false := DevCPL486.NewLbl; true := DevCPL486.NewLbl; + condition(n, y, false, true); + DevCPC486.LoadCond(x, y, false, true, hint, stop + {mem}) + ELSE + CASE n.class OF + Nconst: + IF n.obj = NIL THEN cval := n.conval ELSE cval := n.obj.conval END; + CASE f OF + Byte..Int32, NilTyp, Pointer, Char16: DevCPL486.MakeConst(x, cval.intval, f) + | Int64: + DevCPL486.MakeConst(x, cval.intval, f); + DevCPE.GetLongWords(cval, x.scale, x.offset) + | Set: DevCPL486.MakeConst(x, SYSTEM.VAL(INTEGER, cval.setval), Set) + | String8, String16, Real32, Real64: DevCPL486.AllocConst(x, cval, f) + | Comp: + ASSERT(n.typ = DevCPT.guidtyp); + IF n.conval # NIL THEN DevCPC486.GuidFromString(n.conval.ext, x) + ELSE DevCPC486.GuidFromString(n.obj.typ.ext, x) + END + END + | Nupto: (* n.typ = DevCPT.settyp *) + Check(n.right, uy, sy); + expr(n.left, x, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(x, TRUE, FALSE, hint + stop + uy, {}); + DevCPC486.Assert(x, {}, uy); + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(y, TRUE, TRUE, hint + stop, {}); + DevCPC486.Load(x, hint + stop, {}); + IF x.mode = Con THEN DevCPC486.IntDOp(y, x, msk, TRUE); x := y + ELSE DevCPC486.IntDOp(x, y, msk, FALSE) + END + | Nmop: + CASE n.subcl OF + | bit: + expr(n.left, x, {}, wreg - {CX} + {high, mem, stk}); + DevCPC486.MakeSet(x, FALSE, FALSE, hint + stop, {}) + | conv: + IF f IN {String8, String16} THEN + expr(n.left, x, hint, stop); + IF f = String8 THEN x.form := VString16to8 END (* SHORT *) + ELSE + IF n.left.class = Nconst THEN (* largeint -> longreal *) + ASSERT((n.left.typ.form = Int64) & (f = Real64)); + DevCPL486.AllocConst(x, n.left.conval, n.left.typ.form); + ELSE + expr(n.left, x, hint + stop, {high}); + END; + DevCPC486.Convert(x, f, -1, hint + stop, {}) (* ??? *) + END + | val: + expr(n.left, x, hint + stop, {high, con}); DevCPC486.Convert(x, f, n.typ.size, hint, stop) (* ??? *) + | adr: + IF n.left.class = Ntype THEN + x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ; + ELSE + AdrExpr(n.left, x, hint + stop, {}); + END; + DevCPC486.GetAdr(x, hint + stop, {}) + | typfn: + IF n.left.class = Ntype THEN + x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ; + IF x.obj.typ.untagged THEN DevCPM.err(111) END + ELSE + expr(n.left, x, hint + stop, {}); + DevCPC486.Tag(x, y); DevCPC486.Free(x); x := y + END; + DevCPC486.Load(x, hint + stop, {}) + | minus, abs, cap: + expr(n.left, x, hint + stop, {mem, stk}); + IF f = Int64 THEN DevCPM.err(260) + ELSIF f IN realSet THEN DevCPC486.FloatMOp(x, n.subcl) + ELSE DevCPC486.IntMOp(x, n.subcl) + END + END + | Ndop: + IF (f IN realSet) & (n.subcl # lsh) & (n.subcl # rot) THEN + IF (n.subcl = ash) & (n.right.class = Nconst) & (n.right.conval.realval >= 0) THEN + expr(n.left, x, {}, {mem, stk}); + cval := n.right.conval; sy := SHORT(ENTIER(cval.realval)); cval.realval := 1; + WHILE sy > 0 DO cval.realval := cval.realval * 2; DEC(sy) END; + DevCPL486.AllocConst(y, cval, Real32); + DevCPC486.FloatDOp(x, y, times, FALSE) + ELSE FloatDOp(n, x) + END + ELSIF (f = Int64) OR (n.typ = DevCPT.intrealtyp) THEN DevCPM.err(260); expr(n.left, x, {}, {}) + ELSE + CASE n.subcl OF + times: + IF f = Int8 THEN + DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, con, stk}); + DevCPC486.IntDOp(x, y, times, FALSE) + ELSE IntDOp(n, x, hint + stop) + END + | div, mod: + DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, DX, mem, stk}); + DevCPC486.DivMod(x, y, n.subcl = mod) + | plus: + IF n.typ.form IN {String8, String16} THEN DevCPM.err(265); expr(n.left, x, {}, {}) + ELSE IntDOp(n, x, hint + stop) + END + | slash, minus, msk, min, max: + IntDOp(n, x, hint + stop) + | ash, lsh, rot: + uy := {}; IF n.right.class # Nconst THEN uy := {CX} END; + DualExp(n^.right, n^.left, y, x, {}, hint + stop, wreg - {CX} + {high, mem, stk}, uy + {con, mem, stk}); + DevCPC486.Shift(x, y, n^.subcl) + | len: + IF n.left.typ.form IN {String8, String16} THEN + expr(n.left, x, wreg - {DI} , {}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con}); + DevCPC486.StrLen(x, n.left.typ, FALSE) + ELSE + design(n.left, x, hint + stop, {}); expr(n.right, y, {}, {}); DevCPC486.Len(x, y) + END + END + END + | Ncall: + Call(n, x) + | Ncomp: + CompStat(n.left); expr(n.right, x, hint, stop); CompRelease(n.left, x); + IF x.mode = Stk THEN DevCPC486.Pop(x, x.form, hint, stop) END + ELSE + design(n, x, hint + stop, stop * {loaded}); DevCPC486.Prepare(x, hint + stop, {}) (* ??? *) + END + END; + x.typ := n.typ; + DevCPC486.Assert(x, hint, stop) + END expr; + + PROCEDURE AddCopy (n: DevCPT.Node; VAR dest, dadr, len: DevCPL486.Item; last: BOOLEAN); + VAR adr, src: DevCPL486.Item; u: SET; s: INTEGER; + BEGIN + Check(n, u, s); + DevCPC486.Assert(dadr, wreg - {DI}, u + {SI, CX}); + IF len.mode # Con THEN DevCPC486.Assert(len, wreg - {CX}, u + {SI, DI}) END; + expr(n, src, wreg - {SI}, {}); + adr := src; DevCPC486.GetAdr(adr, {}, wreg - {SI} + {con}); + IF len.mode # Con THEN DevCPC486.Load(len, {}, wreg - {CX} + {con}) END; + DevCPC486.Load(dadr, {}, wreg - {DI} + {con}); + DevCPC486.AddCopy(dest, src, last) + END AddCopy; + + PROCEDURE StringCopy (left, right: DevCPT.Node); + VAR x, y, ax, ay, len: DevCPL486.Item; + BEGIN + IF IsAllocDynArr(left) THEN expr(left, x, wreg - {CX}, {DI}) (* keep len descriptor *) + ELSE expr(left, x, wreg - {DI}, {}) + END; + ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI}); + DevCPC486.Free(x); DevCPC486.ArrayLen(x, len, wreg - {CX}, {}); + WHILE right.class = Ndop DO + ASSERT(right.subcl = plus); + AddCopy(right.left, x, ax, len, FALSE); + right := right.right + END; + AddCopy(right, x, ax, len, TRUE); + DevCPC486.Free(len) + END StringCopy; + + PROCEDURE Checkpc; + BEGIN + DevCPE.OutSourceRef(DevCPM.errpos) + END Checkpc; + + PROCEDURE^ stat (n: DevCPT.Node; VAR end: DevCPL486.Label); + + PROCEDURE CondStat (if, last: DevCPT.Node; VAR hint: INTEGER; VAR else, end: DevCPL486.Label); + VAR local: DevCPL486.Label; x: DevCPL486.Item; cond, lcond: DevCPT.Node; + BEGIN + local := DevCPL486.NewLbl; + DevCPM.errpos := if.conval.intval; Checkpc; cond := if.left; + IF (last # NIL) & (cond.class = Ndop) & (cond.subcl >= eql) & (cond.subcl <= geq) + & (last.class = Ndop) & (last.subcl >= eql) & (last.subcl <= geq) + & SameExp(cond.left, last.left) & SameExp(cond.right, last.right) THEN (* reuse comparison *) + DevCPC486.setCC(x, cond.subcl, ODD(hint), hint >= 2) + ELSIF (last # NIL) & (cond.class = Nmop) & (cond.subcl = is) & (last.class = Nmop) & (last.subcl = is) + & SameExp(cond.left, last.left) THEN + DevCPC486.ShortTypTest(x, cond.obj.typ) (* !!! *) + ELSE condition(cond, x, else, local) + END; + hint := x.reg; + DevCPC486.JumpF(x, else); + IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END; + stat(if.right, end); + END CondStat; + + PROCEDURE IfStat (n: DevCPT.Node; withtrap: BOOLEAN; VAR end: DevCPL486.Label); + VAR else, local: DevCPL486.Label; if, last: DevCPT.Node; hint: INTEGER; + BEGIN (* n.class = Nifelse *) + if := n.left; last := NIL; + WHILE (if # NIL) & ((if.link # NIL) OR (n.right # NIL) OR withtrap) DO + else := DevCPL486.NewLbl; + CondStat(if, last, hint, else, end); + IF sequential THEN DevCPC486.Jump(end) END; + DevCPL486.SetLabel(else); last := if.left; if := if.link + END; + IF n.right # NIL THEN stat(n.right, end) + ELSIF withtrap THEN DevCPM.errpos := n.conval.intval; Checkpc; DevCPC486.Trap(withTrap); sequential := FALSE + ELSE CondStat(if, last, hint, end, end) + END + END IfStat; + + PROCEDURE CasePart (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR else: DevCPL486.Label; last: BOOLEAN); + VAR this, higher: DevCPL486.Label; m: DevCPT.Node; low, high: INTEGER; + BEGIN + IF n # NIL THEN + this := SHORT(ENTIER(n.conval.realval)); + IF useTree IN n.conval.setval THEN + IF n.left # NIL THEN + IF n.right # NIL THEN + higher := DevCPL486.NewLbl; + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, higher, TRUE, FALSE); + CasePart(n.left, x, else, FALSE); + DevCPL486.SetLabel(higher); + CasePart(n.right, x, else, last) + ELSE + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, FALSE); + CasePart(n.left, x, else, last); + END + ELSE + DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, TRUE); + IF n.right # NIL THEN CasePart(n.right, x, else, last) + ELSIF ~last THEN DevCPC486.Jump(else) + END + END + ELSE + IF useTable IN n.conval.setval THEN + m := n; WHILE m.left # NIL DO m := m.left END; low := m.conval.intval; + m := n; WHILE m.right # NIL DO m := m.right END; high := m.conval.intval2; + DevCPC486.CaseTableJump(x, low, high, else); + actual := low; last := TRUE + END; + CasePart(n.left, x, else, FALSE); + WHILE actual < n.conval.intval DO + DevCPL486.GenCaseEntry(else, FALSE); INC(actual) + END; + WHILE actual < n.conval.intval2 DO + DevCPL486.GenCaseEntry(this, FALSE); INC(actual) + END; + DevCPL486.GenCaseEntry(this, last & (n.right = NIL)); INC(actual); + CasePart(n.right, x, else, last) + END; + n.conval.realval := this + END + END CasePart; + + PROCEDURE CaseStat (n: DevCPT.Node; VAR end: DevCPL486.Label); + VAR x: DevCPL486.Item; case, lab: DevCPT.Node; low, high, tab: INTEGER; else, this: DevCPL486.Label; + BEGIN + expr(n.left, x, {}, {mem, con, short, float, stk}); else := DevCPL486.NewLbl; + IF (n.right.right # NIL) & (n.right.right.class = Ngoto) THEN (* jump to goto optimization *) + CasePart(n.right.link, x, else, FALSE); DevCPC486.Free(x); + n.right.right.right.conval.intval2 := else; sequential := FALSE + ELSE + CasePart(n.right.link, x, else, TRUE); DevCPC486.Free(x); + DevCPL486.SetLabel(else); + IF n.right.conval.setval # {} THEN stat(n.right.right, end) + ELSE DevCPC486.Trap(caseTrap); sequential := FALSE + END + END; + case := n.right.left; + WHILE case # NIL DO (* case.class = Ncasedo *) + IF sequential THEN DevCPC486.Jump(end) END; + lab := case.left; + IF (case.right # NIL) & (case.right.class = Ngoto) THEN (* jump to goto optimization *) + case.right.right.conval.intval2 := SHORT(ENTIER(lab.conval.realval)); + ASSERT(lab.link = NIL); sequential := FALSE + ELSE + WHILE lab # NIL DO + this := SHORT(ENTIER(lab.conval.realval)); DevCPL486.SetLabel(this); lab := lab.link + END; + stat(case.right, end) + END; + case := case.link + END + END CaseStat; + + PROCEDURE Dim(n: DevCPT.Node; VAR x, nofel: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); + VAR len: DevCPL486.Item; u: SET; s: INTEGER; + BEGIN + Check(n, u, s); + IF (nofel.mode = Reg) & (nofel.reg IN u) THEN DevCPC486.Push(nofel) END; + expr(n, len, {}, {mem, short}); + IF nofel.mode = Stk THEN DevCPC486.Pop(nofel, Int32, {}, {}) END; + IF len.mode = Stk THEN DevCPC486.Pop(len, Int32, {}, {}) END; + DevCPC486.MulDim(len, nofel, fact, dimtyp); + IF n.link # NIL THEN + Dim(n.link, x, nofel, fact, dimtyp.BaseTyp); + ELSE + DevCPC486.New(x, nofel, fact) + END; + DevCPC486.SetDim(x, len, dimtyp) + END Dim; + + PROCEDURE CompStat (n: DevCPT.Node); + VAR x, y, sp, old, len, nofel: DevCPL486.Item; fact: INTEGER; typ: DevCPT.Struct; + BEGIN + Checkpc; + WHILE (n # NIL) & DevCPM.noerr DO + ASSERT(n.class = Nassign); + IF n.subcl = assign THEN + IF n.right.typ.form IN {String8, String16} THEN + StringCopy(n.left, n.right) + ELSE + IF (n.left.typ.sysflag = interface) & ~CountedPtr(n.right) THEN + IPAssign(NIL, n.right, x, y, {}); (* no Release *) + ELSE expr(n.right, y, {}, {}) + END; + expr(n.left, x, {}, {}); + DevCPC486.Assign(x, y) + END + ELSE ASSERT(n.subcl = newfn); + typ := n.left.typ.BaseTyp; + ASSERT(typ.comp = DynArr); + ASSERT(n.right.link = NIL); + expr(n.right, y, {}, wreg - {CX} + {mem, stk}); + DevCPL486.MakeReg(sp, SP, Int32); + DevCPC486.CopyReg(sp, old, {}, {CX}); + DevCPC486.CopyReg(y, len, {}, {CX}); + IF typ.BaseTyp.form = Char16 THEN + DevCPL486.MakeConst(x, 2, Int32); DevCPL486.GenMul(x, y, FALSE) + END; + DevCPC486.StackAlloc; + DevCPC486.Free(y); + expr(n.left, x, {}, {}); DevCPC486.Assign(x, sp); + DevCPC486.Push(len); + DevCPC486.Push(old); + typ.sysflag := stackArray + END; + n := n.link + END + END CompStat; + + PROCEDURE CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item); + VAR x, y, sp: DevCPL486.Item; + BEGIN + IF n.link # NIL THEN CompRelease(n.link, res) END; + ASSERT(n.class = Nassign); + IF n.subcl = assign THEN + IF (n.left.typ.form = Pointer) & (n.left.typ.sysflag = interface) THEN + IF res.mode = Cond THEN + DevCPL486.GenCode(9CH); (* push flags *) + res.mode := Stk + ELSIF res.mode = Reg THEN + IF res.form < Int16 THEN DevCPC486.Push(res) + ELSE DevCPC486.Assert(res, {}, {AX, CX, DX}) + END + END; + expr(n.left, x, wreg - {DI}, {loaded}); + DevCPC486.IPRelease(x, 0, TRUE, TRUE); + n.left.obj.used := FALSE + END + ELSE ASSERT(n.subcl = newfn); + DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenPop(sp); + DevCPL486.MakeConst(y, 0, Pointer); + expr(n.left, x, {}, {}); DevCPC486.Assign(x, y) + END + END CompRelease; + + PROCEDURE Assign(n: DevCPT.Node; ux: SET); + VAR r: DevCPT.Node; f: BYTE; false, true: DevCPL486.Label; x, y, z: DevCPL486.Item; uf, uy: SET; s: INTEGER; + BEGIN + r := n.right; f := r.typ.form; uf := {}; + IF (r.class IN {Nmop, Ndop}) THEN + IF (r.subcl = conv) & (f # Set) & +(* + (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) THEN r := r.left; + IF ~(f IN realSet) & (r.typ.form IN realSet) & (r.typ # DevCPT.intrealtyp) THEN uf := {AX} END (* entier *) +*) + (DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) & + ((f IN realSet) OR ~(r.left.typ.form IN realSet)) THEN r := r.left + ELSIF (f IN {Char8..Int32, Set, Char16, String8, String16}) & SameExp(n.left, r.left) THEN + IF r.class = Ndop THEN + IF (r.subcl IN {slash, plus, minus, msk}) OR (r.subcl = times) & (f = Set) THEN + expr(r.right, y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, r.subcl, FALSE); + RETURN + ELSIF r.subcl IN {ash, lsh, rot} THEN + expr(r.right, y, wreg - {CX} + {high, mem}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, wreg - {CX} + {high}); DevCPC486.Shift(x, y, r.subcl); + RETURN + END + ELSE + IF r.subcl IN {minus, abs, cap} THEN + expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, r.subcl); RETURN + END + END + ELSIF f = Bool THEN + IF (r.subcl = not) & SameExp(n.left, r.left) THEN + expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, not); RETURN + END + END + END; + IF (n.left.typ.sysflag = interface) & (n.left.typ.form = Pointer) THEN IPAssign(n.left, r, x, y, ux) + ELSE expr(r, y, {high}, ux); expr(n.left, x, {}, uf + {loaded}); (* high ??? *) + END; + DevCPC486.Assign(x, y) + END Assign; + + PROCEDURE stat (n: DevCPT.Node; VAR end: DevCPL486.Label); + VAR x, y, nofel: DevCPL486.Item; local, next, loop, prevExit: DevCPL486.Label; fact, sx, sz: INTEGER; ux, uz: SET; + BEGIN + sequential := TRUE; INC(nesting); + WHILE (n # NIL) & DevCPM.noerr DO + IF n.link = NIL THEN next := end ELSE next := DevCPL486.NewLbl END; + DevCPM.errpos := n.conval.intval; DevCPL486.BegStat; + CASE n.class OF + | Ninittd: + (* done at load-time *) + | Nassign: + Checkpc; + Check(n.left, ux, sx); + CASE n.subcl OF + assign: + IF n.left.typ.form = Comp THEN + IF (n.right.class = Ndop) & (n.right.typ.form IN {String8, String16}) THEN + StringCopy(n.left, n.right) + ELSE + StringOp(n.left, n.right, x, y, TRUE); + IF DevCPC486.ContainsIPtrs(n.left.typ) THEN IPStructAssign(n.left.typ) END; + DevCPC486.Copy(x, y, FALSE) + END + ELSE Assign(n, ux) + END + | getfn: + Mem(n.right, y, n.left.typ, {}, ux); + expr(n.left, x, {}, {loaded}); + DevCPC486.Assign(x, y) + | putfn: + expr(n.right, y, {}, ux); + Mem(n.left, x, n.right.typ, {}, {}); + DevCPC486.Assign(x, y) + | incfn, decfn: + expr(n.right, y, {}, ux); expr(n.left, x, {}, {}); + IF n.left.typ.form = Int64 THEN + DevCPC486.LargeInc(x, y, n.subcl = decfn) + ELSE + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, SHORT(SHORT(plus - incfn + n.subcl)), FALSE) + END + | inclfn: + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, FALSE, ux, {}); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, plus, FALSE) + | exclfn: + expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, TRUE, ux, {}); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); + DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, times, FALSE) + | getrfn: + expr(n.right, y, {}, {}); + IF y.offset < 8 THEN + DevCPL486.MakeReg(y, y.offset, n.left.typ.form); (* ??? *) + expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y) + ELSE DevCPM.err(220) + END + | putrfn: + expr(n.left, x, {}, {}); + IF x.offset < 8 THEN + DevCPL486.MakeReg(x, x.offset, n.right.typ.form); (* ??? *) + expr(n.right, y, wreg - {x.reg}, {}); DevCPC486.Assign(x, y) + ELSE DevCPM.err(220) + END + | newfn: + y.typ := n.left.typ; + IF n.right # NIL THEN + IF y.typ.BaseTyp.comp = Record THEN + expr(n.right, nofel, {}, {AX, CX, DX, mem, stk}); + DevCPC486.New(y, nofel, 1); + ELSE (*open array*) + nofel.mode := Con; nofel.form := Int32; fact := 1; + Dim(n.right, y, nofel, fact, y.typ.BaseTyp) + END + ELSE + DevCPL486.MakeConst(nofel, 0, Int32); + DevCPC486.New(y, nofel, 1); + END; + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y) + | sysnewfn: + expr(n.right, y, {}, {mem, short}); DevCPC486.SysNew(y); + DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); DevCPC486.Assign(x, y) + | copyfn: + StringOp(n.left, n.right, x, y, TRUE); + DevCPC486.Copy(x, y, TRUE) + | movefn: + Check(n.right.link, uz, sz); + expr(n.right, y, {}, wreg - {SI} + {short} + ux + uz); + expr(n.left, x, {}, wreg - {DI} + {short} + uz); + expr(n.right.link, nofel, {}, wreg - {CX} + {mem, stk, short}); + DevCPC486.Load(x, {}, wreg - {DI} + {con}); + DevCPC486.Load(y, {}, wreg - {SI} + {con}); + DevCPC486.SysMove(nofel) + END; + sequential := TRUE + | Ncall: + Checkpc; + Call(n, x); sequential := TRUE + | Nifelse: + IF (n.subcl # assertfn) OR assert THEN IfStat(n, FALSE, next) END + | Ncase: + Checkpc; + CaseStat(n, next) + | Nwhile: + local := DevCPL486.NewLbl; + IF n.right # NIL THEN DevCPC486.Jump(local) END; + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); + stat(n.right, local); DevCPL486.SetLabel(local); + DevCPM.errpos := n.conval.intval; Checkpc; + condition(n.left, x, next, loop); DevCPC486.JumpT(x, loop); sequential := TRUE + | Nrepeat: + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); + local := DevCPL486.NewLbl; stat(n.left, local); DevCPL486.SetLabel(local); + DevCPM.errpos := n.conval.intval; Checkpc; + condition(n.right, x, loop, next); DevCPC486.JumpF(x, loop); sequential := TRUE + | Nloop: + prevExit := Exit; Exit := next; + loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); stat(n.left, loop); + IF sequential THEN DevCPC486.Jump(loop) END; + next := Exit; Exit := prevExit; sequential := FALSE + | Nexit: + Checkpc; + DevCPC486.Jump(Exit); sequential := FALSE + | Nreturn: + IF n.left # NIL THEN + Checkpc; + IF (n.obj.typ.sysflag = interface) & (n.obj.typ.form = Pointer) + & (n.left.class # Nconst) & ~CountedPtr(n.left) THEN IPAssign(NIL, n.left, y, x, {}) + ELSE expr(n.left, x, wreg - {AX}, {}) + END; + DevCPC486.Result(n.obj, x) + END; + IF (nesting > 1) OR (n.link # NIL) THEN DevCPC486.Jump(Return) END; + sequential := FALSE + | Nwith: + IfStat(n, n.subcl = 0, next) + | Ntrap: + Checkpc; + DevCPC486.Trap(n.right.conval.intval); sequential := TRUE + | Ncomp: + CompStat(n.left); stat(n.right, next); x.mode := 0; CompRelease(n.left, x) + | Ndrop: + Checkpc; + expr(n.left, x, {}, {}); DevCPC486.Free(x) + | Ngoto: + IF n.left # NIL THEN + Checkpc; + condition(n.left, x, next, n.right.conval.intval2); + DevCPC486.JumpT(x, n.right.conval.intval2) + ELSE + DevCPC486.Jump(n.right.conval.intval2); + sequential := FALSE + END + | Njsr: + DevCPL486.GenJump(-3, n.right.conval.intval2, FALSE) (* call n.right *) + | Nret: + DevCPL486.GenReturn(0); sequential := FALSE (* ret 0 *) + | Nlabel: + DevCPL486.SetLabel(n.conval.intval2) + END; + DevCPC486.CheckReg; DevCPL486.EndStat; n := n.link; + IF n = NIL THEN end := next + ELSIF next # DevCPL486.NewLbl THEN DevCPL486.SetLabel(next) + END + END; + DEC(nesting) + END stat; + + PROCEDURE CheckFpu (n: DevCPT.Node; VAR useFpu: BOOLEAN); + BEGIN + WHILE n # NIL DO + IF n.typ.form IN {Real32, Real64} THEN useFpu := TRUE END; + CASE n.class OF + | Ncase: + CheckFpu(n.left, useFpu); CheckFpu(n.right.left, useFpu); CheckFpu(n.right.right, useFpu) + | Ncasedo: + CheckFpu(n.right, useFpu) + | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard: + CheckFpu(n.left, useFpu) + | Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex: + CheckFpu(n.left, useFpu); CheckFpu(n.right, useFpu) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END CheckFpu; + + PROCEDURE procs(n: DevCPT.Node); + VAR proc, obj: DevCPT.Object; i, j: INTEGER; end: DevCPL486.Label; + ch: SHORTCHAR; name: DevCPT.Name; useFpu: BOOLEAN; + BEGIN + INC(DevCPL486.level); nesting := 0; + WHILE (n # NIL) & DevCPM.noerr DO + DevCPC486.imLevel[DevCPL486.level] := DevCPC486.imLevel[DevCPL486.level - 1]; proc := n.obj; + IF imVar IN proc.conval.setval THEN INC(DevCPC486.imLevel[DevCPL486.level]) END; + procs(n.left); + DevCPM.errpos := n.conval.intval; + useFpu := FALSE; CheckFpu(n.right, useFpu); + DevCPC486.Enter(proc, n.right = NIL, useFpu); + InitializeIPVars(proc); + end := DevCPL486.NewLbl; Return := DevCPL486.NewLbl; stat(n.right, end); + DevCPM.errpos := n.conval.intval2; Checkpc; + IF sequential OR (end # DevCPL486.NewLbl) THEN + DevCPL486.SetLabel(end); + IF (proc.typ # DevCPT.notyp) & (proc.sysflag # noframe) THEN DevCPC486.Trap(funcTrap) END + END; + DevCPL486.SetLabel(Return); + ReleaseIPVars(proc); + DevCPC486.Exit(proc, n.right = NIL); + IF proc.mode = TProc THEN + name := proc.link.typ.strobj.name^$; i := 0; + WHILE name[i] # 0X DO INC(i) END; + name[i] := "."; INC(i); j := 0; ch := proc.name[0]; + WHILE (ch # 0X) & (i < LEN(name)-1) DO name[i] := ch; INC(i); INC(j); ch := proc.name[j] END ; + name[i] := 0X; + ELSE name := proc.name^$ + END; + DevCPE.OutRefName(name); DevCPE.OutRefs(proc.scope.right); + n := n.link + END; + DEC(DevCPL486.level) + END procs; + + PROCEDURE Module*(prog: DevCPT.Node); + VAR end: DevCPL486.Label; name: DevCPT.Name; obj, p: DevCPT.Object; n: DevCPT.Node; + aAd, rAd: INTEGER; typ: DevCPT.Struct; useFpu: BOOLEAN; + BEGIN + DevCPH.UseReals(prog, {DevCPH.longDop, DevCPH.longMop}); + DevCPM.NewObj(DevCPT.SelfName); + IF DevCPM.noerr THEN + DevCPE.OutHeader; n := prog.right; + WHILE (n # NIL) & (n.class = Ninittd) DO n := n.link END; + useFpu := FALSE; CheckFpu(n, useFpu); + DevCPC486.Enter(NIL, n = NIL, useFpu); + end := DevCPL486.NewLbl; stat(n, end); DevCPL486.SetLabel(end); + DevCPM.errpos := prog.conval.intval2; Checkpc; + DevCPC486.Exit(NIL, n = NIL); + IF prog.link # NIL THEN (* close section *) + DevCPL486.SetLabel(DevCPE.closeLbl); + useFpu := FALSE; CheckFpu(prog.link, useFpu); + DevCPC486.Enter(NIL, FALSE, useFpu); + end := DevCPL486.NewLbl; stat(prog.link, end); DevCPL486.SetLabel(end); + DevCPM.errpos := SHORT(ENTIER(prog.conval.realval)); Checkpc; + DevCPC486.Exit(NIL, FALSE) + END; + name := "$$"; DevCPE.OutRefName(name); DevCPE.OutRefs(DevCPT.topScope.right); + DevCPM.errpos := prog.conval.intval; + WHILE query # NIL DO + typ := query.typ; query.typ := DevCPT.int32typ; + query.conval.intval := 20; (* parameters *) + query.conval.intval2 := -8; (* saved registers *) + DevCPC486.Enter(query, FALSE, FALSE); + InstallQueryInterface(typ, query); + DevCPC486.Exit(query, FALSE); + name := "QueryInterface"; DevCPE.OutRefName(name); + query := query.nlink + END; + procs(prog.left); + DevCPC486.InstallStackAlloc; + addRef := NIL; release := NIL; release2 := NIL; + DevCPC486.intHandler := NIL; + IF DevCPM.noerr THEN DevCPE.OutCode END; + IF ~DevCPM.noerr THEN DevCPM.DeleteObj END + END + END Module; + +END DevCPV486. diff --git a/Trurl-based/Dev/Mod/Commanders.txt b/Trurl-based/Dev/Mod/Commanders.txt new file mode 100644 index 0000000..4d102e7 --- /dev/null +++ b/Trurl-based/Dev/Mod/Commanders.txt @@ -0,0 +1,361 @@ +MODULE DevCommanders; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Commanders.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Fonts, Ports, Stores, Models, Views, Controllers, Properties, Dialog, Controls, + TextModels, TextSetters, TextMappers, Services, StdLog; + + CONST + (* additional Scan types *) + ident = 19; qualident = 20; execMark = 21; + + point = Ports.point; + + minVersion = 0; maxVersion = 0; maxStdVersion = 0; + + + TYPE + View* = POINTER TO ABSTRACT RECORD (Views.View) + END; + EndView* = POINTER TO ABSTRACT RECORD (Views.View) + END; + + Par* = POINTER TO RECORD + text*: TextModels.Model; + beg*, end*: INTEGER + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + + StdView = POINTER TO RECORD (View) END; + StdEndView = POINTER TO RECORD (EndView) END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + Scanner = RECORD + s: TextMappers.Scanner; + ident: ARRAY LEN(Kernel.Name) OF CHAR; + qualident: ARRAY LEN(Kernel.Name) * 2 - 1 OF CHAR + END; + + TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END; + + VAR + par*: Par; + dir-, stdDir-: Directory; + + cleaner: TrapCleaner; + cleanerInstalled: BOOLEAN; + + + (** Cleaner **) + + PROCEDURE (c: TrapCleaner) Cleanup; + BEGIN + par := NIL; + cleanerInstalled := FALSE; + END Cleanup; + + (** View **) + + PROCEDURE (v: View) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE; + BEGIN + v.Externalize^(wr); + wr.WriteVersion(maxVersion); + wr.WriteXInt(execMark) + END Externalize; + + PROCEDURE (v: View) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE; + VAR thisVersion, type: INTEGER; + BEGIN + v.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxVersion, thisVersion); + IF rd.cancelled THEN RETURN END; + rd.ReadXInt(type) + END Internalize; + + + (** Directory **) + + PROCEDURE (d: Directory) New* (): View, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewEnd* (): EndView, NEW, ABSTRACT; + + + (* auxilliary procedures *) + + PROCEDURE IsIdent (VAR s: ARRAY OF CHAR): BOOLEAN; + VAR i: INTEGER; ch: CHAR; + BEGIN + ch := s[0]; i := 1; + IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") THEN + REPEAT + ch := s[i]; INC(i) + UNTIL ~( ("0" <= ch) & (ch <= "9") OR ("A" <= CAP(ch)) & (CAP(ch) <= "Z") + OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") ); + RETURN (ch = 0X) & (i <= LEN(Kernel.Name)) + ELSE + RETURN FALSE + END + END IsIdent; + + PROCEDURE Scan (VAR s: Scanner); + VAR done: BOOLEAN; + BEGIN + s.s.Scan; + IF (s.s.type = TextMappers.view) THEN + IF Properties.ThisType(s.s.view, "DevCommanders.View") # NIL THEN s.s.type := execMark END + ELSIF (s.s.type = TextMappers.string) & TextMappers.IsQualIdent(s.s.string) THEN + s.s.type := qualident; s.qualident := s.s.string$ + ELSIF (s.s.type = TextMappers.string) & IsIdent(s.s.string) THEN + s.ident := s.s.string$; + TextMappers.ScanQualIdent(s.s, s.qualident, done); + IF done THEN s.s.type := qualident ELSE s.s.type := ident END + END + END Scan; + + PROCEDURE GetParExtend (r: TextModels.Reader; VAR end: INTEGER); + VAR v, v1: Views.View; + BEGIN + REPEAT r.ReadView(v); + IF v # NIL THEN + v1 := v; + v := Properties.ThisType(v1, "DevCommanders.View") ; + IF v = NIL THEN v := Properties.ThisType(v1, "DevCommanders.EndView") END + END + UNTIL r.eot OR (v # NIL); + end := r.Pos(); IF ~r.eot THEN DEC(end) END + END GetParExtend; + + PROCEDURE Unload (cmd: Dialog.String); + VAR modname: Kernel.Name; str: Dialog.String; i: INTEGER; ch: CHAR; mod: Kernel.Module; + BEGIN + i := 0; ch := cmd[0]; + WHILE (ch # 0X) & (ch # ".") DO modname[i] := SHORT(ch); INC(i); ch := cmd[i] END; + modname[i] := 0X; + mod := Kernel.ThisLoadedMod(modname); + IF mod # NIL THEN + Kernel.UnloadMod(mod); + IF mod.refcnt < 0 THEN + str := modname$; + Dialog.MapParamString("#Dev:Unloaded", str, "", "", str); + StdLog.String(str); StdLog.Ln; + Controls.Relink + ELSE + str := modname$; + Dialog.ShowParamMsg("#Dev:UnloadingFailed", str, "", "") + END + END + END Unload; + + PROCEDURE Execute (t: TextModels.Model; pos: INTEGER; VAR end: INTEGER; unload: BOOLEAN); + VAR s: Scanner; beg, res: INTEGER; cmd: Dialog.String; + BEGIN + end := t.Length(); + s.s.ConnectTo(t); s.s.SetPos(pos); s.s.SetOpts({TextMappers.returnViews}); + Scan(s); ASSERT(s.s.type = execMark, 100); + Scan(s); + IF s.s.type IN {qualident, TextMappers.string} THEN + beg := s.s.Pos() - 1; GetParExtend(s.s.rider, end); + ASSERT(~cleanerInstalled, 101); + Kernel.PushTrapCleaner(cleaner); cleanerInstalled := TRUE; + NEW(par); par.text := t; par.beg := beg; par.end := end; + IF s.s.type = qualident THEN cmd := s.qualident$ ELSE cmd := s.s.string$ END; + IF unload (* & (s.s.type = qualident)*) THEN Unload(cmd) END; + Dialog.Call(cmd, " ", res); + par := NIL; + Kernel.PopTrapCleaner(cleaner); cleanerInstalled := FALSE; + END + END Execute; + + PROCEDURE Track (v: View; f: Views.Frame; x, y: INTEGER; buttons: SET); + VAR c: Models.Context; w, h, end: INTEGER; isDown, in, in0: BOOLEAN; m: SET; + BEGIN + c := v.context; c.GetSize(w, h); in0 := FALSE; in := TRUE; + REPEAT + IF in # in0 THEN + f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.show); in0 := in + END; + f.Input(x, y, m, isDown); + in := (0 <= x) & (x < w) & (0 <= y) & (y < h) + UNTIL ~isDown; + IF in0 THEN + f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.hide); + WITH c:TextModels.Context DO + Execute(c.ThisModel(), c.Pos(), end,Controllers.modify IN buttons) + ELSE Dialog.Beep + END + END + END Track; + + (* StdView *) + + PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer); + BEGIN + v.Externalize^(wr); + wr.WriteVersion(maxStdVersion) + END Externalize; + + PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader); + VAR thisVersion: INTEGER; + BEGIN + v.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, maxStdVersion, thisVersion) + END Internalize; + + PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER); + CONST u = point; + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color; + size, d, w, asc, dsc, fw: INTEGER; s: ARRAY 2 OF CHAR; + BEGIN + ASSERT(v.context # NIL, 20); + c := v.context; + WITH c: TextModels.Context DO a := c.Attr(); font := a.font; color := a.color + ELSE font := Fonts.dir.Default(); color := Ports.defaultColor + END; + font.GetBounds(asc, dsc, fw); + size := asc + dsc; d := size DIV 2; + f.DrawOval(u, 0, u + size, size, Ports.fill, color); + s := "!"; + w := font.StringWidth(s); + f.DrawString(u + d - w DIV 2, size - dsc, Ports.background, s, font) + END Restore; + + PROCEDURE (v: StdView) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + WITH msg: Controllers.TrackMsg DO + Track(v, f, msg.x, msg.y, msg.modifiers) + | msg: Controllers.PollCursorMsg DO + msg.cursor := Ports.refCursor + ELSE + END + END HandleCtrlMsg; + + PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER; + BEGIN + WITH msg: Properties.Preference DO + WITH msg: Properties.SizePref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, dsc, fw); + msg.h := asc + dsc; msg.w := msg.h + 2 * point + | msg: Properties.ResizePref DO + msg.fixed := TRUE + | msg: Properties.FocusPref DO + msg.hotFocus := TRUE + | msg: TextSetters.Pref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, msg.dsc, fw) + | msg: Properties.TypePref DO + IF Services.Is(v, msg.type) THEN msg.view := v END + ELSE + END + ELSE + END + END HandlePropMsg; + + + (* StdEndView *) + + PROCEDURE (v: StdEndView) Restore (f: Views.Frame; l, t, r, b: INTEGER); + CONST u = point; + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color; + size, w, asc, dsc, fw: INTEGER; s: ARRAY 2 OF CHAR; + points: ARRAY 3 OF Ports.Point; + BEGIN + ASSERT(v.context # NIL, 20); + c := v.context; + WITH c: TextModels.Context DO a := c.Attr(); font := a.font; color := a.color + ELSE font := Fonts.dir.Default(); color := Ports.defaultColor + END; + font.GetBounds(asc, dsc, fw); + size := asc + dsc; + points[0].x := 0; points[0].y := size; + points[1].x := u + (size DIV 2); points[1].y := size DIV 2; + points[2].x := u + (size DIV 2); points[2].y := size; + f.DrawPath(points, 3, Ports.fill, color, Ports.closedPoly) + END Restore; + + PROCEDURE (v: StdEndView) HandlePropMsg (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER; + BEGIN + WITH msg: Properties.Preference DO + WITH msg: Properties.SizePref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, dsc, fw); + msg.h := asc + dsc; msg.w := (msg.h + 2 * point) DIV 2 + | msg: Properties.ResizePref DO + msg.fixed := TRUE + | msg: Properties.FocusPref DO + msg.hotFocus := TRUE + | msg: TextSetters.Pref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, msg.dsc, fw) + | msg: Properties.TypePref DO + IF Services.Is(v, msg.type) THEN msg.view := v END + ELSE + END + ELSE + END + END HandlePropMsg; + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (): View; + VAR v: StdView; + BEGIN + NEW(v); RETURN v + END New; + + PROCEDURE (d: StdDirectory) NewEnd (): EndView; + VAR v: StdEndView; + BEGIN + NEW(v); RETURN v + END NewEnd; + + PROCEDURE Deposit*; + BEGIN + Views.Deposit(dir.New()) + END Deposit; + + PROCEDURE DepositEnd*; + BEGIN + Views.Deposit(dir.NewEnd()) + END DepositEnd; + + PROCEDURE SetDir* (d: Directory); + BEGIN + dir := d + END SetDir; + + PROCEDURE Init; + VAR d: StdDirectory; + BEGIN + NEW(d); dir := d; stdDir := d; + NEW(cleaner); cleanerInstalled := FALSE; + END Init; + +BEGIN + Init +END DevCommanders. diff --git a/Trurl-based/Dev/Mod/Compiler.txt b/Trurl-based/Dev/Mod/Compiler.txt new file mode 100644 index 0000000..6aa0761 --- /dev/null +++ b/Trurl-based/Dev/Mod/Compiler.txt @@ -0,0 +1,348 @@ +MODULE DevCompiler; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Compiler.odc *) + (* DO NOT EDIT *) + + IMPORT Kernel, + Files, Views, Dialog, Controls, + TextModels, TextMappers, TextViews, TextControllers, + StdLog, StdDialog, + DevMarkers, DevCommanders, DevSelectors, + DevCPM, DevCPT, DevCPB, DevCPP, DevCPE, DevCPV := DevCPV486; + + CONST + (* compiler options: *) + checks = 0; allchecks = 1; assert = 2; obj = 3; ref = 4; allref = 5; srcpos = 6; reallib = 7; signatures = 8; + hint = 29; oberon = 30; errorTrap = 31; + defopt = {checks, assert, obj, ref, allref, srcpos, signatures}; + + (* additional scanner types *) + import = 100; module = 101; semicolon = 102; becomes = 103; comEnd = 104; + + VAR + sourceR: TextModels.Reader; + s: TextMappers.Scanner; + str: Dialog.String; + found: BOOLEAN; (* DevComDebug was found -> DTC *) + + PROCEDURE Module (source: TextModels.Reader; opt: SET; log: TextModels.Model; VAR error: BOOLEAN); + VAR ext, new: BOOLEAN; p: DevCPT.Node; + BEGIN + DevCPM.Init(source, log); + IF found THEN INCL(DevCPM.options, DevCPM.comAware) END; + IF errorTrap IN opt THEN INCL(DevCPM.options, DevCPM.trap) END; + IF oberon IN opt THEN INCL(DevCPM.options, DevCPM.oberon) END; + DevCPT.Init(opt); + DevCPB.typSize := DevCPV.TypeSize; + DevCPT.processor := DevCPV.processor; + DevCPP.Module(p); + IF DevCPM.noerr THEN + IF DevCPT.libName # "" THEN EXCL(opt, obj) END; +(* + IF errorTrap IN opt THEN DevCPDump.DumpTree(p) END; +*) + DevCPV.Init(opt); DevCPV.Allocate; DevCPT.Export(ext, new); + IF DevCPM.noerr & (obj IN opt) THEN + DevCPV.Module(p) + END; + DevCPV.Close + END; + IF DevCPM.noerr & (new OR ext) THEN DevCPM.RegisterNewSym + ELSE DevCPM.DeleteNewSym + END; + DevCPT.Close; + error := ~DevCPM.noerr; + DevCPM.Close; + p := NIL; + Kernel.FastCollect; + IF error THEN + DevCPM.InsertMarks(source.Base()); + DevCPM.LogWLn; DevCPM.LogWStr(" "); + IF DevCPM.errors = 1 THEN + Dialog.MapString("#Dev:OneErrorDetected", str) + ELSE + DevCPM.LogWNum(DevCPM.errors, 0); Dialog.MapString("#Dev:ErrorsDetected", str) + END; + StdLog.String(str) + ELSE + IF hint IN opt THEN DevCPM.InsertMarks(source.Base()) END; + DevCPM.LogWStr(" "); DevCPM.LogWNum(DevCPE.pc, 8); + DevCPM.LogWStr(" "); DevCPM.LogWNum(DevCPE.dsize, 8) + END; + DevCPM.LogWLn + END Module; + + PROCEDURE Scan (VAR s: TextMappers.Scanner); + BEGIN + s.Scan; + IF s.type = TextMappers.string THEN + IF s.string = "MODULE" THEN s.type := module END + ELSIF s.type = TextMappers.char THEN + IF s.char = "(" THEN + IF s.rider.char = "*" THEN + s.rider.Read; + REPEAT Scan(s) UNTIL (s.type = TextMappers.eot) OR (s.type = comEnd); + Scan(s) + END + ELSIF s.char = "*" THEN + IF s.rider.char = ")" THEN s.rider.Read; s.type := comEnd END + END + END + END Scan; + + PROCEDURE Do (source, log: TextModels.Model; beg: INTEGER; opt: SET; VAR error: BOOLEAN); + VAR s: TextMappers.Scanner; + BEGIN + Dialog.MapString("#Dev:Compiling", str); + StdLog.String(str); StdLog.Char(" "); + s.ConnectTo(source); s.SetPos(beg); + Scan(s); + WHILE (s.type # TextMappers.eot) & (s.type # module) DO Scan(s) END; + IF s.type = module THEN + Scan(s); + IF s.type = TextMappers.string THEN + StdLog.Char('"'); StdLog.String(s.string); StdLog.Char('"') + END + END; + sourceR := source.NewReader(NIL); sourceR.SetPos(beg); + Module(sourceR, opt, log, error) + END Do; + + + PROCEDURE Open; + BEGIN + Dialog.ShowStatus("#Dev:Compiling"); + StdLog.buf.Delete(0, StdLog.buf.Length()) + END Open; + + PROCEDURE Close; + BEGIN + StdLog.text.Append(StdLog.buf); + IF DevCPM.noerr THEN Dialog.ShowStatus("#Dev:Ok") + END; + sourceR := NIL; + Kernel.Cleanup + END Close; + + PROCEDURE Compile*; + VAR t: TextModels.Model; error: BOOLEAN; + BEGIN + Open; + t := TextViews.FocusText(); + IF t # NIL THEN + Do(t, StdLog.text, 0, defopt, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END Compile; + + PROCEDURE CompileOpt* (opt: ARRAY OF CHAR); + VAR t: TextModels.Model; error: BOOLEAN; i: INTEGER; opts: SET; + BEGIN + i := 0; opts := defopt; + WHILE opt[i] # 0X DO + IF opt[i] = "-" THEN + IF srcpos IN opts THEN EXCL(opts, srcpos) + ELSIF allref IN opts THEN EXCL(opts, allref) + ELSIF ref IN opts THEN EXCL(opts, ref) + ELSE EXCL(opts, obj) + END + ELSIF opt[i] = "!" THEN + IF assert IN opts THEN EXCL(opts, assert) + ELSE EXCL(opts, checks) + END + ELSIF opt[i] = "+" THEN INCL(opts, allchecks) + ELSIF opt[i] = "?" THEN INCL(opts, hint) + ELSIF opt[i] = "@" THEN INCL(opts, errorTrap) + ELSIF opt[i] = "$" THEN INCL(opts, oberon) + END; + INC(i) + END; + Open; + t := TextViews.FocusText(); + IF t # NIL THEN + Do(t, StdLog.text, 0, opts, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileOpt; + + PROCEDURE CompileText* (text: TextModels.Model; beg: INTEGER; OUT error: BOOLEAN); + BEGIN + ASSERT(text # NIL, 20); ASSERT((beg >= 0) & (beg < text.Length()), 21); + Open; + Do(text, StdLog.text, beg, defopt, error); + IF error THEN DevMarkers.ShowFirstError(text, TextViews.focusOnly) END; + Close + END CompileText; + + PROCEDURE CompileAndUnload*; + VAR t: TextModels.Model; error: BOOLEAN; mod: Kernel.Module; n: ARRAY 256 OF CHAR; + BEGIN + Open; + t := TextViews.FocusText(); + IF t # NIL THEN + Do(t, StdLog.text, 0, defopt, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) + ELSE + mod := Kernel.ThisLoadedMod(DevCPT.SelfName); + IF mod # NIL THEN + Kernel.UnloadMod(mod); + n := DevCPT.SelfName$; + IF mod.refcnt < 0 THEN + Dialog.MapParamString("#Dev:Unloaded", n, "", "", str); + StdLog.String(str); StdLog.Ln; + Controls.Relink + ELSE + Dialog.MapParamString("#Dev:UnloadingFailed", n, "", "", str); + StdLog.String(str); StdLog.Ln + END + END + END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileAndUnload; + + PROCEDURE CompileSelection*; + VAR c: TextControllers.Controller; t: TextModels.Model; beg, end: INTEGER; error: BOOLEAN; + BEGIN + Open; + c := TextControllers.Focus(); + IF c # NIL THEN + t := c.text; + IF c.HasSelection() THEN + c.GetSelection(beg, end); Do(t, StdLog.text, beg, defopt, error); + IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END + ELSE Dialog.ShowMsg("#Dev:NoSelectionFound") + END + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileSelection; + + PROCEDURE CompileList (beg, end: INTEGER; c: TextControllers.Controller); + VAR v: Views.View; i: INTEGER; error, one: BOOLEAN; name: Files.Name; loc: Files.Locator; + t: TextModels.Model; opts: SET; title, entry: ARRAY 64 OF CHAR; + BEGIN + s.SetPos(beg); s.Scan; one := FALSE; + WHILE (s.start < end) & (s.type = TextMappers.string) & (s.len < LEN(name)) DO + s.Scan; one := TRUE; + WHILE (s.start < end) & (s.type = TextMappers.char) & + ((s.char = "-") OR (s.char = "+") OR + (s.char = "!") OR (s.char = "*") OR (s.char = "?") OR (s.char = "^") OR (s.char = "(")) + DO + IF s.char = "(" THEN + WHILE (s.start < end) & ((s.type # TextMappers.char) OR (s.char # ")")) DO s.Scan END + END; + s.Scan + END + END; + IF one & (s.start >= end) THEN + s.SetPos(beg); s.Scan; error := FALSE; + WHILE (s.start < end) & (s.type = TextMappers.string) & ~error DO + i := 0; WHILE i < LEN(name) DO name[i] := 0X; INC(i) END; + StdDialog.GetSubLoc(s.string, "Mod", loc, name); + t := NIL; + IF loc # NIL THEN + v := Views.OldView(loc, name); + IF v # NIL THEN + WITH v: TextViews.View DO t := v.ThisModel() + ELSE Dialog.ShowParamMsg("#Dev:NoTextFileFound", name, "", ""); error := TRUE + END + ELSE Dialog.ShowParamMsg("#Dev:CannotOpenFile", name, "", ""); error := TRUE + END + ELSE Dialog.ShowParamMsg("#System:FileNotFound", name, "", ""); error := TRUE + END; + s.Scan; opts := defopt; + WHILE (s.start < end) & (s.type = TextMappers.char) DO + IF s.char = "-" THEN + IF srcpos IN opts THEN EXCL(opts, srcpos) + ELSIF allref IN opts THEN EXCL(opts, allref) + ELSIF ref IN opts THEN EXCL(opts, ref) + ELSE EXCL(opts, obj) + END + ELSIF s.char = "!" THEN + IF assert IN opts THEN EXCL(opts, assert) + ELSE EXCL(opts, checks) + END + ELSIF s.char = "+" THEN INCL(opts, allchecks) + ELSIF s.char = "?" THEN INCL(opts, hint) + ELSIF s.char = "@" THEN INCL(opts, errorTrap) + ELSIF s.char = "$" THEN INCL(opts, oberon) + ELSIF s.char = "(" THEN + s.Scan; + WHILE (s.start < end) & (s.type = TextMappers.string) DO + title := s.string$; s.Scan; + IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ":") THEN + s.Scan; + IF (s.start < end) & (s.type = TextMappers.string) THEN + entry := s.string$; s.Scan; + IF t # NIL THEN DevSelectors.ChangeTo(t, title, entry) END + END + END; + IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ",") THEN s.Scan END + END + END; + s.Scan + END; + IF t # NIL THEN + Do(t, StdLog.text, 0, opts, error) + END + END + ELSE Dialog.ShowMsg("#Dev:NotOnlyFileNames") + END; + s.ConnectTo(NIL); + IF error & (c # NIL) & c.HasSelection() & (s.start < end) THEN + c.SetSelection(s.start, end) + END; + IF error & (v # NIL) THEN + Views.Open(v, loc, name, NIL); + DevMarkers.ShowFirstError(t, TextViews.any) + END + END CompileList; + + PROCEDURE CompileModuleList*; + VAR c: TextControllers.Controller; beg, end: INTEGER; + BEGIN + Open; + c := TextControllers.Focus(); + IF c # NIL THEN + s.ConnectTo(c.text); + IF c.HasSelection() THEN c.GetSelection(beg, end) + ELSE beg := 0; end := c.text.Length() + END; + CompileList(beg, end, c) + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileModuleList; + + PROCEDURE CompileThis*; + VAR p: DevCommanders.Par; beg, end: INTEGER; + BEGIN + Open; + p := DevCommanders.par; + IF p # NIL THEN + DevCommanders.par := NIL; + s.ConnectTo(p.text); beg := p.beg; end := p.end; + CompileList(beg, end, NIL) + ELSE Dialog.ShowMsg("#Dev:NoTextViewFound") + END; + Close + END CompileThis; + + PROCEDURE Init; + VAR loc: Files.Locator; f: Files.File; + BEGIN + loc := Files.dir.This("Dev"); loc := loc.This("Code"); + f := Files.dir.Old(loc, "ComDebug.ocf", TRUE); + found := f # NIL; + IF f # NIL THEN f.Close END + END Init; + +BEGIN + Init +END DevCompiler. diff --git a/Trurl-based/Dev/Mod/ElfLinker16.odc b/Trurl-based/Dev/Mod/ElfLinker16.odc new file mode 100644 index 0000000000000000000000000000000000000000..96b736efbc8076237ab474b23b7679ac6c516682 GIT binary patch literal 59458 zcmd^oTa299c2?Oro|!s{2_XrAfWn_XlbLF}UB}(_cxLRGIcfK0+)BIK>1xj#*5FU_tLr5SVctKnOPbjev;sGgq z-&$*5{!3Mt+kFlb=$Ur^|Ni%0d#$zCUTf{!+AFKu{R)1*{Dakg>$sct#-n;;+;%Uk z>8MqSK4sHa`n_?p(@Te=`Ujo#bIr`B=>7K_k#j034O1o0<+1CVWrE(eIt9ZVo)sW2H^yyep1epQrknGc*T{I~C zLu7yZ_axyv0>iKXkO&b%DWLc4B`H>^)c;GR^22z34S)6L(;vcL#mR~-kH^E#-tjmc zWhr^xO8lh#tz6*4mC7&uQ+cTTs{HwJq+R&(*=5Ug!~T{PVty?|W+{*>$3Ncq8yA5P zsJfRn+nI)a_5%j3VSnF~zhKg9l{@&|$LnAFN95USmA0h~EbR*Z64OwrROoBn{g*Ep z8+MM5SSt{aCzS)T)jot&kI%mVa5m3x;uk;KJONH)d~&3MC++4xxYTDX>waFr!=Alp zyIB57?cxe9@ImRp!}Z_!1^Mv)cP~_a9sP?R_9$Ap?Lpex?e~vXJI$m1LGAU%$!MH* zzqvCSw!XQ%*FPTLz5Dt?^13`GcaNH_$9MZrU!SjBoGdDTDAlNZ5d{^MAH|ap=}~_6 zW0J8_nX|v-p!>NXbn>m3-*Nd|>3LrK{uof3K+mT}#ESmCa0h>5e%~GTKOd#T+Urz_ z-@JSG+GeMf_C_fg?O2?+G_aZ-e?nEItn;Y-&VP!eW4(Wb_U6A?>G z{TdTV+@(jfjDHD_F9jHj{E8oip>-Ew2;O4Ze*(o{4#ju1^u*$dJZrB!#_vl)#?SJJ zx~lRUd=lVPdYA67{b*rd2{rspB=N_wN82e_Vy!`J{(mHC0_{5}@X~86_7;9G{Ruw( zIX+1~@=eoPK8+2jY5&frJ@jd8UM)*dm;NFCsRk7P2VVIzsT~4}mqfk&PhjziU~+;| zFOl@h&ja_b$rI)HCHBS2pTzG4p@Kxc^wUgR#qTAW;K~Bz;-&w_Cloc#Qnh`J#VVik z=_P*o)A)T!I?31h^o#hX@{jo>oce8Kk!+RUB0N!He+6GJuxRBS{9d|u4NcC>m)K@6 zQyee-09xwnfdhY;iTEkw00F5vqyD+HcL}^B@t1xOU%pPgd+G1uA5Hr$2*}HSmT7O| zpO@G9^v4JRr7ADa;~y2}i-4dd{<(kpb$ryc-}F!4^-uo>DC*b0Ls|sp4 zg{M%0Eu;Cq<)1V`( zO6AA#wCP@b1<#~wNk082%1wFr!~5H-4>#8m;IVeJPp2{+-nm@6a^>>Hi`Buf|5@4^ zSKm$MoWnAAx!NBdG<%(IH^-fRkDosO{PTK$FCF%K_0}Q2w=m|D5lVkJ;`eR&mUKI< zVSglk=Lor;z=<~i7fZa+ivnnHGVB~23IdZd9jQ~riZ13HErD^^>>Z?n$3?z(Mx*2K zdhzm=EAy8@?&WICfW(kXTK(<-bnYFc$>*K%q4$gvwArBF!&o@Ed)zrf+a<&FC~c0? zWU+n=&d%;(XOwjNZH!e=^5_Vk2k@%X44)U0eh*3G!!+6N^qNP$+Wvm13GfucUh3*- z*Dn+6>c;&C+dI3LtJMbh-8&d9;PL0uVJ|&eNY*1ZKQf1e*@;Mp7uz;?bu(l+}C z$Pmll9ROX~-f9r$R{Hr)+FE~*yqnxyTY7W(t($M&yQAsL!=a?VdF%SEw^rVK3+ec< zz25E&k$Y|h!}B?2ZG7CYByC_MBDHoU>89gm(&>%U;XZi+ffEZ?b~!24RqMnt$!-pg$a^ZT)U__1j4sa};243eVVT z>9@BBsFHBlOgrg*3vKys@|L{rro%43U6;45W;bQlw>0ktT7D>H-zH}Lw${oVZ{Knh z*4rn&(MdOfgbX_8KSi4SYfW!TSxeVszMh*dyUAdDvUtBR<#H*Vh-db@n??kIBsI%-riYPP%)2 zvhDuHR&8TzckTVPoq7GV+-{TC`49V@;b^>ibfhIeP_&mEz3t9u3=ur;j1Iy6k>PeI zGX!YqcKQ?(Jj#VJhUyzkF&K9!5t1c=+_N*(nWYFszU4rVo9vsy-C@7o95*A#H%cID zrssyOtr@|7qXf1!c@D!)?-aaQY&?u$-JbX^PwF98#(In7LGIf`*zpWwKb{A^WhrA`y>=Zhhby7g3X@D{|Q=m1|FPr zbI=xV-AQ6-2|5&oR@qJ`~9Bjh6sM~7D5HEJtho9WV!aHt1sy8V8TWV9SL z!>N@G9C)z;06&qM95=j%(B5E-9wp7A&OuMRL=Ak{JHdqNe9%zK{0udCQ;eQ=?PA(^ z=+dZWtJTBi=+LETNr*@`!2~axI64G_fT>GWXnUiPOHg2{y<8gYZnX*_atX|YltJ?# zWuFB0i`TDTzbCD+apSF93BPFXgq*P~5^pRq-<^cdgO0~ZHP&!jU8cIP zjUQYhy(uYt2%oBp-!^_*_}wGNpkvh zkRi0w#e2jP;Z5sSp6Tw#yX3y(2YMw$3H%70#rtjFEN|b+H4Hf2Ixb}`M8IjN z7+imUf0T|F5=wxlH^KnLb|+(S>y0;V2nqqZFl7P`rhYQ?ux+*#3Cc+~?M81jKP6aw zu)Kr3AKp$PPZ;y0!)|j7Cz2R!A4B}u)R;fD2H$ZBJL1YP*G}K1iFTBd>2TN|qM=7{ zkoc!DM$c(w+8mDJCY+>&1OqJb(7RX{TS$(YOhfy_7stQt+fkE4#i9K*4_#7E6wwfW z41GmE;~^F(y5Lj+@b4it`UJc3?Fv|g!L{~(31fGKBb?-;Sb%gg#wf1 z&^d(aZw~sS4(*%sHE6RR^ko2oE?`ei`PnOmLLEFtcmf$(KQ%)JiZ0>;wUK{N<%l%# z1JOmruUddNth#j}p>|$Kppo_CNmu^Tby!HCYj48}iBIil$U3!@xdh{Mj9$8ZxE|UG z44u)T3Lp&bLWHa{$>@J5ED*Gq8k#|_RH^AIlp=%fJBdeyfm5tGgI!WYfX zJb@-W`*Z{=XMVN}I&C12L0CIYYAc)DjWy3|v4`Nkn!ki#SM1?x;_N4)x@m-7My4rr;xFyayH|(ud;UT&_OY*4iPon<`H54lBzQxY*gM|ehfmsrBYo5y z!aGTO{o{i}DCzChZM;b0w^V$9P;&d-L@FRE9lptU_QQJ{n8F%;()l#`Msoe5WOW;# zt5V}9lKoR=<#(2=Zfvd8I>3T|x!+#KV{;byG!PjXvF}R>6o&7MYG9(_!h!yAq9w=*g%X5{8DKKfMVlP+J$U|p7F-h21Ppm|;dvA>*9(piKp;91<6a}N}LFdV^@}uoI#`)lGNZiPyt3gmHza+^Fo-(u@=*9 zFxZlr$s_e<6F6}$Hz%O5&*n}7k5sc*c_(%{fmm-0jyhwi30FOAr2{VPwS4!Rk5fXB ztgLwx?%!?oRqJ6p-VHmz&GY_rmj zys0WVQm?N4py%n#N&7Q(lF zDX?oR_jbTD)AJqb_=j7&8=DD-M%M$<#4v|9W-=7#VCg)T4zmO!zmqa0Hd0iR6Z@M* z6IiIV+DqO^t~;%BvXCq{?xC&FZcA^$XLV?!k~cv?28L5m!V?yga<^{Ii&&t1axJ-a zlRyCO#0UjRSt7+_SUF5;Em+%3V>r=6zcRHpSHps^OlAkuEotbgUln}MPU+c8 z7I=hZm)O1W(l8Ql60Gvxr06l2Ym94SYtMc(W1Ej^Pcbet07dzt5RS6w=tNkp>8AF4 z_l#@R?g!z*AhV`@#uuRb$UbQTT)X~}xC1KH0v+hb43IQTuh-y|EQC45P_ciC=r%jS zGU%ZJUG&>UILwsffYFuk9HEi6bBH`R9*d{o=MNIhMwN@M^VH#2)Hxgi(av<%n#p@m zj$%fe&U1J9(A(4{gH*V*PnzNgX}`4I>2z1Kv~zy-N-A5yz^pL6pB6Y88Z)86dO`MH zO>RtMv6%WA-7jgSPnwXG8=u0YbJ%zlZBWgATlzGp#mTuAPtO%{C}+TkEN4~@)7E3m zbh(vK;^E}Z+sO{ZFJmFiFBNmksV-OIPJ*eRFnI;Sf(~vx?hLpm0m80hhwSvKQzX?L zn710_joGw+Q>vvayHANd(0U>po$mlW=%gK5ZSs5{PHkNl!MV%1rmLen^+r0T-e8VH z_Fg`8-2;}FHKjEYTzmzgs#%|aV(@vCqz*g=R@dv;02fSj*y7QTZZU4b2kF$#aKl+5 zhn^~jj73k4MPwQ>z|Caa)aXaiRt}rP+FZS?j8z~U56sCz#DEGw zb%VwJu-{EqH#ae?P0HXYz9OyUcM;3Y-W^OxwXp|9R{QJA*qPF6*DMLsLTon9sORjC@e1Qnt&7JYNa{!T)6tc)h>D4({XE&=AXr9!c!H@&STRy3Wr)^D!gym9l^J>Q1xZk!DYS?!&89KwUZ zoIgMFwVQoyXJ5_Tpdf@IPbAM4tT+MmItGsXF?yN6kBGYIf)>@1+u`$YG zR{049vF>f4mGWv;oK|TxBI6y6oZ}+jh^ZixGdif5DPY;$tFO*ws+J}u@@RHlMwO9@ zKB_2$Nk6GXM=C(|lczFJ(X0+zvEMRxYnh$FbM_X~xLN`>&RJ1du2A0gQO;MRGgcg0HK^`62J=s`TT#O?7YYBwrw3-q{9G z^n5#AP~pHt2szA%WCwGC$^-suu#lehx8w`?@5JWSSR7<=Se8KRwy-FT53`3HpV&w@3#v&S{Q1}+_obfO;r6W0^qov|(ItH9+cN01C=<1XTA0_8FVvx@ z>z(%lh1La;y`zeaNtL^WJnv3 zGq!1H9#$_C9VbmjD?8v;7A9OJom%WMG3eTAbz+Unr&fY1`CVD)AWxYOkH0c-{- zCyu~Hy(_;_i*zii5lgPb{YTuxnm+0_TZf%qnk*0TcZ@At$5?0&1#Z?B zt%?sGtvuY>S=-u0A$OuDuF0jvWu-0senJJ5KH`SylVnZ)9rUrEGry-w>z8Z~;MSlG z9sj9kjAODV&Vd{pV$(%}xrlh{wr+|MHrVEj7`IIM5zG56Yo}~9b4}(d-#=;|j97UK z`@#CdYbN73BqJX}rAxK^`2YtZJse?IRl+^Nx;08S7Ng(DR_drhmTK7z?GD1=5d0D# zrCd;+%l8-`w-G!*!Dz9Zj|xFY?lFi_W`Df{gp(_Vj@xl+bZMhZK*w!+4^W8C6bNPL zK=bH6`T%7lNqIm>&2Nzt!is%9-)vL?i!jyHDIyJ#>WJ0KI?oA3-@ICZJljB5H~}e- z^+U9iF;0%QMOxi?_;KBW*VZx47{wyg#@Yf@KM-QgDXBsT?Evn6S?g2QqoO*4UKzSj~;HVuB{W%Bdoq8T!Kl)ee8bi zV{>OXyityxYzKwEFFSv+?R2EAiRQpQDD1ZG;M7`qNpeM2K0Rxqbx``5z7^#-%pvu% zkh3P5St;B16&^AahMhTKgkUc01Z(8SMS^(o;9SRxp zoQQ#C1aF^Pdd;v=da*|K{@sn;#_1BgbPuECo3zrXwQ+C#(emcz_6pMYy!O%B$_5U6 z?hwvt5?*E-QS1z|ERZO-+p>w@b7V%zmf~z}Ur?IaY53# zH?^2;%2wYA!j8Sm=PmGWJE`4$w6ivYwq7cT`3zzWyhWgLUfTnmk6GIdB=PZ1QWv&hYwLX3_ik%0MhPq(*0k<7)8r zY~2P0#UwOzSbie)!n+>2}*JCW_Xgt1OeMu3opI2`(a4*!K48~Wv zM=6T`U-hXSIoy)#EX7_`mg@}0Nx+w*1`>Y$%-crlw`uS$fFocKS#V5`YLPr;5P8&hK-As zLmN>klbhET-^>igl@Dj@H(K@_9k120E)rV^nN2FqRW@%WY>cO;6yXg$*BVbym4l3H zmccx;jfdybg~!8l?7}w3&Upe1?RS^&eh+)_czAw27_eTf2Lr%ada#+9@At$P#m^#$ zc&+jMniwb--GYSQ!;$6}mT#VmK1b<(!`YhMNB402>3byGMEZOrTOgfXuBG@{q?+P& z(k%=rrrM?0g*vBGLNHJHV!qeCqQDk}`u+Zk&+HVlB-5px1MyOgu^S%m!mlIjM!XA^J~JVyuV{h}lnr2Xz_^uih((NWG( z+TRKad~5qT7BOB})!WT(sW{f(9Hk*8v)pO0iaU}u+Z2jMIdj?mg#tp?Zhv^DFH^9;+>j@Yy4dRKPVnHzQ&zwJR@ zzDj#E95rW?`xi9?jS12li@8h%P0Hx@MutsHj-cE=CYP-CS+|T#gB)WZQ$koP%=9rH zesi_E45h2>?qkX1akO)#4158H3x);qYRbSByqc`jK$mD^6fTds&F$sY z%(StoS=+x;Vrrj=`Yrh|D16}Nf@~x{^`z*M_~^BMFW98qSbr{NzRA5%i~Ps!6cPJ@ z=z3Szu6~%I$VJhW`G{il+_0G}%d!GTWv90W9DFX0VxU+sJH}p;3>nn0hhi#XzOrC$ z@m-jI+oHUI_@)bx!V{y2t4LZ$vi~E7dq#@@I4PKFL~W0)IxHt}$Ur-}$-g1tqZXRo z_POhR(!7F?wosQE=2*`VE7@z8)VWtk6oTy-l7@p_)xWqipw8LYNVUbHDR7`LLTlI2 zqvFgNnk2j9MuzrM%3}H(X%ojaaQY$_rHFBKxDPgp93^3dBxHDkSONPuW!xViVt@;i zDxr7cP~ftnM>rCo5W%JpA#lt9s{7b^%kaqvrHTWnNX7d?@>v9`*Fr$xekKB1q@)q} zhUe0o!5UzI7IZ))wLDIF?3;vgXV>D;_0d`qab-e4nw5z?3}#b6#RV_DP(bE zw!j$FL~5)mB}_Lrl-7k!(m3-(j^dcE_QV^5 zz(x^0mD!(xg>fwi275{^A|W(h>LoVSXl`)3>%y=R!L29t}?DE7bb>m zrL^!sxgBl`VPafLqoF5NnbDI1@yQ0K;X%(RIt-8gWpm*BfvZfUg%Xp^GRGj@cJT2@ zXVls2APnhA1d2xHwov`CH7N9r74Ge?>123OuEwsWnEb4g8jh>quxok ze~e>0IPq)-NcB97mc$~_;NC&Msu24jH zgVzmOol`1^(IP>AMP6M?ROu7|T~i)nqHtMqe9n=LnZF``qZVatIS8SpqLQVY zcA=-eM+UVSdul8Fqa%!u%+JZVYohzhJT1Cebgkg4MBWu*L1XJ$2<_)5!tA&rDdOEI zFxxJUk`FNH`OQr3pnul)0vEn&-WPl!I4x0RsUCbQ3a$#RCrX7V@{cH-<_=|S_(o4J zxGRb*jf@H?{WkDfP49qbdfWa)w8jF#S2NodQ*e?SCSt7JjeIwMi~f{_;S=*+h_W2z zg>PnY)ScHAyeOa%mq%C`sV~PB^kilf<1636n~ay0Gp}@{tpFm6O*5szoJgp47cvZ; z$;A?jojG_1MvI5e*#c@^=u@0e9)G88>1r z!PL8Mo}vl3r_(Wa-VfUuXRASPMw3c%QPTn^9hzs=Sw2Rco<6#c z(G8BcipPgQ2q)pD9qBgiO3Z3=Z`40J#w8?jvla$Z;f5@nuD+vpMDQC1NEqT^x{@!r zwNhRX-%#H5PPw~x(XPCck%rDilf?0d3_18Yy%Y;hU}`a!ZuS=bn&A@ed$w=v^Mwsxg9J3%y@_5=3{o zD!7U^2}(e5l`Nv@t`#xPeJsU0pJxj8`K)C$l#K1A7=qzki>PqD!djiwd*M;8p@EEV z?@~ZY#_1(M*T>n~G5cdRA2UyNP(VeZ^C=b>MvMGQAI1!WHSo0d z&9#izX;b05Sb(PhUQ5Izzx}ojr@ci%^HX_|V8ImH#)2S$PL~q7>0Uob1h{-ya&3K| zhus-~Gr43&ig#zYNhVxpZOV*#X;Sv`0tnYVxquWAjDkuMicmyUku^zB8vI&>=n>6k zoQ=3#nHed}m70}Ir?b#>P8<;A*_*r|N66qBJ|sqWV==;lSZv6$H+(8Nu@V9dT}|KB zpbQg>IMw42bj{FX^Eg=)yT~uB$h#Lic7U039*?42I>P%$w^mB8<^YOt!bmAtiCgnRc))h#P|(V9Y|up6gDy8j&;izq%W!{@o6!e9 ziA!ea7>yefxMTMv78iiKy%aXkqCd<&#@N09lMlUUjx9qjiXV;$U@Tx>xem%8Y`Gwc z2D2N2l{*I+Wiya;HWO(&g=)h*Oy|;9bt>Gz;g5L2lqr>;AX|#J`)m?tgA&2GtX7zA znYdj@ZejTyVC`NBaqd^+o4PSaui_FlM^<8@#ecg3QQHI~94vo${&SFzh|MriX#cXc z84&5m`?jvL1tg<}b3-k?D$|X@EcFX_;S2{%E`k=COB}msOJWFUCWx;b)~>&Csn4kO@N){^4y$Q2?FXB>X9gW z!Z(w659SSN6ta2HA6R38GyeOEYwRH|=@1A;7Z%QukMXDPr*m>Vn+6&L+V} zWw#M(m=-g9N?dT(g&WE;*M*4WOrR2Y%XC|IvAK>w-(mi2$6xiP7m#q&`sXFOGE2Kj zQkD_Yq6^YS!o`r+2Mo7(|C%4X2xAQ)fGzSI@wWYxa!sRVV=lrj5$-qyh z+U{!spHNE_8rIC137GKFdqQe_A}5HSofg8Qn-#Y;iMi{2Yal2 z2Wk=kc(qC?fP#`|DJ;=SDUJ|JOHG(B)~e8X<3f>fh^zyv@%Q}%|5jpTa|44{XLe!F zQ|tN$B74P;Tn<2YEOW;X*2Az70(%Ld?A&ObJyP!b!PKJ8&WcFO_5?5G)he7omU7+E zwIvGYy%6c+H33PPolofCxf_Mz8F2LBqWjHGuIgQ!Xi#7-H_k_Qq;m*nW5gvt5d>2;`XQtPaKRG{OQx~8*pN*d*kuIKk=;yCvD3O4eE?*+ zi78t67KRWmPt%=J6AG*U+?8uA=&L|%F~Z+>{Z#I~&JNWlqJSRDO7b2w`63HR(2Cv^ z?xg#z-dIT!6iYwSCl}|p(`yM@J2gwt2mD#5jcP z^5Xb-jOa)9A|D*uN9z$`2v5eCujVA5N!}IH0ScWR1CY6#_ z4$7e*E38K(h4LA>-rSy!Aj!PwiVUZPFzbSvslnpgQT%Y?`WqPsoiG8&`R6tG`TkZO zPe~Yz=qO5n;dU4_llQXqmLJ}Yk+n!+@J7^Kzk)naTJ?|oi+{2V$~LMTB*-+mpKvK3 zw}%5Y94EQMH2F3m5<*RAO!eF02eLIC3vzidW^@@y2yrhW7*D!Md1y`(Sa-v{lV1#e zdG!=BV1VvrGu-hDZRVzzjN15=FPhrTNQCK!V71jg@n#ggv0W#ZtPS-}_0Feu<+|$4 z{5LKH>K7fjkuf?W>9Hwx;26U~jOW0LY%}NhRCY$mcvc%~a7<`iKeZt^=0Gr?s%**W zbvatsi(J5l6&BkqK14*rLdAhDhow%8G4F>fCUKpu*D%E<^8-kF7-mI+f{Pk)KD1)c zq%xRv6;iv}#A5m25_0Y~t_0(aL_;{I+;Fj_Gn1$gMyk}%TG=q;1j@bLB%)!q3B3wz z_q>)_aiciDOF`zZe66wZWZ!gh7VY2Fyy_lr54hjixt96PEmKM`$yhYul7^^QnUBEK z4DTPqo?_f;g8ffUD+vJ1PpV^S{)Ch+l;@~iiZ9`IYg4;9CYGTn!l_1?beuL$cFl$6 zMs_m9`W+_%N=$4O!t1t-l!;rhmlotugfC-gwHckNLIs5mqOKrR*HJ1bh@%O0f9rCz zcm7Ee8{dga=q%jcjs8SMV;9Zi7#kwb`y6FTQQ~$-SA<7h4lPMX7;q^VTZ8_msG!06Q0DHE6@3y`qJZf0y1u$7i$2ZUe5Gja-BH>?Knih@#_fp z&bZ_1l<E{Fsl5@LLW%_w<7qb( zd7cX5z;{zBurMG}0ZwDh$SI!LnhF0mO_o?-R^XWvqEk?R%V6_>*o=6CjXX3s6Y3U_ zddfk=(#Fk9s!hRu5$hsyV2vl*GU#htTi8e1_eEI}6kk5`4f;gKEk#7!!A$6gi8Q}| z)Zeqduh$Mi4IK8C_jG=qEe1pBE;aN3S*Z>H_~eFNa9j)Px}uNrD}&~#n(sMriCf&7 z`~o*EIUHWMoH&7YZ0MBPFI9|CaS@$ceOh6m^I^}O{i&Xcr%W zf4w`VSaXLgk}b8cq19#zGqjXzct^=TH)1+bil|vX?qSh_dObwZBR=Kyh$C!sVp&3B zSEodj-rwB5yS({mdwsouYq1cnb93zxBn2u~KQ5U>DKI2(t_JAq<>o zEHnP<+$70RcEUnifaTf$R7E?-c<_?_HGPCcP8Fk`;y7 zWV*BpJt#W6xZkX$VHbTV#6?{$&!GrujV4=i%@{Ycb}BgI#WyH6p`Tt` z=>*G66DM%t-OPz{GoBcUW)^g{PjD!i=pY3?mI#DDH^<`}QC-AL4BEVl7-+3g7z3TA zrZsUwe=0yO^rr~Rn9uiU+hvKO?38qIBNaC3;8^oPnOiJ}YO#ef&wgrjS|XmDHT5r9 z5nr_iSQvd@#gfgcAc1_^8nUp?RL1bD;rQ*9M4qm%b1DEoZWATOi3bE7CP@T%T=bh- zR7ZBT13kv7P_AF!)MLkfj$j^xGq3-v1z1;-+BHGsV1B+RH&lPN#C)hSME+*w2J1z; zeVkmwq;HKP+=>|QcCB$QRHtn0T)MFjENB^nJr^F+oOOtgt!}kG!TwI&W1q-JNpRLr zURa|26h+*esXz^>uI~m4vXn`mCBY3Hcd&L+h?!Q3P1IMDy#>mNl|d&!l@Kv*~3$+i*qk{5MO(Yga!j(O-27(F+3-Nk1*)r2-9LFT0SNe;GG^-#c) zk+qO#Uc}b!2S@3>PY$(D=~NdN0qh2~&-=r+9Ca3IIER9XjFfxU1bQ_zUkx4zT1G(4 zCqUETEGd@XiAYszq&N_cOODkh8(f6oCU+>3?B3pS>#^HMmHX6^J|MMBsDd*&(?Aa_KrWSLqa5;^9rq|}vF0Pv zJ7tXHuifMQ&%-CU35grPz7@>}OwD1uA*RJ?$1MH@7cN73fibHt^oMK+wHe28^I##t z#Fn=$Y%#|*;|20aJK8HJ^CDYa0u~@nshvVAr?8Utm;uVr6zH;ePSZ9xh7la!*wT2$ z`KtCnBG$}^M98MBf-`IDBXfoIdeys!uRS(($yXcNl#8lKj3l#|BRa`7zC4E2q^?W^;X z&LYO;OjEgWHAxp~*o|Xs;wdE|EwWISoijWQLy@siPC7h-vbd!;(Eu~RfMg1g0>XJM z-IMOM(SGVYmuOM5oFm#Hx$lo1Q%ed)Hl+csm{FR-9P26=ke@~jb%A7~9b45qU2kKr z=j0q~m*nGZ(58mVQH_a_wz=!0FN0K7@wF=ez6-uelqff+*6zbG zgI@!8>@i%kL9<0~M)*%|)}>5m#LIB)Xu24>5e{?qMxD_(?X^y>wGPwP<799=9N;4Q zQT=kLa97D3~fM)gdMkM9vg&M=~Nd*WBB1Bdz zP9#uzy&wUMbM%~4vp8FdSTU{45^{Cc7Q9Shj5wGZax^EMd|F}kqTSTE8}`jwtZeo( z1H+~Ph`KT^@TP=mn4OVccMeRWj29WF3+Jt4o>bN@5O~8LGU{(dJ%lFjsIxa@yf*Pl zb8NBYl{v?~IY;_c&hg|jFD+`fBha}=WsHl8kB3c! z-v;)LQYlVpuucTO%!sjR+bo?D!)%f+$~o)FvP=$)hs;Lhckb#WBz~}E;qppzfIyn0 z5RThI74XO}Ftert^r*^!P0u4^OX20%6o3IAOEZl8t;HlPzpO6!6e=J>?(8EFUSGym z8K#LRwhKl(pHgSaI_l{0@PE18k-Q6%txPdR7f5Ow^(dro|i zLQLTD)S;t!rOGhHH(R!_9}yaF3LIv3Os8oF@YAQlo1J*q;Ec@Sey}2Q z+=Qz3c+_YE6%Z3Ouc26EjUo~;2Py`3Hg;Umu&y5kpm`oebvbhygxg?d7*?o<+{$`9 zj6Wed#_1pFvB(p72|Q-(^pI#K$z#BsP^^02p+=aJ5905X8CL+bM9d!#D6;@UMmla3 zNC3>JW;Z6!@*$oQATSol)IdI1VvN7qC1Z&q54r_OnV*OnB!^-Kx}k_P?e#1h5X{bW z5WO61A}2`>wYRb~OB@R2LCi}qm?tk}1}Qtc7xOb$7a;qpWLY`jNf;Sva!ry2j_|n% z5#E5prF)+JCUf5IGs)s-N7W4=i}#oWYnJ@vR>bQZe63Kq434m1Aixr`L=ZrrN@OWt z-L)JQF;))wRht0?*|kMdVwJ_zh}`4`s1Yd+y-276I!Y1>2XY80U=BbIKuFY}=Mg|z ztr+|7B1Vop+Vg{ zKt?8fcjw`n4k`+MVLbX2Beos9MXUnM?gFA5D__Sf%czc+f_0p)t%WxpUB)iP`31|- z96c6sg(+o8-Rt9y-t6=V3h4wQSPc<@0Rylw&!p3F)dD>nsAsIR9x+*SE~!6tQxGt7_A0 z1iq0zS5^UGrp;7uP@Y=$uAj7=UawO$8KfK8Ylaj8dUam9Wdik7>6ToxOSfdFe|-ww zl8^oBh0%gHP0*fVpo{ML{ha-E2n+SkS z&VkOHmuI@0mWp&;tO9qi@F{C|Ffr826IaIaqkOL9b6$jEi?WPM$=0%0u312%&CL;J zW?ZjoIa_T3AzjJ93dWgG^6MWCDW70y=}Bu&Na)cB$0NZisyoK(KIYdOG6$r)QaI}q zZA{TC6ZCM0->ShxQToEw?Cl2-w%gX)TL6Wb-^1I9KnYWQHuq2?Sj@b`n#j>@z9LRP zQ|dG@OKKbPE#&qKQE(8EAK{mXv#utwAkS|r51bG~&|DUQ?MHk50~}DqZG*A?NOx7Z z>}YEwc~L}uhF76{FvmRR)M|Vo<~GS3!}jzkP_RaXr;Z+>LANbMiaTVha+?9C%w-P} zvheN#ikt31wW|o+ep;YZL(+R7Y#FqJ8+dyMZ@+*yXNRj*1;#rMxIv278tC4uxhAq* zlWkZmkJTLfIBQUi*w8x6$KZ`I{OnT}bmgLA*FVAs-&upOfuL9lA2f%fbPfEe;W%aE zc0!$Xzd0DB!%@A_YW8~RP}d=l9*dWkLN8_II|ETH^xH;#*lDLj34HQkm_Ctc;$R7x z40eK5St*J0$9bzkGOcaM`)@#QRV?M@ZMif;*a{@9qk@@|qGGDgWwkJqV`?a^Je81^ z6DoA=o{wCz(Zj|G#689ioME#CHJ!YU$ljLAljdToyBiwjUYG47babU3p^pj5R*nI| zPYHUGRqde4h-$c4Hja24_N`F}@jY=ek=<)1srU7yZ&I5iDp;fS9%Xxu!t22#wNt>{69%YoXz{Pi%4|U`P|^sFIdw-mzq%02 zc-8}<_Q2eD6pn%)5O!s*gwdT9EjB2S7NM%45Z@`qSJ1n8W;LW-Eu_3!Ncjd7L8MrA4x;a3DE^#tl-t^;J$CIVUgY9n zjoEYrFp`0FkVAQuIC1t3RPwkkk(Y0ng_Lc`?nTb)@&y@Z7_hH)nn(SEdgHMFd1Krh zA7i|Xm959n2C6u{FRL^16me<= zB)8kI6^hA$Kv98S*%tHcrMkP0TU)?{Vg`I5@r4f&&L7qT7G@6ij&Vs5RH0L9AZvGbk$avbZ>iSS7^d*OZFA`aN zlL-&MOvsVp$t>k;3RGh4o6=A(&snj{+y|CE#e6_>sP=etJka|`F6XV@ z6*RiDSQ6sfMSNAmkES=x>Vx?BBoMAOhS~uvUjbZ#Gu7b)GG7JY-I3jA`HJ9E#1(n` z1yG1V1oS6?280p^m9ZCbZK~;y9`03 z5y5m8L1L(N`7$1MQ|vM8)1A_%B|iRKI_#xKmoHz;UX}wm1ViI zPY!18+q17#^ykOyZ`J^Xy0L1OL2&-*4Ibm(PCGp4^{T z`EbF#RerrMkMDo?f;{rWPus^YpI!FZ^x>!6yOduZ!p*7thhI@(zp8&M#}EClN=1JE z)}Zo3KXd23FaKb*-#X@g_yS9w{iK6xe~G{R2>rkRx1Usg0xy literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Mod/Linker.odc b/Trurl-based/Dev/Mod/Linker.odc new file mode 100644 index 0000000000000000000000000000000000000000..7b642598fc26e59cd9c7b5088b4f654d55f66bdf GIT binary patch literal 57137 zcmeHweQaFWb>C3CPE4=ad^&03CV9)1S3`-KB`HdxMDMQoFjFs-AnhMbQW!1JHt0XG z;21@d!u|cuIrrnec|%e1Iv+r3Yv;ZDaqhY2o^$TG=iYnX%IZd^gui#cxZ0^7?5FKP zzp^!GxR=$mUoS;j+4Pl8dr)h((_X*wYBRmBh4~b{|NhpX(@O~yKT?9t@$c*L@8|xD zJbor>;##MXwiHwZKT4IyekDq=CaSG;Un)L)TA-FnfAqVh(m0;KgkSl4_lw)<;XqMD zHv`ro*{3}`VU_qpWdFWG`Ha9YEC3`zgiwaid-!z*=evHVRQd)ye+a+&cj=q(t2kM; zrNN-r+&LJe{cKN8S&i?s-_jT#PM1FQEAmkKA^G`cq>a7%aKZ|mv)`ghEU%SFECq7< z;6qzKd;$oeS692S%l8jeAH&*&d$QLvC??ma-b0NpjMN8}R`whH%0@SBZ+AMa)n={Lxm`ZB z^`JjU_g~oT_v$Y!?Q{+Xr>2ur@{laIYW2Izox@X8r4yqWr~AeGdQJ z-)9~^;~w$L_CM+0FYqahy-Pn@Nst6znHWEt%+1VPoSB_FH=XS4O(*?>Znx7LB)gqn zvJVBH+)gna)LIEte&?W9Pm|qdEA3B=OZREZ~iSGNsbb@=0=k zoHd01f0gBKG4~GAo|4u`l&3gdmN=I`MGh?e0Ly&`pPokR3U3wT`jpIE?;|{E?aLUG zvFBKB7XQY+jZcD=aNNJd+fyi88YASA%sx_tttpvAVN19E0@J=5|9M&{^q2W6oCH)1 zmoA?K@-^n7f2EQD5Y2OgxiYjD`6NI$`1D=)Pl*anYY>2r>I$EPE@$~9kU3CVm&AFB zb)Ob;3R?(qrkN4C^>NmacAsU2U`51rEU&u4CFzHBp9Ir#k|ym6JieB4P$XB{AaOL8 zg-g-~yC2mEeG_=na~9Foh}xL6A>{-Y;ZA9T;I-%5e3INUpCoqyl~wLO2+;cUC8TLD zsS}mge#zJPH++(T|3N-+07@S~U443+X&m#?Nj^zy|Jmn$yMH39CdZ5x|AhCS{+)0BktMvp|MWAZpTK+aoB#3ii+KO=)H9{O1_t}m&)od%WxQ9) z&y;=x@V@E#uOyf7zW9-6q$eBuch@*}|M%oGCGyTcoap>A`Q-a1pDFzq>i^+~{_B4r zjjrPT4dkDk|LBjM!~6e8o+)(!@B2Ty@M9#@Z{z(B@xJo+{?)Hm@ct`!|03%D-7kFW zCn&VPg!dVU+)w@EpZZ0L)sN!+GbsP-U--`dNu~3*@J{%@@rA#BNX{GJ{kM?+`H%nB z=bp#=6}WO~>;Gqq^WGoeeGBEskX9-+QBsBS%XlAS2V|hf zI3Hw3{GrTVEMR~Ce`rDKKb1o(f}CKObZ9y3PhrU6H^`<53%m{%_{z17)tl?p1ZtS8 z<+QgrQ9gZo;>3yZZm)AEtq;auOeWoGY;t0})4N@3H$PDuG&^l(-M@do(%DISopzk%>^!m)-ki2BSS?_iFvY_sx)IE4748Vz@W%daH(|you-rkeui;J{$wa7+J z)5&TL z&LjMYFJL;^LZ{ld`_m{Gyi?PO_jl>zwOY4}p0U(==XP@WMbvBH32@?BZjlYIY+T=B zyVukEn`!;ZjpW5-zB+etX<`22RTNUn#0qpH6m~hPd9p29 zt_zMXFy~o141s1=j??9;D=@Q=T z3?L3_J1xxsR`Qaz34L}3@P%ybXs3}h;P%DJ9jLl4b{ZR9^jAC4X>6vu^)|b_06aU5 z?X$QDghdg$;(^%VQH<)mVz3McyUy^V^+ueTSMimIKB8n|-ZZ5q6V9Can zWa}!JeC6uWCJSmsl(@06c740LnQU()o7I(#%~fQMx8WtcoM;)A9&ZEO<%B@xwbtle zPFU}i>L!6*UuE*9b5tAwbvkKv>b2J8#1$5J7=-Dh*+3@$(+5{hC*2N2?{GSK;9HWS z9nkJ_vQ^!dH@ZYFtGHIk=8~w$iVRnXa=`Ffrvazv(Y@9(g@8skxd&YL@vnh@b^N=B zf9)pHYIw)Ld$nvY8ZBrUh`{dUWO-v_y}EQ=V5f)O4B4Cec#lR%hZAENA=#)60KBNs z@*CS#g0KTtvPyNB-T12{k*h=M$U zzWaE{U|)wOmP`)5JV1%cudn7HI)G4Sc_`H9B#caSHGP8q)d%WueOlY^`UfH8G&O^j zN+Hhrh;ipb22ZxIc@O-LnY1PkfG@uUFAsn&zW}KjglIXKL)3lQ~u%RQBLIpTg^f8F}4rwlTv;2}&l^ zhL#M}q>T^}d9T^0I!wyYTspgWO-!W#%4c;Z$qEYz>?BG=GpSG(IsLiP>zE0#mAjZ= z7Rc0hWL9&uvej)h2dwRy$2{YJ3!$ytwc6d3aHJ?(o=z;MvvY^KPznP9j*B)3IF)Vm zu8aqaqUGU7Q^oX?TD#dg8?8nerL=>vdpB=ZrP$h)q`Zsy_4?ZSRPsE=T@Av?sbu?V zm7FtP+`L+pM`AF33>46Svqh8@c5Pg305Qz@afKa1QY2-L8Hwh`f>bOVSoFY^S%1_B z7T}yCJQd+8h+jlXqvRuKr$%-G?Hp)|#&M`8E#Lw-n_ev}sT!;>^Q z8nTSstlp?DaiyE@3?=SX^Gy~M*yWY0n;1z9<=XX?a+7Pqo7cD3)-k966|g3T>}v+| z>j(RabwJAF=~yR$^_5vtI8N#-vdIJc%~Bmry>@jCK9Zf}qsdINx*_;Im`;|qu7Zca zPjd@cxj4kp$VK!a10yljBvfHFsdr(1%I3EPOotcd2?XFCSXa@d-1vyey|R~->w8!S zxiua8>3Xu+sYoG_3Z*L6btpeIWlU}`iXcPyvVwO6RE2%$#0}t00uN<^b`m&@&TvKT zuHZFSgcii_PXetc?#~lfj0lmJOreg7CM?onnZ*2^wv8uXRC?BjGzh_w=C~vhO=aso zh48s#=5@062nJ#q8DkYq$Il9&3AsS?L)B-zD6@RjJCopy0Mqt|!RJ+q@4|>>urr;L zAn>k-5LirQ&g@TKdNEnAUN5UTAFPq<)z`{c9neONvZdK^(_TsFUsQzs?3&_Ipm=dg z%TZ=rbEr_dz{lj@iaXRq_tmtjOPhlKl@->v=*wY8-jVgSSOUpwD&AY_k1S6n$)MAL ztD*e>jwblD`Y^Ywt#Pde1Zbiu4iogWAs%aNP;y2oq44 z_f>Y-N~~W79Va=Ok(V3rJDP?%nw<2uudg#%nRMkBlRG+Dlc3rZ>fO2%G?}lZ>7gQ3 z*c}lQ6$%h(+!vmC-4Rbnl_TI4%GgX&ZegorI*DDOo-lAW^i%k#+c9Ectz%LgLCS(3dY%C z40D-UJ>#ZO#r$1(Vs?dI=0lpwLTN)mcPR4hw-*y(5B3wt z=iBx>8KdgK1h?@_t}d-_moHtib|Z2L>?})qzA2n41SWP39q)lN!BRSvI8#xaLs-0E zX2}=F;EyU^TmhPRbOov6d#Pbnx z8oDyIu47*D;7AHtaw^%_gb^;5z32t1t0^_5)RYj72u=;w$G9V0n{;$Gi6}Sbkadu# z%2w5Ck*e{?lC6u0g+yX!z-Sc&s+FnO8erUsn`U_+65Is?>fl1QYN zG_UMIt!uIC0`xG;Y?A3{j_ktORgwK>?&g#?1^8xVD;;2aK#Y>TJ`@9s?z;zgku{~> zm*T#GKwgJ}-Y^>e1sSiYSxZ;skHG2=G#*F9aSqxL1^!-rjV+1-h0bcMf(zuFUE|#zBZGzEuMx^2<~#RvbOyYZiJbZ+dc%BBzXED8*tAWE43j z4&OWluw|Ue=6bK$g%drAX`d^59OC;bh1B=CHsX&af3C(b{at}4835bpaHR1=Aa<6Q z$s-0xPEkbERp}byb1x25W)wEwc%ENI%4Cb95D45*oQ z5jtA7%k<7kNymSZ-1GtbvYw5ay9P$gsq(=R+~&sGAj}zh> zJVDO`s%cN|h|3ufJ}?cM6ULwHqw`h#vO0jQq?&bggIkBalxMS2q6mW+wV#LKe}F?O zNWl3CJIKO;dj~0=ZNw$24FnTFnno!>h3yV1JY9lAGx9qM*#W3z#3pmvaRSdCl7<2G z2}HYl(BDhaokN_|!BlZ;c5XUJ``tIEd6?)$8z|A$QED<{D(2s&7R<} zl7k@c!SKl7@O%h}{#ZlfEAqI=qU#4o^znygHa{4{HfLwpCM#s%XM4t82v1<6 zU(SrEF5!~Yak6NZH9a+Axp);S7c0MWigfsfm`I<@f7IRsvjqIzL@$98G&NBC; z4E;`gYc~zRbDp+xj3X>26Z@1^x z0g{)q-(_H!fhIW&pwr~Zlfg+Sb(qOkF{SDGGOd1q8Wosk9*!~TG5%;7tIn8QNTU|-*bYcxY}64X$3-qs6zSX{*XDS)tQku z24!ej-_DT0=kN~7!3>J!fUS|Yn)@KR0~1NQ6L})pbU@L8qba9pvhZqxjC3W?g zU33mrBRUG%NrtX_r=pc=sPq_Xp)jNwS#ho`4gqa+^NQjv6pMxvn!;-IIE5_Ozvm&81qCn%Mfs3UH-MLux9zmfX=z zDG@4|F0S{Xi`_&it_}ABP+BFdeImZi4mt~FN6+cJ%gKG*_P8xq(&Y#}b)VsEFdlm_ z!?>_r@l&m|I(?j(bMK@BRx#2}K>D~i3kUCF9n%QNJ|V6iRUTO;R=|*0xpcf*s%SW5 zSq_Hh9lw~t`8cr{P1U(M$@Rz48uN=315h4b?|0LB6Bi1k7Xg1ZfBbpI(1E!J>#=@- zdk$&RyH`79OFN+H7!-UOHODbHhXw_LDtfJW^7YwzjI9+t_b- z(eVm^5pD*Z1Z3figc}AeS$P4j*u55W2l&Qrm}_bKK$aP0++V=~M2V|06>lPlYla8( z<3#6=wqyn-_|tg>zQe@| zoK*{Cgl`FC!-)Xd?GDEx3XePohm|6x7dQyLkg`I{Chu37E<)e%3ci}1Id{&}QfSTz z3k4^yRj=QSEahGW9%I(PO{!j{@0>0p38rSZjt9Xlt*lhntD8&P8=FN?FU3&dAd=y* z5n#7m$NHXSWH=R*>0|-Stt05AL~8k2u9sPhVmxFys_2EZP9brKweo#fTC^|fW( zv*e#g9g9q68=TD6)9^xguH3fn2->`hIKMhSr>kIMz0(}**SY~|Tfw3hTCgF8V=my| z=DZ?MJyj>!FGmi9F|-vVPF( zV>idVj;vBd=F9-U=VXSP_Pr0~}C`n4VeIb$fJqnr^W zP^3WSU|idQxk_=I!x;=eTp0Win<^ePV={`R2YTEmiaD<2LDFIP_TY^v0Ic#o1bq&y z7PC5ZViP#eT)|()lNLDZj@LI#Lxu7ko)*QiY;+jUAB7H>)x!^Ws1GjKnFq(ktmQS& zok-H#5Y2Nu%($^)nQ|4}^?Ck%`*x9{TqkL0ibM2C~`W^V=TmP;`B#Rk+ z&HU(OofX%axry0D&c8d=&*OFwd7j%R?a9O-squMat{9YDH8__d0(m;h3}pIR=@?4I zSZ67ETzVd~@3uSl+egy#aj6+$6(0Q)9;}}>4cf{!OzV$Y*N)1c*?>+NJFRy`wpTy;K<2E-?4GI5YGiRI)y3*L>;FVd{`jTDpey_C}%Q z37zKpsVIq2;d(B;)Ga^dY&Vv=^u!M4HqU23FHn;00ybY~FJR}_(&ZrHj4;h@>@+%_ zk^BFu@|9WxSVla052$MxB_J$Mw+5nk&;WJLz%Pu9*)pug5{8uND2EglY@BP=lp)!L z`D~bMfftPs_OFS742=O@YXFmCsAB1n(Ny@4hAP~L5rWIwHzC$j4pnJ(nye~@CMFpa zhtq_XCcBaqTv_Z54HtwxUx(RIDx*bssh%1*&{R*$VVi8gf zZ*l=vZZK+Et$!C}-0ZLps;}~&N=AS<)zsx zGu62DmDQO`%ZwcpTAp8-nO$C(oApU^<+<4vQow=YYOy>?l4CcabGujDhYPaJ&4nGf zAP?F+#ztzwo0V23r;~G+Lfw_U^33Y%uC?K}CFHqw=F4;Q9*g-hJFi29>#{H|hXzaW zx=}@w92rhz2%}RQ93T?w4z8EFnT$TTx$?~H{0gC?SiO57hD1_6w{QW1!r6jmCj(*l z-5H_cT$y(QQRQNS3)u*(WH8-yVTI^5L!k?~LaJwNID8NTEz8#z8g$}H^KQ(L86F*B zfP7Vk3~gNBc7zaBawP6EOXn73_)!mTgI=xo0GlTW(U9!6YPXBKvJk4c!5*#>b!@IY zJF{$b1?VO&gS8o+1Rl?NT0hVu?R0S%osD8M=VpZC1T)63N-VZi^6azEW=P^Z&`P#C zcr2c6IJWcfQi~T@i!|HK0m47QU4&3RaB2@1cm8KBf6zXn1{{?V|AUGJckFK9z-`R1 zlvQ*=O5rF6!ovV}YL}v3K(%V|9Y%pdFcRrZJpAfA&K8m`#Dy$$l$O%55rAbbLGJIu+fq4K znVG+gcss2FM3$29Uk$nCl*}w4q}92rxa^e7SKyuR^+W;@r~hCFp((n}L%5K44sIv# z@<2y45SKc6{YIvTszD`o%h5xqgfy8d8bO`7w!l_O4pT=`BR|^47ImIa@8gEE&$hTjdU+47dpO=uvu6PrHl{7W0MWV8O=@3;TLO7 za&orWMoM{ib=(9g#zL;73N&N6@whp=6>F_w$osYW9`>Z%W^Mfu#Rq#m7>^nnE$QPp zJEzs7TX^~9m;Y>)Q0vQP4;bOlz8#nlp_gib$w4U?VGF7lWmdCFp{NcK7{_u%g_LWp z`!&o8a8*i4Ry~^21ArbDDh1%Xdk^|eZs7$TmE|B`KyLvK!H7zS$G~V8sBdQIQI$zi z6fBM#192STJWLT^NB9DmxjIH9Tsa9e^7l`kj83!({`l!cHS!6B41Ja+9&M)Bq#F{! zBI3=g2=!#4Ld9v+Q)o)LY1=a&CLlWM*1#}SW1D_uPXT9FEm zq7)~LKq)^RJQ<}PJ^TEL%cQZ@laQ*JS>t>RJ)GP0Ch59oq)GUtH@5!e7!S}! zBJ6N(DG*@5zKaY5x!#7dZrc*T@6h*CaWp zps>~HZuOfhpH*LE1=%9t8)GQZeJ`|)H$>xB7%J%KR{WVJl9WY(AO7oip~S`5(8ysI zkhw2eVUWRKxWFrPkx}7+dI_iS`GbZP)lc1CWFWMYijG{vwf>t$2t z8qtT@c@*S|CmQNU22b6^kpxwbrWaNBx|(eeB?Od)jGm@mf+5tot4iY8w70Sw_X zmI%DZ8A1=eWRfu#O-+&iXnpCD3pyAZb@jBtZO`YijpEPV`B)61NFHHQNf|Yf$WvxJ z(Ke!Ggr@v4_ap4AoCOsuqFjA(ES?R{o&T2;5V(ZCz*bm^-V*j^m)eYWTWVC4E>?B3n3i?=GYEn#mS+o0ba1?V)UF^L#`6>@C5``;_B$c$d-9RTkli@gq=9reF3q9#L+-%~2|_1^D1xQEg>cD1oXc7^Jf}e_EH8U><=BR; zYRE^to{IpK@}yT7;2M()h*pT%v)YMV#0zWNI&&UmAG+*rQ=7@PI}XTjI9{#`nLUCj zL_zEZUhh4d)B=Mu5RL1;Q(@zZfhbBLt?9fY7^ZqDqRs4V(b&b|RQwoyRg4DLhpYt%-_lXcM)@D&Gaoj`@mbd3rDn)`FQYiuX5-5>8x4Y_ZYO9d`R2CQE~XMqad~v- z!pSq)a-k^WgoV>~PF+F-oYx1Ua6ZGhUcq4stI5>rp`RC4Cd?>2jpM}pX|kXemSY_n zv2$8Ow4ou2ugrO#z)7n);kiseq5_c(B1VZ5G)0NI*hUsLXt*sXEEWtgghWA`FQnjf zoPZypBR!eED(-xQ8uX1^3~CQZ1vell2KOI3l~H@X-dCfJaLSQ@i&c?tAv0z2Qn+f5 z*#)gFEG&1$l^a97%qSN2C{hN#+E+#GW9S0k&?t(Z&k)?nf03Y5D|&E`6jhS?Xt|F? z)h_XP@JGq2FLWHq^o1WKm`*Nzg|CLyA~g}kc`^a^EoA18h}Ce`MI;~-?#kvVt`X}n zu3&NMceunfra=jXho8|=nCJqOZ)KvCMw_uJq9rlSWdhB~+=`N!JFz@|D4zPrVZ3Qj zG@8VStEU9C2OB}4vI|V$k~O>4B0-d-%%=b5j0Q|)*|%Wv9;ZCX6UzEPOqoEY=&nXF zbvC4W-hmbj4h>Eui+p`lBP4btjeEySS&Lxz#y)Q*-_M**gcA7P=rryF!{-bW#{%UZ z@=ZD!%(vhPayQbBj(Bv;J4YG6mRj$TqftZO9@?mUZ770It76FL1`vwKmsbB2Q$&V{ zr;{V+{XWJ{hO0OeRv(#}(ZDjL@*4ngF1;5~3v$djzOk&f?@-uY1jTW}23cmAmr&Zjxc&&85OnQ7+daHvleCEB#HfoyUZ=hn6g1 z`$$lPIP`0}il($%mZ&|D9%hcvQg-m@) zfmFv`QCB@j6jhU16tkLwJ$;m^=*A9Z*-1waygI=PLZ9I$<(naf+D!YaI4D!*VI#k9 zMq;~DMZ$L8pD}#HBf4ltRiQVeYz;7cfk(oj$l{9AB`-2H-8BfQD&ZNJk1doq7yVSX zpyCVsM)ai08&nB)x8$UR?-9OK+eAbs`^0qIKMryfHwe#=3>;#0msS_#3^4}WkGIV9 z)I`F%)?+(M1ZZeT6}siMVj^B$3 zZf-unZlTII>dl@TSW2_lNDxjBIZq)Wh{m zUYp7wIl8`EriGFqbV>o%Y?-KII2AB}HV{)8 zYObw^26()+NLIi(ocSA!rRy)g3(jZ&f6=|FDELuq7h#Uq_fFrzFb zWaACDRbr=_Bh>>eM z8Un?gQ4?fX^XOwpgn4~f1;wU3B31*=;aH>(iK^hpumCVopajw&j7+BEeju{Z{w#Qf z1$tA~7d>1yH7qU~4c&zq$A=@4$Wlz8G}AUNHy}MK%mt;u>bY1@Q4*Aqn}ba+MS~p%I_fhU<`QCLpFMOKIZz2`Ao7Zs zL;wa|7^Bo^$j++KfY5QMg#pnZI0#ZDlEw*=la2h*t9{eSzb%e;=oWZeXl@jW=2#HG`iCVp$w$h%QC@{lcb-p$xLSk)YZ571crY6N1 zaZ!rS(}PBIn(tS##t4`>G7ezl?=^SB@{rXofawt~XQ*0a8@!d&2R)4%O4^{7m=pz- zxM-kElF%Q+o%U=~V!#yC%9uU8m3Ge!5ZfBI%uJ?upUtaeL5tCX$WVXK?jkgipk;M$d8eh6NU^7rKdweJS;{Cf$9^lzKeY&RX{r{m0zZAihXgUuU}$U z0*^>^g~U#v@M#kgk^^m#2ygc~xL0i4tkDSN3k*)Zu)CW+5~Ot;+Cgx2b9g?sBP&Eu z5O-2!4j+dN#Pi?Kc3ChIyi3DG8N0Zl0v|nK_P}2eCVPv2HEI)&P`8Y?;On?yllc<& zDtO=nUObsTd;~`~H>t$D!}|kmyFFl?$DvjmR$(IY2%o#EDBA%gJPl9q9xq1~wMpx)vnpUiJv%S{ng522qTx;SW0Nm#mwO z$i0{#d_lP8CQQu5SE2s_#ARuQmJ7!OdC%$=Kt^9X5_WNR>+!OUq!|qO?H6HRYXKCZ#>cptUKm+g z=K#P=lmW9$DFO%oJFfkZt%bF4H@joT@~5e{#CIE&ebKR}t9UsvC_ zqBr+et}bl?wsUj>bFP@N$K=<`-0R0?C+=oyjyJosY!$m5FS$yh1clpBmN~Mz{b+(yqd%y4-8INa&cjlowPpym!iuLR5Ytac7JB5&;EMklUv zRi6%Ro}ervLKPVSRFh$P&*@yaP_-&nZpTrwfkkLJ9l4vt0@N087S*6VWt6hjorZ|B zjFMQmaB+eaiX0P0s_qtN1<$}i2e7eDuYr@j*vDhMycnh`bS?B;W?RY$Lbil7(jD|{ zm)%;4FjG)jj`nJ1xHvj8U(^pYk=Id$mCbwXiQqb_qU0M!zRVC{ojma<^CE+A{NY+; z5W%6lKq}Vm3ll-EQ@v+Zbn6Fz9mQhMZhF%y@qMFMx3gxEUe|?i9vgJS4VfPf*KM0i zoFk)z!7RIH_K-qx z9)4v6O27iq#YPxb8&o@?-tje%*EOgtx+YdNTcTqa;KJ{`#F_;khQR@#u&4mnIpa)7 z+QJuJsn~jp`spHx=+?hgj)OnQ$KW@sH>yk9GT1UZTR}|5A4N@!L6-35akNs1R{xTg z;uYFEet2jDVJ-I}a1dKhOe+tWckB>fu20V{Q1q~Tx(30==Y+LwJtL*if#}Wa+c;Q5 zyYLQW4NWodg|$Sol|i+Di=u-43Bg42Vay-^2FS1ao@oUZwG1>{FoPN-M@SKPOJOa$ zOS6IM0+?G<2*o1N^K`?jkiT6KJsc!T29B=TAO?~+x$cUEYo~@Fw~(qX-XhyjVs|Wn!Es!i-*Ui~vl@Y>Jok{br!H=- zzk^N6yHSKUvB!jx)R&;3RTp04a{rDuXt2fV+2SnXk{}kh(Ey+$E>r_rzL$4sCM?F- zu%H7s#mW&5>PrRzO*2_vau!;y(t;o^XRP{8^?Oyou-rUfCmD}pgm@Jo)iJ2C z3Xu4(VrFzZFc^&Ih=&t()!CV?2KsoVqEN!=(6Hq|#sN4Ao~x%)AeC|$2xS=XJ2H0I zK)-SwbBRzyc99v=hKI2Mm=A6FWq2}qXzq9AH$BwfUfR+E*xzVla}EFTy^A`BL48Lf zg^1)THLMj3s^G@6YSCh`s63Gg#c{Of$nu7?s{p6Dev-vlr4T3WpR1yV<8UL-M^UU3 z?Tiw{Rn%EPPwWm?k7%IubJc`%TzO=Hn(^R5WEU1)du@&40~W}3gvtcmVBb+rEwZv} zf!6`$8n?=BC@8^uL#ZGfS`ckyuO>xpSRmI>8NG)so_VJea&WDbTt8IZr$wmuUotmNRXb^ZHf-ESGG5k^A6%{&hxK3D=QhP4f<@s44J@G)TwAg{)_)8VE{ijM{ePZ3z#N!irl)K zY{RK^t=8?PJ!}#4YYZuD@XQn^VeVQ$vEW!D(1BTBYqmljT$4r9BMVW{XHF)Uw<>S} zz&r6#HYvv77EjCYBaSg*+&F;Y#et+(RR}^-;2;fQZt<)=cDkhl=&w*3unQm|EIe#! z91Pm3@Dc4y-hzLg(-rHDM=&^Cg)q>V+HAxC=WT{iaMRo4;qj*7Vf_$v#MA78@wh8k z`^|ozXKYTrd5Yn9GF+gwvinAAb`^F-Xb|qO2cmpTKXhr4Y8);?5l6ST;v%yb3d_8c zDRXhS3>ICJFUN&=1(%0pPA&+=q4Fe+RxDmc9HEQ(ifRZ0^ z4x%_Igpo8CpG?d#!m+uDyF_CA!~jOJQXUz{F_sSE3|c#Y$d6W0R^)6IQn%NaT|2~| zTkJp|ANX{=2O&P5_V8ug%C*|vlrtnvU?CbiJB|J+v<&S`eMD3w=Ev@P+2NGwyJ?*A zmYB|>&N2s(9;*p_JU%9`FqECSwBUeS79G$_$$VRI z=)r22>YVXT!=b3~p_?=F;;UazM=3ScIUI#zjG+V^9Z>u?F*;_K{_D8%v*!2FM(K05 zaoMI6@_~F-J=#$#UeUOZOrWE3nvj~+CP|Wnn%u6W`d7JtZh0u}t~5wdO#E`q*S(0| zlo!x~Gp~b!iq0qKlH$-stb!t(2y_L`$?|ZW$MTT8iZ8ZwZdbPUI`?S;9Q4bRycPw0 z2_hrkUuq!eZ8)J(YQL-BV)2?(yUX367%wtG{0?Z4j@9(u3O;60YvTh@_-LxkDL_%# z$G);`Qn^)u1=_}KrtMC7sG0=77Zf2q=>S$xL7AQOwiK~d(=ZTZ2o;8q3WM@mgaz;G z?i}!}co5lRDo!aDG!i~KVro2M8=l{FpuK7$Gm`jD17(%%Jgn z9#z>C=~k^fS$(~#oEFbS$5x@2v-*u=>E?vvSu-yd0WdeHOd-cGw`^uGiwg)))*uXE z6a2SewiGNyIe67*vLiK|&>&4al(n(;3Al+BDk9zD#%XdB+hLqRcoPnh zz~u2k8*h*-H&OvABWoV>g1<-9goe1866B+q*;dMz2_*__1~QRDibt)~x!}Gwo&Q`Q z8zGS*kDRzmv{u$@HKHiiPLC)j-V)SyGrU?J)B})|Y~rMRjbec7B(P>3X|2c_PULbS zh$&1yvtCe{l^jGC=YmyyElNU1!OU{O>>yz*T`>eZn$?a~*bRxHdK3!)rj-WaBf1yN z$h$D2(gx&Ea40Cyxywwotm63!6DtT2&!duprXf2{&CozN$}q{qOq9a3Qy?lN72g5w z$t)M~Dmy3%4?Or6o-uGQfUlN|C8$T+n{u&Jor$M`kaMA{&;w61QT#Pnp9J6vDL_U2 zJWS|<kWuZMn zgHeS6?PIGR+mZ$QEKbP5k_j7jjk-fRPin*+9LPi(0?oKIJWfuaA+8|Er)jS;F)?u> zyfKke^xa;&g;Qx_G;gQ-PqXNPCj1Uyk1>rD6m*(ET?HV)<>>Xg&F1ZGuU0n2TS0(;utdx0F66V);H)- z_cf}A%>l#G;0O+`ZV6L_u7E2HHyh1GD6b^l@8X+z_w8eqaNxG^u`>Dm%Yirtms|KE z<8tRPQEuVRGiq%h=xaSW!MCB_O(!?Es+;HV`GQwg*Z8wVl5V}RwOze7?Z9M+%npgh z#K{_bLaUCY(>0i~uhE^Luqs!vE^bMvk(hKSp&1BIaG!gs_{>NjTlx5A*NqxJ3ykBy z^6MSRQ~rtS$~JLBTGGXav$c2w7z|+l9@OCyZqzSpZvrAtEmK=*t57*s_qA)Q;Qn6c zfmdG+Xs18;-h<}gn%3YTi2+p%L{RV`8gAW-^ z+(2}y^WY=?o4lH~TAk#zPOsH~W<#J=l49H{8u)6vkp+Gfnk#gGJ3pwhiSVx0ktL4# zFAVx>x~pGDC9f_WIdVcDwciZJj0!>+df}cMn;R?D)tj5uWTTt56}lT@`PzXWS5#bq zRo0hp%7>v3^Q;uF*ww8-@%2uvv2xJscX~@@kkPtAuP7!KZs3(IX>D}{D!FqX*9|}c zg(g>(var^$H@H*|9A5wso0I_rZ)ehG;P9GpX_&G%E@yHJ?y*)n8S3poesAmMxN-#o zI&TedTm_#lf(xmviLdP;9`14vp>v}q`-2BKNQ?G9i4NmZ`}yhQ;@bgo)1;LpTt7lC zjnsn;V3rcvg66glhlFMjeb^QNf#C?4KK@Tv5W~M3WJtSmzSt zdZ#02+o?eJ`?tMpnOYkuTI!#%zJm{~{8AY}q+{$JFT%L*XJk9J-K(|xEuiewC#p&R za|Bpz_Pez~eJ=(t<-{DL#a=vR0$fEWjwvz1NQbDq&LnfxC(rq*m%ZsU4qB;BNK0kN zDBH}?(E*!q6Sr=ya8j4a+L>9f-)yQDvqUE9KHSTYMp(vZgkPY>x9(ds_ZokjtfYPwn%$!FYZgg=gLWkrXymGH)<^=rzNK;}I#o{ajQ>}vag=o6c6Hw7B4 zk=){@Zn9o$-#*~^z{xi!lQ$t4w2u0EAQ>eplQ{7(Kn9+%$M{Ly-?JT=x3L02jR`=) z1&@RMowPUMf%y~%4_Y>v#CGYYlF4T$lS)PQGx37$QT!Jhpl?r1w4wj|;En3_n-k-+ z34fFFjBLo@D(Wm_awfQbOrB#fovj*z&dbH-`v( z-3QQa$qo1}(kafjE-()seXJckyZAYH^dWKZtU+#;YrSRY-MdK8s5S1*qR^}&3eCjC z(#lG8y}G%yy|GFBqgO%yt?R`8tqtP-)>Z->-+G-WzO_OG-+GnE*+qRk>D_xg$aQ-B zo`qL(t&Jo9gNcb3zyIU+ dO8?*!pDTUro%hMVpa0IkQu@9>`jJxU{{e^s7jFOn literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Mod/Markers.txt b/Trurl-based/Dev/Mod/Markers.txt new file mode 100644 index 0000000..b402b5b --- /dev/null +++ b/Trurl-based/Dev/Mod/Markers.txt @@ -0,0 +1,442 @@ +MODULE DevMarkers; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Markers.odc *) + (* DO NOT EDIT *) + + IMPORT + Kernel, Files, Stores, Fonts, Ports, Models, Views, Controllers, Properties, Dialog, + TextModels, TextSetters, TextViews, TextControllers, TextMappers; + + CONST + (** View.mode **) + undefined* = 0; mark* = 1; message* = 2; + firstMode = 1; lastMode = 2; + + (** View.err **) + noCode* = 9999; + + errFile = "Errors"; point = Ports.point; + + TYPE + View* = POINTER TO ABSTRACT RECORD (Views.View) + mode-: INTEGER; + err-: INTEGER; + msg-: POINTER TO ARRAY OF CHAR; + era: INTEGER + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + + StdView = POINTER TO RECORD (View) END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + SetModeOp = POINTER TO RECORD (Stores.Operation) + view: View; + mode: INTEGER + END; + + + VAR + dir-, stdDir-: Directory; + + globR: TextModels.Reader; globW: TextModels.Writer; (* recycling done in Load, Insert *) + + thisEra: INTEGER; + + + (** View **) + + PROCEDURE (v: View) CopyFromSimpleView- (source: Views.View), EXTENSIBLE; + BEGIN + (* v.CopyFrom^(source); *) + WITH source: View DO + v.err := source.err; v.mode := source.mode; + IF source.msg # NIL THEN + NEW(v.msg, LEN(source.msg^)); v.msg^ := source.msg^$ + END + END + END CopyFromSimpleView; + +(* + PROCEDURE (v: View) InitContext* (context: Models.Context), EXTENSIBLE; + BEGIN + ASSERT(v.mode # undefined, 20); + v.InitContext^(context) + END InitContext; +*) + + PROCEDURE (v: View) InitErr* (err: INTEGER), NEW, EXTENSIBLE; + BEGIN + ASSERT(v.msg = NIL, 20); + IF v.err # err THEN v.err := err; v.mode := mark END; + IF v.mode = undefined THEN v.mode := mark END + END InitErr; + + PROCEDURE (v: View) InitMsg* (msg: ARRAY OF CHAR), NEW, EXTENSIBLE; + VAR i: INTEGER; str: ARRAY 1024 OF CHAR; + BEGIN + ASSERT(v.msg = NIL, 20); + Dialog.MapString(msg, str); + i := 0; WHILE str[i] # 0X DO INC(i) END; + NEW(v.msg, i + 1); v.msg^ := str$; + v.mode := mark + END InitMsg; + + PROCEDURE (v: View) SetMode* (mode: INTEGER), NEW, EXTENSIBLE; + VAR op: SetModeOp; + BEGIN + ASSERT((firstMode <= mode) & (mode <= lastMode), 20); + IF v.mode # mode THEN + NEW(op); op.view := v; op.mode := mode; + Views.Do(v, "#System:ViewSetting", op) + END + END SetMode; + + + (** Directory **) + + PROCEDURE (d: Directory) New* (type: INTEGER): View, NEW, ABSTRACT; + PROCEDURE (d: Directory) NewMsg* (msg: ARRAY OF CHAR): View, NEW, ABSTRACT; + + + (* SetModeOp *) + + PROCEDURE (op: SetModeOp) Do; + VAR v: View; mode: INTEGER; + BEGIN + v := op.view; + mode := v.mode; v.mode := op.mode; op.mode := mode; + Views.Update(v, Views.keepFrames); + IF v.context # NIL THEN v.context.SetSize(Views.undefined, Views.undefined) END + END Do; + + PROCEDURE ToggleMode (v: View); + VAR mode: INTEGER; + BEGIN + IF ABS(v.err) # noCode THEN + IF v.mode < lastMode THEN mode := v.mode + 1 ELSE mode := firstMode END + ELSE + IF v.mode < message THEN mode := v.mode + 1 ELSE mode := firstMode END + END; + v.SetMode(mode) + END ToggleMode; + + + (* primitives for StdView *) + + PROCEDURE NumToStr (x: INTEGER; VAR s: ARRAY OF CHAR; VAR i: INTEGER); + VAR j: INTEGER; m: ARRAY 32 OF CHAR; + BEGIN + ASSERT(x >= 0, 20); + j := 0; REPEAT m[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0; + i := 0; REPEAT DEC(j); s[i] := m[j]; INC(i) UNTIL j = 0; + s[i] := 0X + END NumToStr; + + PROCEDURE Load (v: StdView); + VAR view: Views.View; t: TextModels.Model; s: TextMappers.Scanner; + err: INTEGER; i: INTEGER; ch: CHAR; loc: Files.Locator; + msg: ARRAY 1024 OF CHAR; + BEGIN + err := ABS(v.err); NumToStr(err, msg, i); + loc := Files.dir.This("Dev"); IF loc = NIL THEN RETURN END; + loc := loc.This("Rsrc"); IF loc = NIL THEN RETURN END; + view := Views.OldView(loc, errFile); + IF (view # NIL) & (view IS TextViews.View) THEN + t := view(TextViews.View).ThisModel(); + IF t # NIL THEN + s.ConnectTo(t); + REPEAT + s.Scan + UNTIL ((s.type = TextMappers.int) & (s.int = err)) OR (s.type = TextMappers.eot); + IF s.type = TextMappers.int THEN + s.Skip(ch); i := 0; + WHILE (ch >= " ") & (i < LEN(msg) - 1) DO + msg[i] := ch; INC(i); s.rider.ReadChar(ch) + END; + msg[i] := 0X + END + END + END; + NEW(v.msg, i + 1); v.msg^ := msg$ + END Load; + + PROCEDURE DrawMsg (v: StdView; f: Views.Frame; font: Fonts.Font; color: Ports.Color); + VAR w, h, asc, dsc: INTEGER; + BEGIN + CASE v.mode OF + mark: + v.context.GetSize(w, h); + f.DrawLine(point, 0, w - 2 * point, h, 0, color); + f.DrawLine(w - 2 * point, 0, point, h, 0, color) + | message: + font.GetBounds(asc, dsc, w); + f.DrawString(2 * point, asc, color, v.msg^, font) + END + END DrawMsg; + + PROCEDURE ShowMsg (v: StdView); + BEGIN + IF v.msg = NIL THEN Load(v) END; + Dialog.ShowStatus(v.msg^) + END ShowMsg; + + PROCEDURE Track (v: StdView; f: Views.Frame; x, y: INTEGER; buttons: SET); + VAR c: Models.Context; t: TextModels.Model; u, w, h: INTEGER; isDown, in, in0: BOOLEAN; m: SET; + BEGIN + v.context.GetSize(w, h); u := f.dot; in0 := FALSE; + in := (0 <= x) & (x < w) & (0 <= y) & (y < h); + REPEAT + IF in # in0 THEN + f.MarkRect(u, 0, w - u, h, Ports.fill, Ports.invert, Ports.show); in0 := in + END; + f.Input(x, y, m, isDown); + in := (0 <= x) & (x < w) & (0 <= y) & (y < h) + UNTIL ~isDown; + IF in0 THEN + f.MarkRect(u, 0, w - u, h, Ports.fill, Ports.invert, Ports.hide); + IF Dialog.showsStatus & ~(Controllers.modify IN buttons) & ~(Controllers.doubleClick IN buttons) THEN + ShowMsg(v) + ELSE + ToggleMode(v) + END; + c := v.context; + WITH c: TextModels.Context DO + t := c.ThisModel(); + TextControllers.SetCaret(t, c.Pos() + 1) + ELSE + END + END + END Track; + + PROCEDURE SizePref (v: StdView; VAR p: Properties.SizePref); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, w: INTEGER; + BEGIN + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN a := c(TextModels.Context).Attr(); font := a.font + ELSE font := Fonts.dir.Default() + END; + font.GetBounds(asc, dsc, w); + p.h := asc + dsc; + CASE v.mode OF + mark: + p.w := p.h + 2 * point + | message: + IF v.msg = NIL THEN Load(v) END; + p.w := font.StringWidth(v.msg^) + 4 * point + END + END SizePref; + + + (* StdView *) + + PROCEDURE (v: StdView) ExternalizeAs (VAR s1: Stores.Store); + BEGIN + s1 := NIL + END ExternalizeAs; + + PROCEDURE (v: StdView) SetMode(mode: INTEGER); + BEGIN v.SetMode^(mode); ShowMsg(v) + END SetMode; + + PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color; + w, h: INTEGER; + BEGIN + c := v.context; c.GetSize(w, h); + WITH c: TextModels.Context DO a := c.Attr(); font := a.font ELSE font := Fonts.dir.Default() END; + IF TRUE (*f.colors >= 4*) THEN color := Ports.grey50 ELSE color := Ports.defaultColor END; + IF v.err >= 0 THEN + f.DrawRect(point, 0, w - point, h, Ports.fill, color); + DrawMsg(v, f, font, Ports.background) + ELSE + f.DrawRect(point, 0, w - point, h, 0, color); + DrawMsg(v, f, font, Ports.defaultColor) + END + END Restore; + + PROCEDURE (v: StdView) GetBackground (VAR color: Ports.Color); + BEGIN + color := Ports.background + END GetBackground; + + PROCEDURE (v: StdView) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; + VAR focus: Views.View); + BEGIN + WITH msg: Controllers.TrackMsg DO + Track(v, f, msg.x, msg.y, msg.modifiers) + ELSE + END + END HandleCtrlMsg; + + PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, w: INTEGER; + BEGIN + WITH msg: Properties.Preference DO + WITH msg: Properties.SizePref DO + SizePref(v, msg) + | msg: Properties.ResizePref DO + msg.fixed := TRUE + | msg: Properties.FocusPref DO + msg.hotFocus := TRUE +(* + | msg: Properties.StorePref DO + msg.view := NIL +*) + | msg: TextSetters.Pref DO + c := v.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); font := a.font + ELSE + font := Fonts.dir.Default() + END; + font.GetBounds(asc, msg.dsc, w) + ELSE + END + ELSE + END + END HandlePropMsg; + + + (* StdDirectory *) + + PROCEDURE (d: StdDirectory) New (err: INTEGER): View; + VAR v: StdView; + BEGIN + NEW(v); v.InitErr(err); RETURN v + END New; + + PROCEDURE (d: StdDirectory) NewMsg (msg: ARRAY OF CHAR): View; + VAR v: StdView; + BEGIN + NEW(v); v.InitErr(noCode); v.InitMsg(msg); RETURN v + END NewMsg; + + + (** Cleaner **) + + PROCEDURE Cleanup; + BEGIN + globR := NIL; globW := NIL + END Cleanup; + + + (** miscellaneous **) + + PROCEDURE Insert* (text: TextModels.Model; pos: INTEGER; v: View); + VAR w: TextModels.Writer; r: TextModels.Reader; + BEGIN + ASSERT(v.era = 0, 20); + Models.BeginModification(Models.clean, text); + v.era := thisEra; + IF pos > text.Length() THEN pos := text.Length() END; + globW := text.NewWriter(globW); w := globW; w.SetPos(pos); + IF pos > 0 THEN DEC(pos) END; + globR := text.NewReader(globR); r := globR; r.SetPos(pos); r.Read; + IF r.attr # NIL THEN w.SetAttr(r.attr) END; + w.WriteView(v, Views.undefined, Views.undefined); + Models.EndModification(Models.clean, text); + END Insert; + + PROCEDURE Unmark* (text: TextModels.Model); + VAR r: TextModels.Reader; v: Views.View; pos: INTEGER; + script: Stores.Operation; + BEGIN + Models.BeginModification(Models.clean, text); + Models.BeginScript(text, "#Dev:DeleteMarkers", script); + r := text.NewReader(NIL); r.ReadView(v); + WHILE ~r.eot DO + IF r.view IS View THEN + pos := r.Pos() - 1; text.Delete(pos, pos + 1); r.SetPos(pos) + END; + r.ReadView(v) + END; + INC(thisEra); + Models.EndScript(text, script); + Models.EndModification(Models.clean, text); + END Unmark; + + PROCEDURE ShowFirstError* (text: TextModels.Model; focusOnly: BOOLEAN); + VAR v1: Views.View; pos: INTEGER; + BEGIN + globR := text.NewReader(globR); globR.SetPos(0); + REPEAT globR.ReadView(v1) UNTIL globR.eot OR (v1 IS View); + IF ~globR.eot THEN + pos := globR.Pos(); + TextViews.ShowRange(text, pos, pos, focusOnly); + TextControllers.SetCaret(text, pos); + v1(View).SetMode(v1(View).mode) + END + END ShowFirstError; + + + (** commands **) + + PROCEDURE UnmarkErrors*; + VAR t: TextModels.Model; + BEGIN + t := TextViews.FocusText(); + IF t # NIL THEN Unmark(t) END + END UnmarkErrors; + + PROCEDURE NextError*; + VAR c: TextControllers.Controller; t: TextModels.Model; v1: Views.View; + beg, pos: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF c # NIL THEN + t := c.text; + IF c.HasCaret() THEN pos := c.CaretPos() + ELSIF c.HasSelection() THEN c.GetSelection(beg, pos) + ELSE pos := 0 + END; + TextControllers.SetSelection(t, TextControllers.none, TextControllers.none); + globR := t.NewReader(globR); globR.SetPos(pos); + REPEAT globR.ReadView(v1) UNTIL globR.eot OR (v1 IS View); + IF ~globR.eot THEN + pos := globR.Pos(); v1(View).SetMode(v1(View).mode); + TextViews.ShowRange(t, pos, pos, TextViews.focusOnly) + ELSE + pos := 0; Dialog.Beep + END; + TextControllers.SetCaret(t, pos); + globR := NIL + END + END NextError; + + PROCEDURE ToggleCurrent*; + VAR c: TextControllers.Controller; t: TextModels.Model; v: Views.View; pos: INTEGER; + BEGIN + c := TextControllers.Focus(); + IF (c # NIL) & c.HasCaret() THEN + t := c.text; pos := c.CaretPos(); + globR := t.NewReader(globR); globR.SetPos(pos); globR.ReadPrev; + v := globR.view; + IF (v # NIL) & (v IS View) THEN ToggleMode(v(View)) END; + TextViews.ShowRange(t, pos, pos, TextViews.focusOnly); + TextControllers.SetCaret(t, pos); + globR := NIL + END + END ToggleCurrent; + + + PROCEDURE SetDir* (d: Directory); + BEGIN + dir := d + END SetDir; + + + PROCEDURE Init; + VAR d: StdDirectory; + BEGIN + thisEra := 1; + NEW(d); dir := d; stdDir := d + END Init; + +BEGIN + Init; Kernel.InstallCleaner(Cleanup) +CLOSE + Kernel.RemoveCleaner(Cleanup) +END DevMarkers. diff --git a/Trurl-based/Dev/Mod/Selectors.txt b/Trurl-based/Dev/Mod/Selectors.txt new file mode 100644 index 0000000..81d265f --- /dev/null +++ b/Trurl-based/Dev/Mod/Selectors.txt @@ -0,0 +1,411 @@ +MODULE DevSelectors; + + (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Selectors.odc *) + (* DO NOT EDIT *) + + IMPORT + Ports, Stores, Models, Views, Controllers, Fonts, Properties, TextModels, TextViews, TextSetters; + + + CONST + left* = 1; middle* = 2; right* = 3; + + minVersion = 0; currentVersion = 0; + + changeSelectorsKey = "#Dev:Change Selectors"; + + + TYPE + Selector* = POINTER TO RECORD (Views.View) + position-: INTEGER; (* left, middle, right *) + leftHidden: TextModels.Model; (* valid iff (position = left) *) + rightHidden: TextModels.Model (* valid iff (position = left) *) + END; + + Directory* = POINTER TO ABSTRACT RECORD END; + + StdDirectory = POINTER TO RECORD (Directory) END; + + + VAR + dir-, stdDir-: Directory; + + + PROCEDURE (d: Directory) New* (position: INTEGER): Selector, NEW, ABSTRACT; + + + PROCEDURE GetFirst (selector: Selector; OUT first: Selector; OUT pos: INTEGER); + VAR c: Models.Context; rd: TextModels.Reader; v: Views.View; nest: INTEGER; + BEGIN + c := selector.context; first := NIL; pos := 0; + WITH c: TextModels.Context DO + IF selector.position = left THEN + first := selector + ELSE + rd := c.ThisModel().NewReader(NIL); rd.SetPos(c.Pos()); + nest := 1; pos := 1; rd.ReadPrevView(v); + WHILE (v # NIL) & (nest > 0) DO + WITH v: Selector DO + IF v.position = left THEN DEC(nest); + IF nest = 0 THEN first := v END + ELSIF v.position = right THEN INC(nest) + ELSIF nest = 1 THEN INC(pos) + END + ELSE + END; + rd.ReadPrevView(v) + END + END + ELSE (* selector not embedded in a text *) + END; + ASSERT((first = NIL) OR (first.position = left), 100) + END GetFirst; + + PROCEDURE GetNext (rd: TextModels.Reader; OUT next: Selector); + VAR nest: INTEGER; v: Views.View; + BEGIN + nest := 1; next := NIL; rd.ReadView(v); + WHILE v # NIL DO + WITH v: Selector DO + IF v.position = left THEN INC(nest) + ELSIF nest = 1 THEN next := v; RETURN + ELSIF v.position = right THEN DEC(nest) + END + ELSE + END; + rd.ReadView(v) + END + END GetNext; + + PROCEDURE CalcSize (f: Selector; OUT w, h: INTEGER); + VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER; + BEGIN + c := f.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); + font := a.font + ELSE font := Fonts.dir.Default(); + END; + font.GetBounds(asc, dsc, fw); + h := asc + dsc; w := 3 * h DIV 4 + END CalcSize; + + PROCEDURE GetSection (first: Selector; rd: TextModels.Reader; n: INTEGER; OUT name: ARRAY OF CHAR); + VAR i, p0, p1: INTEGER; ch: CHAR; sel: Selector; + BEGIN + sel := first; + IF first.leftHidden.Length() > 0 THEN + rd := first.leftHidden.NewReader(rd); rd.SetPos(0); + REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL); + IF sel = NIL THEN INC(n) END; + p1 := rd.Pos() - 1 + END; + IF n >= 0 THEN + rd := first.context(TextModels.Context).ThisModel().NewReader(rd); + rd.SetPos(first.context(TextModels.Context).Pos() + 1); + REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL) OR (sel.position = right); + p1 := rd.Pos() - 1 + END; + IF (n >= 0) & (first.rightHidden.Length() > 0) THEN + rd := first.rightHidden.NewReader(rd); rd.SetPos(1); + REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL); + p1 := rd.Pos() - 1; + IF sel = NIL THEN p1 := first.rightHidden.Length() END + END; + IF n < 0 THEN + rd.SetPos(p0); rd.ReadChar(ch); i := 0; + WHILE (ch <= " ") & (rd.Pos() <= p1) DO rd.ReadChar(ch) END; + WHILE (i < LEN(name) - 1) & (rd.Pos() <= p1) & (ch # 0X) DO + IF ch >= " " THEN name[i] := ch; INC(i) END; + rd.ReadChar(ch) + END; + WHILE (i > 0) & (name[i - 1] = " ") DO DEC(i) END; + name[i] := 0X + ELSE + name := 7FX + "" + END + END GetSection; + + + PROCEDURE ChangeSelector (first: Selector; rd: TextModels.Reader; selection: INTEGER); + VAR pos, p0, len, s: INTEGER; text: TextModels.Model; sel: Selector; + BEGIN + text := rd.Base(); + pos := first.context(TextModels.Context).Pos() + 1; + (* expand *) + rd.SetPos(pos); + REPEAT GetNext(rd, sel) UNTIL (sel = NIL) OR (sel.position = right); + IF sel # NIL THEN + len := first.rightHidden.Length(); + IF len > 0 THEN text.Insert(rd.Pos() - 1, first.rightHidden, 0, len) END; + len := first.leftHidden.Length(); + IF len > 0 THEN text.Insert(pos, first.leftHidden, 0, len) END; + IF selection # 0 THEN (* collapse *) + rd.SetPos(pos); s := 0; + REPEAT GetNext(rd, sel); INC(s) UNTIL (s = selection) OR (sel = NIL) OR (sel.position = right); + IF (sel # NIL) & (sel.position = middle) THEN + first.leftHidden.Insert(0, text, pos, rd.Pos()); + rd.SetPos(pos); GetNext(rd, sel); + p0 := rd.Pos() - 1; + WHILE (sel # NIL) & (sel.position # right) DO GetNext(rd, sel) END; + IF sel # NIL THEN + first.rightHidden.Insert(0, text, p0, rd.Pos() - 1) + END + END + END + END; + rd.SetPos(pos) + END ChangeSelector; + + PROCEDURE ChangeThis ( + text: TextModels.Model; rd, rd1: TextModels.Reader; title: ARRAY OF CHAR; selection: INTEGER + ); + VAR v: Views.View; str: ARRAY 256 OF CHAR; + BEGIN + rd := text.NewReader(rd); + rd.SetPos(0); rd.ReadView(v); + WHILE v # NIL DO + WITH v: Selector DO + IF v.position = left THEN + GetSection(v, rd1, 0, str); + IF str = title THEN + ChangeSelector(v, rd, selection) + END; + IF v.leftHidden.Length() > 0 THEN ChangeThis(v.leftHidden, NIL, rd1, title, selection) END; + IF v.rightHidden.Length() > 0 THEN ChangeThis(v.rightHidden, NIL, rd1, title, selection) END + END + ELSE + END; + rd.ReadView(v) + END + END ChangeThis; + + PROCEDURE Change* (text: TextModels.Model; title: ARRAY OF CHAR; selection: INTEGER); + VAR rd, rd1: TextModels.Reader; script: Stores.Operation; + BEGIN + rd := text.NewReader(NIL); + rd1 := text.NewReader(NIL); + Models.BeginModification(Models.clean, text); + Models.BeginScript(text, changeSelectorsKey, script); + ChangeThis(text, rd, rd1, title, selection); + Models.EndScript(text, script); + Models.EndModification(Models.clean, text); + END Change; + + PROCEDURE ChangeTo* (text: TextModels.Model; title, entry: ARRAY OF CHAR); + VAR rd, rd1: TextModels.Reader; str: ARRAY 256 OF CHAR; v: Views.View; sel: INTEGER; + BEGIN + rd := text.NewReader(NIL); + rd1 := text.NewReader(NIL); + rd.SetPos(0); rd.ReadView(v); + WHILE v # NIL DO + WITH v: Selector DO + IF v.position = left THEN + GetSection(v, rd1, 0, str); + IF title = str THEN + sel := 0; + REPEAT + INC(sel); GetSection(v, rd1, sel, str) + UNTIL (str[0] = 7FX) OR (str = entry); + IF str[0] # 7FX THEN + Change(text, title, sel); + RETURN + END + END + END + ELSE + END; + rd.ReadView(v) + END + END ChangeTo; + + + PROCEDURE (selector: Selector) HandlePropMsg- (VAR msg: Properties.Message); + VAR c: Models.Context; a: TextModels.Attributes; asc, w: INTEGER; + BEGIN + WITH msg: Properties.SizePref DO CalcSize(selector, msg.w, msg.h) + | msg: Properties.ResizePref DO msg.fixed := TRUE; + | msg: Properties.FocusPref DO msg.hotFocus := TRUE; + | msg: TextSetters.Pref DO c := selector.context; + IF (c # NIL) & (c IS TextModels.Context) THEN + a := c(TextModels.Context).Attr(); + a.font.GetBounds(asc, msg.dsc, w) + END + ELSE (*selector.HandlePropMsg^(msg);*) + END + END HandlePropMsg; + + PROCEDURE Track (selector: Selector; f: Views.Frame; x, y: INTEGER; buttons: SET; VAR hit: BOOLEAN); + VAR a: TextModels.Attributes; font: Fonts.Font; c: Models.Context; + w, h, asc, dsc, fw: INTEGER; isDown, in, in0: BOOLEAN; modifiers: SET; + BEGIN + c := selector.context; hit := FALSE; + WITH c: TextModels.Context DO + a := c.Attr(); font := a.font; + c.GetSize(w, h); in0 := FALSE; + in := (0 <= x) & (x < w) & (0 <= y) & (y < h); + REPEAT + IF in # in0 THEN + f.MarkRect(0, 0, w, h, Ports.fill, Ports.hilite, FALSE); in0 := in + END; + f.Input(x, y, modifiers, isDown); + in := (0 <= x) & (x < w) & (0 <= y) & (y < h) + UNTIL ~isDown; + IF in0 THEN hit := TRUE; + font.GetBounds(asc, dsc, fw); + f.MarkRect(0, 0, w, asc + dsc, Ports.fill, Ports.hilite, FALSE); + END + ELSE + END + END Track; + + PROCEDURE (selector: Selector) HandleCtrlMsg* ( + f: Views.Frame; VAR msg: Views.CtrlMessage; VAR focus: Views.View + ); + VAR hit: BOOLEAN; sel, pos: INTEGER; text: TextModels.Model; title: ARRAY 256 OF CHAR; first: Selector; + BEGIN + WITH msg: Controllers.TrackMsg DO + IF selector.context IS TextModels.Context THEN + Track(selector, f, msg.x, msg.y, msg.modifiers, hit); + IF hit THEN + text := selector.context(TextModels.Context).ThisModel(); + GetFirst(selector, first, pos); + IF first # NIL THEN + GetSection(first, NIL, 0, title); + IF selector.position = middle THEN sel := pos ELSE sel := 0 END; + Change(text, title, sel); + text := selector.context(TextModels.Context).ThisModel(); + IF TextViews.FocusText() = text THEN + pos := selector.context(TextModels.Context).Pos(); + TextViews.ShowRange(text, pos, pos+1, TRUE) + END + END + END + END + | msg: Controllers.PollCursorMsg DO + msg.cursor := Ports.refCursor; + ELSE + END + END HandleCtrlMsg; + + PROCEDURE (selector: Selector) Restore* (f: Views.Frame; l, t, r, b: INTEGER); + VAR w, h, d: INTEGER; + BEGIN + selector.context.GetSize(w, h); +(* + GetFirst(selector, first, pos); +*) + w := w - w MOD f.unit; d := 2 * f.dot; + f.DrawLine(d, d, w - d, d, d, Ports.grey25); + f.DrawLine(d, h - d, w - d, h - d, d, Ports.grey25); + IF selector.position # right THEN f.DrawLine(d, d, d, h - d, d, Ports.grey25) END; + IF selector.position # left THEN f.DrawLine(w - d, d, w - d, h - d, d, Ports.grey25) END + END Restore; + + PROCEDURE (selector: Selector) CopyFromSimpleView- (source: Views.View); + BEGIN + (* selector.CopyFrom^(source); *) + WITH source: Selector DO + selector.position := source.position; + IF source.leftHidden # NIL THEN + selector.leftHidden := TextModels.CloneOf(source.leftHidden); + selector.leftHidden.InsertCopy(0, source.leftHidden, 0, source.leftHidden.Length()) + END; + IF source.rightHidden # NIL THEN + selector.rightHidden := TextModels.CloneOf(source.rightHidden); + selector.rightHidden.InsertCopy(0, source.rightHidden, 0, source.rightHidden.Length()) + END + END + END CopyFromSimpleView; + + PROCEDURE (selector: Selector) InitContext* (context: Models.Context); + BEGIN + selector.InitContext^(context); + IF selector.position = left THEN + WITH context: TextModels.Context DO + IF selector.leftHidden = NIL THEN + selector.leftHidden := TextModels.CloneOf(context.ThisModel()); + Stores.Join(selector, selector.leftHidden); + END; + IF selector.rightHidden = NIL THEN + selector.rightHidden := TextModels.CloneOf(context.ThisModel()); + Stores.Join(selector, selector.rightHidden) + END + ELSE + END + END + END InitContext; + + PROCEDURE (selector: Selector) Internalize- (VAR rd: Stores.Reader); + VAR version: INTEGER; store: Stores.Store; + BEGIN + selector.Internalize^(rd); + IF rd.cancelled THEN RETURN END; + rd.ReadVersion(minVersion, currentVersion, version); + IF rd.cancelled THEN RETURN END; + rd.ReadInt(selector.position); + rd.ReadStore(store); + IF store # NIL THEN selector.leftHidden := store(TextModels.Model) + ELSE selector.leftHidden := NIL + END; + rd.ReadStore(store); + IF store # NIL THEN selector.rightHidden := store(TextModels.Model) + ELSE selector.rightHidden := NIL + END + END Internalize; + + PROCEDURE (selector: Selector) Externalize- (VAR wr: Stores.Writer); + BEGIN + selector.Externalize^(wr); + wr.WriteVersion(currentVersion); + wr.WriteInt(selector.position); + wr.WriteStore(selector.leftHidden); + wr.WriteStore(selector.rightHidden) + END Externalize; + + + PROCEDURE (d: StdDirectory) New (position: INTEGER): Selector; + VAR selector: Selector; + BEGIN + NEW(selector); + selector.position := position; + RETURN selector + END New; + + PROCEDURE SetDir* (d: Directory); + BEGIN + ASSERT(d # NIL, 20); + dir := d + END SetDir; + + + PROCEDURE DepositLeft*; + BEGIN + Views.Deposit(dir.New(left)) + END DepositLeft; + + PROCEDURE DepositMiddle*; + BEGIN + Views.Deposit(dir.New(middle)) + END DepositMiddle; + + PROCEDURE DepositRight*; + BEGIN + Views.Deposit(dir.New(right)) + END DepositRight; + + + PROCEDURE InitMod; + VAR d: StdDirectory; + BEGIN + NEW(d); dir := d; stdDir := d; + END InitMod; + +BEGIN + InitMod +END DevSelectors. + + + "Insert Left" "*F5" "DevSelectors.DepositLeft; StdCmds.PasteView" "StdCmds.PasteViewGuard" + "Insert Middle" "*F6" "DevSelectors.DepositMiddle; StdCmds.PasteView" "StdCmds.PasteViewGuard" + "Insert Right" "*F7" "DevSelectors.DepositRight; StdCmds.PasteView" "StdCmds.PasteViewGuard" diff --git a/Trurl-based/Dev/Rsrc/Errors.odc b/Trurl-based/Dev/Rsrc/Errors.odc new file mode 100644 index 0000000000000000000000000000000000000000..b694ea0fe7f97e9860e7b757a699e539428f0fa8 GIT binary patch literal 10095 zcmbVSOK&7s748WTD3JmLM6f{UVv@*CY)`)*lb1YpC$Z#dM|RIlhA2qo?&|K!R9AKC zF`h;Qq-2c*t1Lm{7qDOjLM&OZX2q5r3-AiDf$yCAY`Z;!ux7fu>YjVv>5A)gD@XeoT1hG`)N`HQ4(hP?!72Hm&EkTx&Fs#k!B$= z#TQf1a`g8_{Qvt){PR<1i96{yj3q0FzjK#==DW@vwM0J-=REP^^USqUxdrwfe%IwP zw9R4oxR4@Zn^tOj+uXZ&MscAp685hz@{LcKhmrzJ96^Z774a^fN9o)Y0$%W6O_Tx#~`Z-VLHR$8U&%m$p zJ^Jp#yNMR_68i8wwBvosO?EK4&nDCfA$eP7+3 zN24swmw6G+b0O;8T~WusYPI3}wOw(TjM6L%M};W!ka)#GGA)B?sF?b`5LK^C#^ERq zvT!V-G2AnnL}7-Jnl~@wB3i^tF%Bni!b{_IFN))E8pL8W3$kETgqesEk+6uE-&jAM z!~Bvd#+#m9PK?tq7fD)(c~FdIVv(hza9n1gNP>9?;+8i`=M+4cXcVV;IL7U^hmQ_@ zbm^n#ZM?oA!p95j8RNC8=htfZU-ydTB9z;RiU{h=iy$js|SWl*Gc~Zv#FFr}*I6a3x&z5TzZ+mx+5AGiIoqb@3HEghk{q1gu zd6eg*!g|%)*mf>!-o`EGvhMlyhPSch+-iCoA2^pSZ{uUq|x^Fj|Zp2Z83cCZhu?c+dJ77@17j* z_Ydx#;QDs|?Zd$~&FT*h%xaB}_jH=B$CIzj?RkC^irTarZPv79!nEf>_Hfm*n|0V) zg7Z|y79=>NBAmi0nho#nV0d_BBx^#Ww_tMmNSZCI*7o}E9S+%0$-dwdahfj3LZq$u z%?=EQyud1^*>%0a=&Oknf7P;YRXq$L+2w4*v$Tw1M4`~~`mLJhDy{_|H7;#^47buE z6oDYG@LO=yClMilq}f=}Ha)D4u)voTQmm&&(t!hU7Ua=L(YHKHFbd+BrUYVACL{6$ zzt#2vY-XCU4;3ktmh3zVkaW&sNY?QdDd|3AWuB!7RRTmxB3Ma~Wx-M{)rDxIGRvb! zp_GoJ7Q4IO>ggjF=^{+jyamG6JOq2cUG>fpWv6CaqW}>z4$i{ZZ^K-YV9ZAhsn(Lf zWXuE;E$6@^qL{&c(qt6+Z5t3D1#!s%*&JNE=`lINPKk)hvnFXa$8RHL?zdasBs_;Y zoGeKfa6BE5I4o)KwCf-epE)3xPn~o z2R0DG0y4i-Gc&b25t-VWC969YswFX&7U-2=w#6(IIqXH`BkbPqG%in^1+ct0d=$o_ z>UWyXaG5+z(sPO<Dh;r<@HG@q5V!5X(tPDs38mx_!R7`*ZVT!yr_qzy5YAL!;egm}uTEv`pl8|zI+BWXCYQi3!-&X31b^~XJq1CG zu3*GFH05xxV|_sG((iUX$Fm3zA!agEfaz-H+uA5uC&Ws6weoqt+w=AY4^H~~$0x|4 zh>yev&PS|9$U$SjSACiqEu>@Keh=xrS0~{z3LelIypZKHXU}PyZ;3oC{9ePumv94- zbI>{v^qMZumox>r8zHva$Hzzgy@B6rxn##D*V45O9ZRxU#LPGM9tHdmysPUdso#6GT?kYl&U~iPiF2k{ys(4X-76 zoy_+8ptCAoOP7T)V`fnHycBUgi#P=#ZO_uN$t#FSX~vKrm|q{QaarPwLcl5-`Fusk zn-pfZEG(&^Vz|OZyB|0qle_0@Aq>W-C}37d{wl zd$NLJaHYxet8|?eB(_>VflZf?B6Pw4_tI=x_5c8!Q-E|T6U^&@tp!d9osS8S04O8q zBZmM?nEWI|I(e2&YBdxke30;9CsD|Xhp@xpTifFPJBLRA`w~jS4wUz(^U^+FtJi?4 zP-0$9Tt)Xl>-3A`AeasC-8;{ zO|xYMj-8!LPz89BrE`LH%+-~@WhOI(bf!8vP8gn`Z1*?XDLt3P6hznQ+ItbyT*mp)fUb$-Nl3)=-~H!FTmy5MJVW z3LmIXmAH1fDn%QR7tc@?WI~}|LwWl!lr0e)KAKv|Xh~sEpPiVeV{{rpNGNl) zX(J{PkJLTc#Nq2TlUY*}!lGb0A?>Q1h2(QZOy)#Zo5ri>U4?@C()HEkQ^szXhZa^1mL z5N6jVe646~sJ6U=Gn^=jAW%{k)0EO8*OH--QAPL_`DlY5m0?Es-tv;^7PYGG4^B&} zaa2zQ3%9+!@%SX1h?m3(@F7)14opSxz}cV*)zfWyr6BP>H2Q&SHK;db?f!lgjXw}O zh9UyGLZPXpR^=sYPg^mL0Ob>)ELBp*qRFSVLI~}05P)t`PZ^nX7aezdo>r=mu!N5d zftewR;iToz18C{t^i>O0dp`$mjMO}nQ#I^VRzZ!C8mg$(T5&B=1OA%qFtAX~CP;+I zP0uvOZJ3sgS8j;v@V|l#P*ABZm!Pl|SOuV7(%ZN^((%at!}+2h0HJ%jh!_wI_<&0= zLda6v5RG7qx%)rOu$>(v5;dfgDb$2IM{+i>FemN`J!JQhuhjFf z50pHH3MLds^9Y#K8o;_ztcD5*Q8h17k8m46hgHgl%2z4pUD6?~*77djG;YKpfs&z# zuCPfmY9uE_V`O54Ua)98O$xvbv)>)|2WzP)m`qS2r`KC!1f`XyZh|d9{aK#IXsw~= zz>hCvOy~i_UmDQq+xPM0;)pcHp_5(6h{Lx)fx?Oc-V$}C8AGtBqlTg?Ia7!f0#fOT z!VP#~icSfloNTGhqA8W++>5|8BnziRU7@_Q_ul4df4D_zi_vhE^Q)Kyui{4>7L(v6 zcYDT2{wsIU_KzM#jAPL1{}D6+(zchEfPz#V5TL=G4#=qWMqQef0q7AW&jfoTQ$t&{ zm?6TTe9ULjq`=Ic>^sVxIxJBIjqsFHGD8jG*HQg^Sk4y$=?tCi)pbzqXa|O}(4(c= znESJJlsd$A9wbY2sd6MK2*N?RO(~Blc zr$m5+sC+CnHVqMy=?*8Kr%xux=GcT#(9f7x9Tkz@q-nnz?+{|MDqeeCEW~R9V0a7C z*tqf(@;0bZ^<2*!!!@f#l}uTYy1fVrfI6+`X`G%>-&bbc9D~jwsCY*HL?b9Y^faBN z^^ncKct9v7aR4izszK9h?{)$j2s)Mk>XaEw!Y*2_Ye&s=gAj?JX9*IZUnlxeQk5L> zSPDg=7DMBLTx^09P8@|eY)nDDIw}Q28b`@PQE)p4y=|Zl%%QN9C8RE$UUHlVN(eKH z9vmWzv%(G6hE5DNtj+M)Gss3WJWqgZ6e++5)tMF)bNSI|j^}Cs?y_J6>_TV(303;I zU%OoWCq@s zU0uYZ0=Mg?A*;2B&7$Lujy(=*Cq#(l$HEQSEYnrVCJa+cq>Iokf~)lA3CUy}5puM| z9*k{?Q0_?7qr8N^KPo}Ou004SFS!p2x#%|JfD1qt>WxAI$~<@t0|kOJu_;Mqvlr26 zn~o<(6HzvC<=mDR#CfXvHjKQf+m6-cgNYt8OfW({k>6ZJ&U^s#a2!FY5P=#iQ-<;Y3ro>XBRX<4vP;782=(&j{i%M&MpNCLrSy(wW3% zS|X=Xk5>;hxZ8tAsnc13&7u54;|C~_!Y^kds1C&jBd=;`Xw@<4a^het!bi)5PJN>6?zV-2x=VBU)9z(-S5ASQ1l!wy&FF!VYgH2XW(i zV&#iw4v{ynA=ln^Ig$BIXx%7V*G&xg&O$1+S#X$P6K6p6dX}aWj+qku;l54x9DHfd zI7LFA7;G4re`Qd8|F;ia6fsLKG~^j^>ddHw0d*VF)g(Mv*as_RcKzOH`huk~*N{q3hWD)c7M zul{nwyb1LGyaS|HdG2483jhCXQF-pgSKn~oiMzb*=k+A@P4e>}@BfcKoK?Di{)N6* I(bqTr3muN-&Hw-a literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Rsrc/Strings.odc b/Trurl-based/Dev/Rsrc/Strings.odc new file mode 100644 index 0000000000000000000000000000000000000000..0924ba1fcdfa39d49c4d7414e6555a6308b977d9 GIT binary patch literal 6103 zcmai2Pmg3b5$^>A7{!7EA_%0&D-mr1!)!LoVYNs|Gd(k#CNtZ^bZ;UNDbnlr+|!SF zZFipi<`3e4HeY}P2Lw0v$c+;xJ`cxaP8^WnS7rOX*WI(CrG73~mCNOFxvK2p!PpM) zd->&o&6}k*-tA6&kva$3<%1q+9Y3_jXQk1#+x@82SAm(JUjK`Ux3wmrXqbbhqu)31 zpT5c9=e;RTY@w?lswcmPWzg;RFmZ~*N-uff?blf9VDQ)P4F&@6pV9K~<(E@^?SqO~ zW~X(BZgIC?iG!#iWeKTVKgf;)u6mJGe){UR`F@;CKJz&fpK++{YC6Uf#;Y7~3DDJ~RDzW6Dr%U^#$BOgr16Bd7vxp zbs~mdOFXvc0)L7BM0;PFb4PuZIua&nD*fF0BioolEV+w06?9T_!pY}$uPU{nJrl;N zj5_KPJy1qoFP~>iJ%JLr*99?@z$pWyauEy0IL`)aoNkkOn$_nT8s&`(YC)=J98?0b zRg8Rrtk!V>k<7NnMcS`((F$4?KQ`43bfmR75%eytQEp+Is!$eGm4}n4dP+O2EG!+& zt@v*EJQ{EU!(*5FJPFgPFlq7yne*^^W$V5vKYgTh#Ho30m*f$c7VL-D{{N4#HHLd_ z9IdAt&nqU|g(dR}+23e09L>lZs!AAvw-LkT1P8~QL&LDyj=L?d995M*&#Dhgcv2Z) zb(vL-#v*HV0kk}=^}M{ET02=_mBKYMcjL%mR!mT(Q{Gy#d+pUb(fl*59`EixQTZaP zGq_pp-i^m*T4%;pnb!i_Lpw!o3wEFIMN(>VgE)HKs+gUqj_~z`i07~Rq3-z zVdrSh9jv0N>{TGTWmdH$h2<6HdFe^9MP|;m2#tJUDw`EBnrIS4`}e|J7<*-a0@-!+pt4PKw!{$|D@n#6)0A z_&{eX)^86xn8RNRu>eX1O|g>!`Bch@ZR#98+6#)VMX?{R1;?4HI72pvCD@-drADy=Mi))3dBKs80#!NzdqsgF!L>&q z3;m}mF`U}cz|mWVRp_hx_wQp#1&m^_P^5$aVPJIQBU>*spPZSDgf7UE%s!s|2Cgay zQ~{PBWyqoTjg_E}e6cDhdV~h#*}8{xJYqOY8N-(~tlw?nFYnnnY|7ks+xc z$EM{;1j8#tM(iO@U^EzF-xWp0fK-;v$ehnAJIkt8wqVY4Mk3rs(=ump=2PoRPluQp zgEiDDBAM?@&vmU0rs_|Qh#awL_F$%u5y0hiotFycY{vHdfrp0B|H*m<@w?+%KPF3YbX^0n!ZEgV{w`}cV%mY$YiSH(s^11 zwd;$Bl%UFl%Y$xMTY%8mwzDpvMT6&VDL5}POA;7ZADw8g8JUHhABMJ5EF$hQV2`wA z!e_N@R)W8stZA)vG}PT%Y%n~66^(YU74W_YKJj{v$3eow$fq)|YHNF2y)om@#F4EE zU8^#;#-UUyrX1sTquQdwFhPzh9kL@|?8Nx^FvUmI^q2d!y+YN$J6cjXIJsF;DimmE zwt}BldYfs8TOD%|5P0O$>0Hn!W^EB-jy%=Ka>k@Vg=E{6} zv(m!jqwJinCa4jq%*)h_sER0HP4SR2am$gyVW3lDr5g&cS&96!bxZkGgWF93yAaoB z)R~t^LsZ^uUuIJAvz@@{Mir+D2Hld-2Ii5O+mWH^HsUfe`5bpC6RZ7Hf{*KAR%_O; zEz7C;%n6HCQWzs?9<7vnRjsq)=I|O31t~FHEpy;J){{!_9Td!YhWZI5EYc0$5N>eE zSB3gL8F3m(UJFG48@~>4wZr!3+CD)p5XwX}d~2s?nC{Y2`V2Ev^D9 zs^=Y)FZk_1pjC8z;~aXa3FQ2GsRLTFlT7#;;c!CeI3InU@}? zak<1bMrX@VBTR>Jf zq2D91W|)K95mjBt^!V=Zl6o?aa1eq_hPuhP)Mbebb%c>AJ*i2`;ht6PC(kUAS=x@e?#uHI@V`m=`0 z5Dfm9%ZeV2_PuXiHeE36j@sgm2-abXi0~R?OpRjW@<7j;o_VO64U-WRqjv?Jx;1or z+&Kg}9J$6i7rRJ*JJ!j`JV{JPJ)sL~&#=x#gI3-_E|RFw24X6V2rO_BSxA+HV_|IP!_;o+I9^M_=r2RrHkjZhEOnMNGR z^@Df&V%kd=KdsQo%&)I4Az^Q6Z2El@z^`LxO`+GluBL%MA|O1b0#L7lknewSZ}21!ghbqaU~OM! zS=e1KvrNF}jem##&R;$myz%zWf6;$?-`I=W@1#MorKRzY4Zq0U;K>hP4SxThZ}I)4H(#L*~@CE1l|Qa>zuDN!Pql*CFRS&??o1~9PP9g~QI*r9keT zd+#~-{J!U&xvTc-X57HfXFp$!yQ9Nsn5DDZS+96ljnZzTGBnxWj)z&NKa7%e_LF|} z)F!i4dH!NMi<5{*@u3-9jz7PK-#1s({JgTn!?+g>3{?exrB}^#w$hU?u{MYf1^E0G zVQnqNLI|;(An*Ct zb3Ef)jmB@G{S$oZ=cRxACO(a(9BetulK$=}i_%F>uH+!!&OaM3vGIQ6tuNGQ{Fy#} zy%=r0KYDZLAHJUBel!|TN1#vUA5!&c{$R}J^G{>80KCA4@rOqE(?8MxSzhSc00&=cgm1si5j}kNJkYF0<9z;^ zi|jA#u`V*2$IA}%U#9^5)+TC#DA83 zzbsq-Q?@iu_%!c3#P=`ds4%})_Wdqfj_))qFA1N(e6lY@A~i*_`tyEzVP)<~e0!Ypk$muxktg$BcrT)#og^%kYk;A)joa%uB~g%_qu%GRw3i0ucls!$VVGN!^MqNWPL()kEUDmg3HdyFs7cbX z2v+!@?bL4%_ zhx(*9my2VO)TDFo^Oj?#uQr6mntxHH!lkdCy zM2j#>8XpmhQ=oYobu8Q=lvvwp+_xHnWkfO?QcJwaItAezspS&V8nP0fC#q^T=@dAu z`sDj=FTyu1f{0S*+~*1Q)R^cxa!RLRaSPL^?AiNV=QZhyOJBozlcpsr$LA7q%l1BD zk;SS{9M!OJ2Q$mjyxOQNr`9J5YSNV?-E!2@K}Y(i*@5~5AuNZbl?bzJ*SW0e+(*?? zRCZe2XIyGNDydDg4Xx&y(L8yN!}_|SUOuSRYT6R4vRB6^EvQeU%wBEp5iRnRTEx^E z!t84ZwzgVr)OQGZnP^r^u;S9?A{~8~v}m5F62Bf#nLXI3Fl$u!w60?o^;(0+6oXh~ zOMUmtmMD-kJ}mnjLZjkbeeNIX(-Be>$eM&%+INoBr`V)5M6-{oPkM8Ia~%nD4PR|H z5CvL8SVW(!#PLazwMZk(@~zrx;#Ux&dD^Jt?DG^8r_FN@6@Rr_O`Lml zbQx&f1@fzT${F0+ohtPSv-kOGHGFf#=kt72e8@W8!bFv%>-32h#canit)+RgU8lvR zE4#17$=WE-OchEs>QTyNuXyG3dF1kST|&;Adw|2LrI_d$sE>-~nw>hAvKLY1-mN~# zO6%&Zp;1LR=hw9$pHVE4J~YpzD+)r&#W@lLOE>ktAFxmKi7Ka0SXk`(a(m~|`o`Vu z;N{@LYV_p2_SR0&Ps3rHh240V_R|ct*1>VuKRk+)Eb28cg$v^w<6GmU@$K=-cmaQx z#+S!)25zDibPqbi{iqiX`nyRdIS%&*o&Dy*_&ShX12BKX zRRLZZhx0%@kB0?7u3)T%mXQ?>VxURF{xD3B4|n51xYr*CpJ z4YF?MM3p$c5>VtvPfrp~x-O6JgQypwc?c9$#w*Zuc7?KFH!$@sgTvz=M@du4E}nu< zmLG*%ouqRZK?qGg-GZ2I^nL-FYEu8S zggFfx>CjT}C`zL&+&s$qMEE*Dm+@}}^GqKLXg>h5&XcH|br!SMgp15;{6XC5mE+$6 z^c9S^VPN@quAk;>KsyJC()QfrgyP&Cyxf?boo!wK=mI!i8RIF}_WCeAf^YVUl}d%4{@AA)ns zgF%>%cGF|TLfHN5&@?QZ5%4OS3sSrpKEyMKcRPcS@1MfXuovQWN!aTrP(qyaqZCxm zW63#kPZ_m9L*XQIg;-#h^ggHt$cZ61w_PmXlA%woOAWLSqVD66B-0fNrfCth64?1N z6u2mi&?};PKKCq^AqOO-oW+M+A}dM!G%dnK{t(<5bh1#+yVvPPSZ@*Vuoz%M5L#NuL~}?6DNnAj2p}kfb2G;LZ5SEzX_}iXuE&&dm@H-WH3fXe0VfK$gH4Y z99qn2ohAx1w0lwKX#42c3@v{M_z6sVk_3orlBv~F8oARfk)<}`+_iB4%Z$5-S8&Ks zqNFXYi&^N<5T^YfN7dom1^fcdW-x+LCuytsZBR`%O>+#_;g#)O?i{`BJ$`u{FY3Y2e%+Og0KW$`6c;7G)`gP9OzE)aC@=(-Bqa#A-(A zau4ora(P3G&q1iU0CE|Dh8q}SBw|Fu^bBHbH80^OxO52^_?EYM0{k*mumOvt7BKHo zbQnL0H1!=YY1OoJYzHpD7_zRw}4qu^D=Qc}3Re1_6!=~iQOth+cLqLvC zK>(g6Q7qB6XiW4us^CKjk6{?(WShgmF?gq_(k8dTMND9LM-rc#-lWhlLR`uu@F@vW z8!|ojAM6eru?ZjHvmkasu~N#Pst>}zd|;ym45|Ko(8|>D647%@V`?d5KOsLN7bh69idM(#p#+sC-!^lUMPu8CO3|i zW8B*MI0disp!FjfF%5(6$N+mCpH{XZamuq(kVcKs{B@W%nt_2S{3Ou@FgE5+4>Ne4 zEL5fqlxGw{65~z5+j2p`@U-0RBC*@*WC!W`5LAMNDs3(k7&416*T4bXp)BjLV$s5B z0>_MB0e=ssX9s4|Y}vA8Q)bn&w~4L0lo&F%A`5Q?!FD`Kx(GX!Orq+vj4cy7n4Vgg zol7>%t>_rwt)7xpeLw;&-J@c`^~BDBirPXQFE*h(2cp}Yy85)uFW<_G{T9B?;8A2u zWx`Wg5hfV~TS?r7isal8ZznbxnwD@1wm`!0$cmWLZdn9f8WG3kf}|qfK#(xw4ri(; zz?e-FAv<&f33Conli?3`8x}xYG0vno;*zzgK#W^Fr!p8?IU_uK_AEk9UOE)y$x0!d zJuKpqoo=T@CsE~RJZwvl43Au!yMK&;)6|*J+QBECq~F;cAZI!QI>?5V4j7Ih19Ldb zDbuD`lM1P+h~`p5{mmeD;-miq5Y)l7*WkK&M$ID{J?JKrT119J)ICz1C#fZFa92Sd z3uf|>6v;frPau{g0&J2;s6y4)=5AkQ_G+oEU6xCBr<@ zS!oHu-?K@fu^Lgiu(+B)!+n-e+(TKnmgb5iZ$js!%7V{Uoc39bJc*3}mfO>ts&Pqv zM4M)Ez)z9)DB6pXXb4VEW3$SUGN!U}q?5EM@rOv};-{#fPO4HzamLi!N)u_1IxDom zCw9)fo(Bsks)XF-Sg%ZHw?^r~$|yscK4D#iLqH({I-xe;DKN9BK+fqvkKo8<7m-ua zJ{On+oC3hYq*WC}T{%nTww3r9id8I|dhEI4&y?Vz@k5(G2L#Rc1<* zS0FuZ3^w0MV)ccxsMZosj2g+Tf!ALf`PB00R>uaT(Kf)7JlDTb5l9v2MHWGX+Kst@ zMJT>$q7B?0&tjEoS*kF*0^o&^cl1g?l?W!GW?xnPwQa`f8mvq>O^0`rcy!eKCTMPh zVjhKDhC4|V<;F6d;7R|eO`mTfJ&V#)(Orhr3OB5X)J)^)yO$Udv{#XKMq)aA3ne}vVG_$^3{|ld`ENdr$3?PYhY}`JYgIBg z@fd7o2gssqb=G^0cH+w^HzeR1x#mhI?RR&MkD{iX=CRIXO2Z0XnI^M5Y54&Es?1Yt zpUt95w+UWY@Gs6xQ!!#?0I~$4Tueb_BEhF6Fsp_YPNN9$e=tJLuLq@_f`Nw;dkslE zq*o_)M+_XfvR%)oR~v2Wi&5gPJ635INa;+GZLZ-KGB_j-Hk)-!(MtZyceh0 z!)Q24ecCEA?X<~()qZDCMPSdBAyI}k^r@G5N3et_xfoI^6`YKVhEpwHOb2pdRLcj} zhy9FXk~kFY1{XsFcyQ%2?&DfUG%zkvQoy2wIXMsXoe;&th}TZ~DWqo-C>|aC7K)dA z1*QqbLv5IKm*Ojh6>hhqKN&Gm2C!wjl`#pXEYc_X(+em2`Fs-E^0j3B0i-=DAZN);P{Jor#vzh4df>y#C83} zg^^CuJ)q{#!08!8u!kdbce3t*l{)NQ;EMK87P{F|O_@jIS`B0t2OGY48`2*O@gYHr zhBSJ!iwoyT><5q1r27FSdH!N}{%r&smguk_eGu|YUu;i&3w!>(D%P@q!(F~OdaE+& zFZJ|3fbTPkQP+;^dj7M1*?}e!E@3TP38iyU-uzyH` zCSqphET`)1_@px!MU#*x-fWx>y*C5xr^Ax~Q%&ypr3f-FXeOHEIQ{3=r+O?JPp!eSU+ zQ2KJRX2)6!^3G}NXn;kx>$xrSgo2b~h?|m~a5y^L&1;BATj)+S>fmv7ycgs6|Dl$@Bbm3|JIk`d*^I)blWO z@J5P`aXk%JHmyt+_1BoGXW!PxcJPzCgCS8lXDQZ|#Crv9r24G~G8B(&IYExf@KqnG25!P%eJ<8%* zjs}&t7sf)~SbsZ#rHk90^xJqhjdgA3s5o0mK0L>nG>~J`u*o0`EMyT@Q9oGS2W=D% zjsszPd3&u{eJDqMxW03*9N|Miz4W7ASaHvjT|p4ochD(6-V;FlNS|IkK0f392N_R!${ z9fjz-%u0DbA5lM0K}*6U-Mb~A9T~k!gqe!_|sp0L%%=UJ81mf_x`-m_+Lt3 Bd%*wz literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Spec/ObjFile.odc b/Trurl-based/Dev/Spec/ObjFile.odc new file mode 100644 index 0000000000000000000000000000000000000000..dd0bc717f4a964ce144e7aba1c4299f2f0bf4458 GIT binary patch literal 6777 zcmcIp&2JmW72im*+I7Nyp+?;X29lCuck>6M2XGv`u)i6DKepn`KOyj znprZ%AQ%+K=PUU9+)tT++tvF!=r;hb>wyfv`*0l%hV zXy%q37OEo59BVyZuGS7`92X8$_HSop;fe5YT7b!fBII&Ry~BAS^E~?<&-*&y2N?C) zJB3koa%9UzkwvXRVe@HAmK?<^ZuDLtu$)Cf>^=QRCf+Y~;KsSZnXSLfJJxpxF+&7Z z1ybKqRktx-J)9*moDx-7W*-w?@pCr03 zbNBZpO69i0uel|j4cZdu{K?@r+y)04cGJxtAAZY0zxM2@S{U zq?k{eA@2SJ$uv8rj;E-|Rb`0*A>9q7jOBkr0)hyH7}5F{~guWnP@UPDmW^5g~Ej79pxJM>1U#hsv6G|21sr zQjg!v*6R98m+Fnh`ck8D#qVcn+lGV8nmpP`f&x%( zf-tmUt@Y4fyjE{CiMZ$w`e9Jm&~(VFYlF~cW-ltbrk!RPg~&z`?3f@4m4gxHd7ft2 zv~gHB%VcbF+Y6E+YMXwL6(;SNq8sHVM3b&VJL4}d)$w=jQf;QTIYJvAUa!?)39ayN z_-}~pmH3f)+ZF*wR(+1EXs;YMq9KQSIcN1+t)c++?Tsy{SSi*NQ}XBo+cZ6}Qz!&O zh1y{0)`D_3Njp)mZ+dB%1U+l^F(GhZmSeaO@O@1!ob9oy(PGjudwH@jx zBxW<(;beW-=WwUUIBdirhc|n&_zooGurSGsyb|OL2RpP_A}hNsw+?~I5(sM%gOp|? zELJeqlR+>RKXTaQmS9LSlI#cN-|N@XGCe# zg+{!`dAl2A#85|ar8O!nSHyKfvdyVF6mxJeX}^F22=P-`YOGlxW50lXE@48=mQ044 z?=ykKE}Wh~fXsGs0hlxjfq?=@CE2n=9f<;E%79Y6ySB~n!sO*FbI{rtgv;FG9h__j zZt(Qoit>V%IR?(OePn%?G7nGyxgCJW3NxN*;BFlL|S>&%kk71F1~ENyNO&jmjh-R(SyH^z2g=yN8UAqvVkR7-X4% zJmUg{P(%O*NLLUb0${=cEcQFmaL^CJOiq9;4oriGSnCS+_wPv_Ar|+xMt#fievomX z^NCJ}D-!S*w+#bo)UbL@h_Jpiwa#oastCDZALV0$uH2&tY&K8YM37ltu)W{dxVo+N z4rN)`>?60e9iU8SvUcE7p7m8Nz&DO07w=9chV@qc_RdKF`%kM$&Lb2 ziYOgQEJ7hl2Dk)JwZP;eCR7Dr6QDwuh@l|MGS$KU6|Oq?DqyIG)oWaJDq`AL#$5H} zY(-~Kma|pNoW`8eXD&*Ob-=1Scj!K?kC-hswhhyfrwd+%Ty2jz+Mc#9mMi`m&Cw~@ zs6Rj}khW<}7@aYA@FPjPGIA$(9oI_WD?X?^X~zDp=s6T& zvyv|pC9Kjx5v7R7N6CmJ=-f-r1gI#M{7K?)+*f)KVsa&Sn&IAr>r)O+ z?I3|Rhz@E{0r&KRejg5kwA}zdY+G>^!Q2`V4&U(pG979bCj;M4SgL9`No5w064kgZ z5rS@X3~~a_>hl1VR<_b`RFb&pAtI=Ih={m0?+5L%z)ID+!O?eG2fQlsg-6JcWC%va z(5D$LgbOCB!%vhR2S~J?IBns?mwXt=4B-fvKhV+{0n1Uf2mKoTD<#*o2Dr?$%cN&9 z%puLiYMk=U?V9;a3Frpl_$GJMeJDon$=y|=4GC3{)RUbwj?+DEsu(*&%3QC_)FwKJ z&#lslPAE>B9*9b;R#~}Ai`P-MC_DgvqCx^15j=(qa|m;C=SC6a`qTeX5LgDIDLG~H zo01|iDU(9IU;0}DNg|0y%`bcAbJ3H?(U-0Ex#;BxFdrb_b?E1!Cy~l$zcMyJU75_A z$%HAZ zeH5B=X6gNdLTdt}pGAUVF9g0_U;K>d+V$x}QY$nHg7EEuyN`YNUg2~FKZD+?zP zF4Ss6X7xlQTvlrkSapvy7~I*%$N$J(M{&#US#_PDx-3=rtN{h`fVV7qdZB7;{v>xDKBP%t(U08GePT0e>2a(pik)m9$>09Pi zw8jjL%f0(vEi(6S1-|;8+#JKaczK_3?*6TD(pJgy$X@kNhi~Kc5+A;fn|SbUx_qk~ zV3}{geyZEY-+=wZ(H(yS_I>Vr=^HR2jbDp$#^$kXp+70>ft`dmK?zkSbp@pJF> q$^Q-=HTz6S)s literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Spec/PackedFiles.odc b/Trurl-based/Dev/Spec/PackedFiles.odc new file mode 100644 index 0000000000000000000000000000000000000000..1759a8324e0f5aedc9111ad208db3c6d6e9d803f GIT binary patch literal 26571 zcmeI54~!I5p2w^I)y(wJv&i8rg3FbN?0_>9m_d(4afh3Mh1CTDBYNygtm&>{8hWbd zy1Hi=BYPuod&G!g6%FU<9f&bRU4oo3o*Kg%kJ}hyTw)Blu!gLjF$VW$XI(=)qWAs% zURC|7dwO6{ht;GDep9bMRrUV--tYb1t5>h9+dEcgHEi4e*pW>ZdM!KeG_T92ybm3g zlhgu-ig|n1&YNl5$~n#J)7F4GnL>fj!|U?doJEmh$7fJ-v{gY?Y~tXKKoUR6rmT#L zDiD8wa?oiG5I2cs8LO8s9EozQn)YzFrqv*PKlZ$B|6`}MHLtRWVoI(B`)nlaUPL>} z>>?G*4vxdk1tJM#gkl+$y%F7w=cSaUeFx!x$6jp*JF!=JaxYt&&*#!zg}mhym*iUa zika?S3sGQcE^TJCV^>6&zRVe>6hhla5{xwMd>2j|=2)~nygP_1!gAqJH-d60(uH)5 zx{y=6g08*{e?r$$h_oKMokD!{CZEN9Mk-b3eb*0hEPTbFe_o>>n&pRP`=MG2acXxW z6p{STQf1S|%0JH5l*ah#hwxFwvy9@QXhT__eUCyhVr>+fL?JE-WjJ&*{zN#}TqZs` zhtA_zE~gM5olGH)g-Wc_paWr!Wx9W~l|p<)Gle)7`lDEjA6ke|gg%BEh;cclpx7$( zpwH&{pkFLNWulJO~&ERU|+9=aBYq*}wtsq=uWX z){a!qMWI(@o&1_~GG9=xNgRP+zW=<6;?}eSY9H!>+Pv$l?*j~xXNep~omOez=Tpi0 z=jh+jrfFYb)3nLjDO{95tK5y!K8;dR4bd6Zd@XlfTN?T{0uhkr545KCVaqQ z?HmfsiqRAe`FkqE_w=i@Vf@=4Ym1!@d1t8jaM;}x50{NE!to72H-dGt2=4~(2KzaS@IByrzz(qpe-Zpe zuoEo8-v@sm>>P{mx@ePL7j4z&un1oSz6fj$i|{V+F0i{;gx?2#AJ`Kt!k-6!9_&pP z;ith*gPmm&9*;HY@mQ-qi$(ZC@P%Nvun6A>z7edSMffi8U10lJgdYVz3idjS@KfNY zz&>FSuIo*@uD9wlS%l9ApAWWzMfe8r4PZGI;XA>1f<4M2{4n@ou;VPkPlBHW8)gw6 zu4>Z5RjvAT7U7NHjbI%t!qyTG?_imxZ>yT-x0h{IIylK6V%s2IyW3WE zDz<~=HSpI0{3tldBjAq&_%1M#KJdN(-v~ys9DKRY^HuG!eASZJ&sf@h{$ubTgSD^- zH^2?BY8K(2>g};l^(C=)S%kj<{s!1{EW#fLe;n*y7U5gLw}RctB77D2DzNKWgwF<_ z4K|5I_-C>9*k`dNvEQ=@e+&FAuoqZ_KMDRM*!?WR?*_jcEX5*xE%;in#Vo=bz#G6O zvk3n@+8+Bnx+L}ii}1I>-v)b`Mfg+TPk}waB76vZ2&{)i_7-Jf_px;IL2@3g{-NBQg-(O*aIshS-2#uO5F zFwJ3%IIcvD|3|}u((Sz|+Ani|9%uvaio{zJxBhvc9-_uL^Zi`VxT1!x=P~|Nj!DIN z1fxOP)cumyrp;1!ZYs`Oqw(JIaYi|A8qt)Cn^<#b8var!%zB)KP)q!saC>A5Lbs*u zRCd5ItgTkEkT<(B)++5Xt&#uzKx@D#uTh%|X@F3;QJVr$@lxqjyi^bhm6lDNSDgO$ zab8RO`pAtDy6tILX(uyt=uE!DTb|BX#sVW{=1pw@%1jz2 zT`PUl-}9HUbi_>~^1ETW|AYN9Tv}3I-x`&6l#O~VCB|o86A5dlLqpNi81WXj0dM3S z;q!v+u3Ro|MCx>3aK2oq_=D-T#fGZBe7bidy_a#5bFt|TRUM05OuAma)n466%!p2p zos9iMbQpIGSk5xavC#yDzp*e}AsT91rV`RIHZm+1ZQG3_v&DL_v>G+4!#-p z>uQu4yi=~+q06(p(K8aBzJg=+${qSworkF0p94iZi>}tTkNlO3|AXdpusx*qyvD^lt9l4ft#LU9 zZRpw(K6UgOm))q8-Kd7Aq2?P9F0Lc0j*D93!po{?=J~6yaoHW&T|;w9lfs8%GtaZe z#Vf%NSGYu*JT8HW4`<@l5S zFw4gXlMLhhVLzTjV25!07|X{#KLLIM>?0Q8=fKZ_O^uTXpM&rmu$x$fuK`~J*25zF zF7Ug+9$*pv1o#tRFS7`L6Z}oE4_Jhs1wRWmxt2uuEQDu)EoKpZ3-~QyDHh@V;Qe6t zvk2c0z8~xb7U8dhzYg|$7U7?Oe*!jX5{dAc2+st&o<;Zy@D*TpvIx(C=fLh|5&kIn zqhQam2tN*f9PC{d;ltp=VATl{;nNYG4%WgVyaT)g>}M>(ZEzdx7c9c}f$sx5!Xo@t z@K?e9n??8;@H1f1Iuhaa2-kx(vj}ekZv(rXMfhg$&0yPEKKAW@FZf=t{g8t!!`Q#C zKgKc)P9pI><6wtbgg*-YDA-OG;W_Xe*ajBiE5KKP&1Vrl z6MQC^&LaGi+9cZD9r`I2;je?g4tA79_ur3ziYrxllEn*Qq2Ye1#9gFaD zHA(pGJM{Nigr5LE0rnz`@I&B-!1k~tb?T`vZY{`o)@#fQ$KNf#wqoox6=RR^qkdmq zywb#5U2s+OK;52**Ry*oP1Gt5Z*|Ks*4voXQjx?;rP?#OLOrnMHV0rE%8qy z)p1IBRiU@b%6X6SoJPYo8dk3AT=t`7Yv(S;>`yy{p6k&}Q1FQ!J>w%r>o@APA7IV$ zb=pnZLTxcVQz^%O#z%wR(a-L@u~2#aJ`4RC(Ng_-s}|Jrys`9KPUk9zG_s+PT0ukO z+?Mz+qW@JxgMN4QMxUAQF&gYbCS&BSTyNSo^H$1m@Ldgi)7nx}_P`7`Ab)meDUK8*-wlSez=Rz||YQ{&t zuXLerNtMnZc{4_8?~OaXagoFeCyPy;Rc<{~WsXQax30_)DLqu?h?E{Gb3{rHl{q4% zhsqq0(!)1@j%cjA{;}tH^~^z3=4RB4OzC$eDswaHTV-Qeb$NYN z=4QsLugctv%!5|uW{PKoD|0jBZAHpUSLSBMtFOx3OsUtolyfu1b1&X9E^m(HV%D`$ zDb)4ey0#e4wS3ieZS-9`{=&10eAE)MU*h(_LxiSs{th1(J=V*3@A zFWy|Mgo;ip)c*2sar#w!3BPLqZ*kJWtvXh#W1$~}Aa*0qr)cyr&Ppx(JK zBf7Nq*ZProTe#e{-d&Hxp`!5S8r7awbC2hl{r^VePnCblUH+N-- zY5y9Z;Cb)8SX#TZ_DKAgu6&tSN8X*PS0_ z$Kr1V8~hFEXzBNY)tUkNOHcCT`@xD__#49ItZ=M5chQHk;EB|S>dPy(L4Cnr$~MZc z&-LCN<8^4t3cRfx!3VNzpgKmL4C;^GpC zj%CYNu3Fi-a`h^s%*U;!Oivvzg+vW{EVE;Cj-D{Uul zW-?alh9F;SIrN@b_M{!@T+y+0R$h2w*{Y7xw3`!&1YVF#bTXD6-2#z2pS=da2`A^|&_H~R201?0_0+u}SO{`$nI z;y9L>OZHd}pO`G~COm3Vx%jg<3I;{RRM03qXBC#%w?2L+^ z%IGk4i<;X*caTw?qID)=h7Ak}~(YoDLG%>@{HuR84(Zhs#e5iavYG z3fx4w26+_VRv8oqTOmuwyF+Z`A2o-nN4gyA7HA8tA?rA4ys(OG**96XpjI$?h6AghD0nz{m*+=?G zD}}en8mTPwjTX{_6@kshYO0cfw8KR~OHFP;3+WD4XK~y0D@2@ljx5S4h+Ru}pELt=cQ)b{AT^DRPWf{>@r>xU;iv~kc4v4!5 z)G=$UB$Y(NJY!u?wvZuPL$o;y7BfgWC%^VXW8Pf$Y^9W)Z~`Wv(!*N4%CZe{jbCS1GUDXFH=XXf&Bu2V?% zl%$EwSzFCyUO8siGa3y$RGT!BF-E_X&rK+g7jBb+(ZDeV@?9f!YRdLh_MyXI-Z^99 zAmMy*vfO{6N;;_lt6FeN=eb3gjZJ!XER=_rG_wxj1anYqF7GVHsBOVq*xl$%^9hNX zmbnJKrk{Q|fb>Cn3-mihs)0M+#3W{J@zFFk-EHRidrDoDaVkgam(gqmn+zG zdn?pKHkT^uyWE!`He&ddM!of#Taa0bGhi~AY<7#0Nuw89p58>BeF0P$4kr@+Mn-gJ`BN_s+f(&$a^cxAIlG%iziBdUS2xTFYwlOBd`Mtg5#aYnPc#1~@ zQ}0iN`(T@c1ye`LC&K4BS-imAP{TQ~2JT*cs}ERwz(N|SyM?k!24HA|^3p~g@4&RE z{VMBJ6-`~HKg4w76kP`UK`LU@=){mC7;6eX zG?yK;Qm$#MVUW@`ia`mH(rHKxgQQ{*QZf5^Eiz1MfBr?#C<^5{4ETmz4*nG}bq&IM zKse^Oedv{9N|iZiI3E*lM7Fm#Wu!m^-Pl?gfI z4|;v;qLL@^>k#Y!JnL*Jw$2s|ylKR&T9|(+8z!7%e>RPABL-X4fm$ZofZwN=IAzM1 z>UJ6fj+aL{R3tAB?xd7%#TJ@JcSOEdGaUy%GeXtmI$gOqlg4+&`CcVQ9TX2lGkrZ~ zmzAfxFV&ixYm`IFm}p@Z-w$xbc-};;kLwZs%*tVqP7%|H9z%9Qn-D#ELbIRrK;v_C};*3@0fz)knAq`9nhkT_B24qG*4@&@~vPAZiX!P|?`b zH{J_2G@E)7FL`R(C0alhy+OL$BLwWOZ0p0lqWWb9a`w3_28QbQBHHsg_s3f3=OTg! zC9Hl1H!l0oZI0G>)j@6O QT%1MwX^-~I?0uT{|8|5y0ssI2 literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Spec/StoresFileFormat.odc b/Trurl-based/Dev/Spec/StoresFileFormat.odc new file mode 100644 index 0000000000000000000000000000000000000000..4be52ee1b36ab8955c89bc2e6d576be8f13eb624 GIT binary patch literal 2443 zcmb7G&2Ah;5N?OR7#M*NCr*VF!LD&u`8!04R)W|GiWJrnjsha5-kDnO;F)eS-Q$fF zB1MkGi33Lv2M#{MBk(Xh0@;&=kf5r%XLi=Hg&1jOs=Ml|`ntM$YBn~vtfK4i`KC?l z5{-9*ZJ#xRO?0X1sFvq9tnoTGSh>N29B09prOx=zZEq`Nr}PpF4#(GPbe~@p@mVLt zXEwtkxa#=t%!=p+otYToR)M7e=P!#_r5>DDiX)8ZE!W}m`}oKQinPoH>&0|CH$N9a z{9>}l{7~wd_=qgXNrwn~d4b;iRe>pWj)b>J{_B-Ep}u1waEh=`ysz?c?a?i-$3{EznGz`np1RG7x(Ps`n9`E)h!9CO12f8@7Up@LvZ?V~a|4?a+aC4lAEq z1HRIG46sE8YyE^Hb{j_DpIM}o^19#Ev zkRoi>Ko%m{A#^M8Vun?|j~RIKbc0g_W1a5Kbd^DB%RR8BIA9KtG+RXrkJkVwI}{L& z}2B510f_s5k{e8 zdks3z+gsp17B^Z}ykEu|6e^O6Gki|+%K3&1Ih7cNonb}df4hzeUUFW9q*EpMY3>@| zz1*ZloiSHk6yWM{Sc&V0-G!vx$02ML8INd>M>u0ilIQT78cm8^WV}^isK6aeDqBKn zX&HMJrny7TRb{QGUE~25D&r$ z;`PdhfOMBdCnHLXHrCUj1UUzE#-)lT{ApuMKojVSfOe1?nC?1_$LIQ0(aUHNk@C)D#?o-%*pT&KKI<(Dq9rXJE@0k_$u~1ZXsReLVlqqo~CMip3t=&@!i-GLf>us z#7bcGdEF2aDMVyOQL&hvzZ9{*(wqC@Q5c8jxbU;>4~o$CrE9i|W_BKWY5;SW{wj#E zD@OaXx?;3d7gz|5kOVjiPCor_xs|F=1^W4_)z4)^-c57isT>f`SJ(#c%E j9U$$q`T3Av5%u&7r`F#;QcwSWU2gSos(!ohqf-9@Z^X)@ literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev/Spec/SymFile.odc b/Trurl-based/Dev/Spec/SymFile.odc new file mode 100644 index 0000000000000000000000000000000000000000..3bd1c13f0debe8eac16404c5284d1b19a5f79cf3 GIT binary patch literal 3932 zcmcInO>7%Q6rMUMbenElC~#>-hk_uXRfvD`Q$$6a*l8>!ab&wyLR65GY*JHaH(IaT zrVUkSIdDSUpyEI!E*v?)jYCgR4oFsG?Vuf#`Qlk-a>uFaf4cKF<6Wi8K<_O+MuocQO^y^71!}=y=N=VB_m9#ZGEp8 zc)mlUm_&lxaXgOa$NfUyXxn1aTXd?%RGa-au8_6fHcq%jw(6{iVxv>6D)kb~TcD4c zZ5U?Bxf~c55oXKl7Q4x7#6l~a=Q$Bq zt_o#xOIJgn#cgy@8RG{$4Eb9wlrkZ=>=c8wswt-Aq6tLY26dyc2gJ2-VPXyCcZxMq z94FC?Nq_c+0F3rioLK^VEVc3XUUmD*LACMCAvJvIu)1A)QK`mpwej14Qop9vaOE^* zuQyEnlzL4JDYacPr;DcSU(0lulFeYge1E_CWls!gMJ|g$d1Y0y+Bz{&`o0f0_)6wj zmwNAmYnQvQxbs|>y0}}Z&qsd$YcJLZbeB4TL-63lN4J=#4y^CO%3ELT-^Xnq9PLua zu>SMt-3_RzpRhhm;{P6!_J1}vH`PIG6>H^gCfqs9-G*6icM#cliZzP~MXzIwQ3=K9 z)w_6N&yzZar(?%m)Fx%NJ?>Jbp8+Dv7;GrBA8QelP7|I`W0Yv^f|U#ti`irQU7mnk z2gB%;#E^r)>r{sZZ#zQ*S$+OlWz$gJR-%CnN9U)3L z6c1=8V^W9kbjYC|AtfPFt%JLD=J2x_%g;N$=e{zgi)${FQQG&7ap8 zG5d&T10`aevV!t*O0W9ff>Wz`zP^a7qvE+5_Y;}RlYh9OSr?a{k`1OUrFwzsbbTQ<#$#oabrVH>2zdhTaGt-4U&>SYfm1Vaa z)P1K-f0P0(pz63t!UF!J;>ZDmqf^_TLRB4D_O_iV{b24G(ffVLqwxoNEEm0_B(-RPobf%gdhze&& zIK@&SH+6a_av4U10s9DPIXJKD!O~C-|32=r$WP@aSYnf5i3tVvou$awnbA^oD5TW? zxuU4H*;-uD=U@;Oo-P%(RK#QDd5%bP)4Z^n+7fL?y3kGCY#msf;nbrSgW=e#pq_VUENGQiNhoWZ+7H zQ*&F%j<>W_a{^%9dOX8ek^g1`tdoaR)}uo)*ficqr{pH5^U@@b_C<+m61yR?lhYwF z6GBLWG2J@C;?N4Bm2Mr+h-A2C#iJ&`=BD~c&erO7qnjqCqqZ^x_7O(@Oo>D@{4gZh zRC3FV*>WvlgZO}Djm(y^B(3?ifHzRwMg=s9A%N%-kO^zv^QunSC2h0!iJ!DAX*AGD zYvFv^A0lN-kto<_S?nZ`DXZcJLfE(nh{XlN{->;df`+nrTM$kNoJ@coAZ#coGj0kb zEz7hW7K4`Wl&c~#Nc*8k%7_f4ATlH(hO}`$XrkY;(8-`qS~wh>Z5|y$NK4qTSjGD+ zTTTs;LCZpGk{cIpAx|zch2eU^+A1NW2vsM56k*iXYO8@yBne9)mPC3m%I?~#hX@_P zQ#NlzNG6dWgZj>b=Py#Z-{w6@5b0s&C29C!?nBz(J80Qh;?^LB%%Cum z4HOxhhop_BAdbvn;Jcw-WnL0}HhP8t@`6#RyBA#Vk{pJ(jT?aw5`%#-iBc(H^Rggh zva?*TFp5Od#LOEl~Rvm-+l9(_+(CX-B-iyAHWZX j{ftp*{>n=lR}%ldk1wiQS8mE@$ndq@YS*h5WUc-MkT+mv literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev0/Mod/CPB.odc b/Trurl-based/Dev0/Mod/CPB.odc new file mode 100644 index 0000000000000000000000000000000000000000..6446649418bc6996ae53ce968c8fcde11809d1b7 GIT binary patch literal 85923 zcmd_TU5s4UmLArkg`E_kC-vz4tkFs(&cnJ2MU;b)BF6v;NoGYyX^;yX(U_{QK!2+#PNo?)L_h@xtb0 zCvNWc#@lnntNQbm;b7A34|=2V!sq?oGb_xi;{G3RPKKi%8^w=GusiRxYO6~BF*jpE;6?X|gi{O;mc|9<)hTfL)+fe17+ z)cJ9G_U#3$qrU|9&si%!QyUHi8Yuu_D^uWo`%B)=@7;fG?$>br*YRure)cQ)HJH5G z?a5@+e{?wMjq8~Fz-#>T{yV28F3r982iDf#&<~+}?WfP`U&HeAc>~z21A3Pl|@UMwZP<@Kxj!{qP)ZRa046AZ9#>*n0{Gj%Xwb~P>A$33{JS75c{g4DU-v?<5S#Nt_s;-? z8QA=eL$_kTuie6LN$WeK;j?jX)cFAo={tAsT)E%h?hVF0k~s)m#WN6^=3+)yt%Tc- z@_+Y#DqiW+|_i64~UTiT@f$NrDg+v|Lsc^`$^Y!d4j@884a zAHFevrCMHGys@~neD!km=*i`3t@msbrf%@K+J4dAmWH1iPu35- z;LXM5#bqnF(d+J2+kD#{Ose5QZ`7TjhcTXwM!oF`u?E-&!!fQN9akH}N4?RcTIuc| zJnHT3fdXQFV&=Dh$!Y#Je#tqCF8+x_zpG39xj_3rqv8v^V#UY!KmJX#{9e48dnuOF z<%;DC3kxra0>Kvwb8sy(^50Sx`R{k}KP~SU_#gj%_N@~^cQhk^O;?oEzu;H#^Xt4w z;ylaNvd{%O#5vlb*JR~MGrQXSXXoZ#&r0yS-dvj!u!;XlSo~RDQXekJvwnrU*A*80 zhv|w&-Jbm{U41WI{dcU3|KTa|{{^-8U!ds=YW_N)wYR^=XMk{S?ip*m&#T|W|1zm_ zFZfI~{w-b+y}5swuKw@z_LEfOH`24u`Rrd{jlT!OZmq2Hne4^iM>&I@B5H5%rng_G zw>10q_71N^wSR=GqAtqL&HZg)WY5On`-Ojz&;B3$e?ct#eMs1azrtt#FW&y?%#D9n zmFMPWapU_!{yA&j1KiS-xqtLMT>VRY#sI}&`j6Aq-vs|(7mn}n*%kbm+jt#Ug5>|? zGYQ~7BvnN3e*!AKE(rcFXyWS(VdnlP(E9a%j#nSxui^76kO1rV|6qG>@$CTrU-+xM z`aS&rI-bwXky5VU%}rC^ha~se5+?G zypkOLFX`&p-VUD0Y-IVzo9{rBnW_tVvXnXbM8p-sO29YFd^nL{X{e{CEhj;1f7 zz<-2$YvW(Ri`VIP1^4TU9Txaj6#dUAD`G5V?{yMHakgF21{f`l($&9*8n20txS0FH z2kUn~yT4l9?R~Yl^6<{BH#(Oty>a2fJS_8%V5H|itlkXY{N@|;!_njJp#NNkoUfie zdj@yV8x02w+fVQw=H5d1;b_eF>v~u1_qRtw_#}i^Df=iu@F93vXPybn%Th=I=dt zxW2JP3a>oeqUSVPZ(X)W5Avf2w@`d#eQk5=jrsY`CAjhZN5j49tL`3}t%f6b(Q$<~ z=jSK=eLVTFTDnz@_qyXJxLm$f?exFG#noHY{%{8u*KVOC962uEy;U9T9kRxCyzLKk zdE*w_{II%ttLpuD4;SyT!l3tKTrMr%s`kd}0)6b+Gj#EI!Wv8H^5S{c@ z1AQ1wOXy;M{FE=z$zD&z)C(kqur8yU?ju%OMmO8t174w<;SQl*MmK}u1XowD612{x z%`Y~$Rv(B2-5o-*d=1sMd4b*^^;vcq-R~Jm(EUjDm(e}Q$hYbqB*67mRNn6%@d~vO zIqm8x>W}-+dwhI@-KysbVGk67qy^;#!RH8~fZ44I7Y}s}$Po{*;;riAJ>x;Obxf?# z!TpDb(r}6Pf9RKLf75RO-=g=G;XWw_ zc|t+LCs>w1Hf!E)0RmtX1Q0HiM1uy$*LZ$&VF7=yA{JGlpFj`*ufI1mV2OkR-Z38b zccRB-k!9)nPlB@B0BJbxgM0{?r)hkrJMNRSK=bx!)IG)}NPG8qfID1+wi`W!y(SRO ztbqh+8`?V#fm-`YQbfw(>LA2xZMWZ(Frm#gq!+|aw7J#?Ybm{;+1lg7uG$C7)_QRx zrmZOmM=?-rZNlM!c(!(6(g?1t9UfpX;5^$OiumN%j$N|b?d~2028s_#qvQT$A~|H& zeTo;gAEm~oj&2dRJ zINXP~GSd>kEfU)&-Mxtn10Wmpp6L>R!EEUgV8L#g<)A^`(WT5HFz)w8x(9V&({u@l zV19H7fM9=g38HL2v9hAb_z8xAdLvUj96Yug^i1PqH|V=R*tTmBWT)rXZj`t8>=ioi z9mNg0hat8X=zn{7aBMe#09MNWIgP-T}uKV_xuh$9~}BM(8P0Z325Sl-^k1Y zLTdqt!WY;z5Jg}TY`u#9_lI8@b+0aw`;#aAF@~!ueGNVEzB{sZuR*_rTD7wNpoy6I z2z1nUi9p-^xCU}RKJ1N*^4COOYY6TIxxDJD{<#0Bzt^7}SHoR*J#Noo=6a)nd>L9q zjxX-eX54L1@+lkUmcTEhv+Nq8VLeg(EoGooLDiv4?(Qv&dlURzH1MBv$9IN1v}b6& zKi=q>FG1Vmy|o_hXavxFf8U&;1kc*>mt;%EcXoY_Go`ci?Dm{~+$bQxL-MAX0$GK%#j<=Uv315Z{2S-mT$%IPPtAAIa_j zao&x3GD5kr$gx<3L4WU#3=ruwuuD)0WVdU`DR8lCKnp?e;y_Cr-R*A6Zi1&j!UJG@ zgoCkXhw`60psl_#sU8YfYOU&xMxDX?)#j&&fA6hrv8g+&pWIvXz;{9K5zelz-DO$4E^Dv# zp55ZEr;&(*y3xJQkcj&7xGEm*=Eg;C)84mW2S&VQmK#@WIq?Z?~ z@7weJ!EmqlRrNu&2>jH z>|I5_46<3JFEv)NR3gx2#1600@9j`zKnr*VL|?n6C@&Zfp9~k6(KD(jVn!s#`0%m? zyeC(sQDfCrh`YpZY59g@SVyho9QrF>0{mm7GbNNHr1%N~JI+onuY(_!*;w8BY-3G? zG--C(#k*3XMNcZ#rH9rftb)PYJo`zsQL;% zw;-Fa-0SU5SpO)bnL}b$DEflWb@K`RJztrlP$d(7*ZVJ)|y+APdZ?D13z-+C4vbur71)Ps6LFimxG8p}Ckf^{)CL$zrWLnetkfTN|IP=3Z0ljb0%Q>{E=p)OmzUxcSs;yG3mXWhR1{ zV;PNX2Vo6lPmX9#No_B{zFbj`+=3Ku0heHcovGqA(lQJ}Sc)(^Ukqdvb5b8AT}y~H za9%%{+=By|)~}0loku1)CUiEWhbH!S8ISaKYWi1j1;ZV{g}TrdJa#GU@9M#Vl#OyM zYE*aEQG&9a*wRTQE#5LzFB*?UR}@gPD-dN1Py;l=s?>s}njE!OSVeh)>a|GT(D44Q z8l|KrLr0vgI6{(IMHDhs!{bmh)^~_NhbG$850*GH<|>S=V{a$vIVPA0vPj`*Op(P5 zeH~gcFSTNr5=nL;Ycdm2l?a-ca7lvdQ4O*hmpVUBeL*bw(&~cnv7sIPy*l`-`v;R_ zBs+e-IA9cUP8@99K}LU#j7%MgfVrXG54t1Fh z9vXgx(9n!RdV_I@G_-E;GZjRhGT`{6H`&6#2odZhbkN-gg>G+b-2MWgtwrT4pWfb3 z<};Dbqh!S-fF?a(x4@gAD-205*3c{lI_cgDqFgx40SWTvZ~R78y@{Ndvf#+gF}ctg zAVPffBUp6&T_AjlEP3(kGSJ8PIe}wIC(7}-dd0?peLY8dqJyU=5J_LB}`zYuKc01b>44t3lR-uUO*q;V90zW z{cD{kPj9aX_mZ#ohmWgH-8sV`;)!`K^u4~ zWL3k0yCPm$DyZSEx#6uzUWzr}LU>aPPP}i{@80d;o%F<8;LqKApEFl+Z*8Rms4iL{ zBd=68_!cBU40Fh@AnFQB&2kPV-g<;Ld|WqsA0t^f645qRZ{G*C_`{l%W<;fa8w3I# zx9@CrjxGX~_po?l>Am-s-@SI@+9G}z7AtUX`O9~&f-weFHdpScJ4e+=A65@;|FGl4 zzgWFpEiFK$X;zLf@OyA?Exof=NIwOyf)$0{sX8q!AT`taT;y^1yY@{pFht1F$p4NSqQe$fo&2wZCu4v!ZDi#l$K&+tkj z5_DP{Ls&?> z$uOnSnmZ-;FTm;QG9D2L3*~`FM)Zn^dL_5xWbqO(79@J@y##2glk3-VCzb#agN2tj z2DGS$34Nle5P*`~2CkV|jX#0{BoWz2An3_9H_SaVr&u(@VgZq19Sy{UTaAW+EppfI zzH1s%Z;!QZmIzM2Ub-Id1MF2M0SllG2Rpk~MmB6b@%f6l!8$7n8VYl zOk@c_2R4*sg72noBIC+*7_}dQR(<0fx;NO~JH$-16wAuUf74h%Nlf3~qKUZaE+;Yk zEe4kILLq@4AlJN{$~hZ8!X)zzxrBOqOV^`zC`xOCSC?;GpKg**(P&kNaszU5b=jJg z*9}CUCJ3k7gZ*o^He2{#Qbk@`L+ILRHS4CaX*ZGFlG$tvK}JJZ zw+X_Ih_h(j7>AEX9*RsyW0SvXf$^#hhC>C8=k-eu+?U* zQQ?B?-aM;Vj;2Tqx9j2MA1sJJYs1Oyy}jYKx4()A&cJdPjSG6yCfkid94q%Oa~#f2s9p%s20g3M4Mq73PC^_m>{2chH^($R0&uWI{DNKO;H$=Y%WxmO* z)c{)F7DFTbl6ob((>2z5<`N=g18s~rF~WtZzNFuo4ZS@pmcCMr5Jang%772^M|c2c znA0{fyoeF-@|R2RR?2qxYwL){m}Fp|_s*C6Qaot>~Umn+OjKTqQpJx;@! zX6$A8|L5fV5y!>N@d{%u%ZJnzlyd2iU=(*Npz0i($UZNWEKwcJ`{P^H^AIrgoNide z(MJzvm1-cgC{!~B^5Fdea%&a?)x9#-6XZ^O{K?p8d1*Op%j(&{%NoC0eR});R%dBZ zmH=EL=WDU-^CC2*9lLJ#?m>ck4W?rK8kT4{Utf-?!1b&wEqMq6WGh)+nZY+aKQpuH zByH9_KLN3gN8a=vef3aatPxj#|SP_mLC5!Hlzl~hBiJh%t$S^7HZ@2OvV7okmpy*nBc%PW3bx4 zu-(mw2Ae$6s*Mxk8_h5k+2rHu1wtK$R%iB%L>I!J&}X0&{t=`1G(0*fBAVwK!JuCb zw2M4Ij$|)#!lSJ>3n}NVt?Zx?l}9YbUVPM$8lT0I@52?aMxGUg5QE5U9C|5c{$9l~(3o)hA z+A7u|a{4*~vZ+=%-_mSVBtWdH3DUE){)%BH$zBd-3sfcC+%hF|kjVmOmhw;^2^K`) z7}MmS7Vg3FDmUMdLLtIO>%J&0z}}2R%l(;-XhyJlegYj zN-fn$DuUi!ThzckPB>!~vJH-#t#2r~9GiU#U?Kt` zG=8lLNY)gkJd?vhc4=j_+V$q;v?B?qbJr4x`}hz`7A|3G)ai7zfYrZWlH$5hb=w$q zx$<35xWKyAEzY{7N`{82*(EBv!1*j7ikgsQQE14>{oZ(df+smyL_TYg$4b$i4j33sc0$S1YQpeCJ?WoVct#OeyTAyB8 zil?zCK;c(Zh}{C)X_YLlJVBPrs9#%h-&kJ5aK^x)N3yyhntX?7sJZYK#Wm~PTuxV@ z*pMZ>x!)ZI0rl|=!;f$F}o$&;DZxtu>V$)c-XloX+0r3>I>|d^a zbh*OnPoHIi9Hd^v5pK&#PsG*LBd+LvHR=mW5(i%}%@`BZ!H}U&Pm}-&v}%FWn_pY~ zO)P_hzrYe2Zn8v(D(pV$(qtG&E*&UDPU8oUBd~7=n5!@fGvqY^1#4PZoNUx7LYIx1 z6s_|+x2kJ=#d4{dmn$`nZY#*wyHSmKr*qt)MD`W-@o#z0(c zeW|@&)Z6VRMWxe-J}8cHGF7cn@dOHE_x)@dL&lygm4t3z4%kj~(}EU~UJH^YtQ|d& zBxNDeJJQQ2viQR(ib%T3wXC6CZV*FZ%GRJc>DD^tl0E58dd^P!&ZPEEm$Pc5THlRJ z*b-Y;1XqF3g%dbswh{I)*+$9kp!Y0kPm4i3k!@&zGMaG1JxL@5={bVCCpL16}yQZ~dD9O1+Nm7-&SH*nID0Ry2aFYS9SFiS1kLn#HZ zHd>&kq?2e2yGPMYkYeD`gg|s8xrrMzaVO}&I&InrhT=_nna?uN4YkfdBU7ycWe1Q( zq&qM<{-AQ@qhz^+okURsW zz@2T79q9)b?2=eZ*BjJoRi-Hrz(dj92@(czsh>=~5^ za&TIv!7gPj!^k_>=f!csxV||Xm^AgTb;I`b&SoVC252$W_km#2Uc93pig?vi1a14Z z0R`2Yt))$zXV|8laH{VSz@jhgo+?%$5iktpr?((`1dfc0nGUQ8EsSk?j4e?(Hz*bc zj}ISh?_uDBEI~ZtUbv|y$QrFC)gU9SxB1$ID`!`Kf|87U4emz527w9=kejsZ@@=!S z*|1JArozVG$Jqqms-70{QDbFR<(q&*L2&d8Ihk(F-vrfyXr=Z(hK+Va(_`8{9;Rf^ z5x*6>R`^b&$VoXjbh|XeuIN^w)bpD~;n_>!HELs*c{Xk;KQI7-p9tUU-Cp9gVf~O>@V=7wa&62j z>=9eq-tOS8gu12JV=dYZ3k@5Evp{};!!VGD!O39=uxx**tw97e8_k08(Ss2eE%5k0 zo(YU>=@=vP{&>P;gJ}lfe~`C@%=xZvpbjp@u$}IqKo=)@3AfV~O+C}T;wX)SE*D~P z?du*6Vo|St2oa7-ajmo7HT{SfF+bH-ZF}r;W%GmrecI;9d>{y=eKU@r3|ZpOV&gh& zo{(li8pLq8k#hh6T@T&h8<=(ThuN0>ArO)fm^rJIBhZMzpWSC)>+HgV@Pgr zH7SE29ERy9HKo+K*^xA~Do0h&?0N(zJ0j~CymwO~h!*lgiVtWKMLpP)@+0zxlgCUL zGk&}Z5rh;xrgfNEKmivm4zqN=lHWRRi4@h8cOhvKELIQ>0Ng?hE=xiAfpTftj5h~9 z;BYC{mRCS}UJ6uh?69il5x9t>y=JNyYj6ChDyv7!Rp3%U7&cgti)i}X$Y>;`J`^zaTT^Ln0Wn~x!fQG@8w0N8;h-3Vf8!FM(o9jHh4dy zjhO)HWIj8abVk+I?(cD;C}ZHaEiFK#YYnW*zGlOM_i4wS8wnXlpJrY4>MkfsBVIT_Ztwuq;R3OR+ zk(+uk&M9MJKydLC5cA6hPne zLfFL9#JR54js8RM`73WJMxn|nu{K26b`ch#ce~3oEFS74VRN`sE%2Zb5VSE|}?7z<b4tB=v{Xt$E#gg^GsahOL5iH;3m@FDKAKiqmzXjtW z5iO|fazMlZEz>u%NNMX5K+u9%k1?i8!lR}m-V=C8llPuw`-4t+Tu^%jB9Y4zYQl~` zTnfYBtRAr`m4*W>!6lq`ImQ79y9bx6ZXTJh>v$5Lp^5=Mk0i;97Z8@hVd}-W!uA^+ z9Erog_PY~I(BzN}&~)=`Ae6oyrrB`>y9YjqgNls(qb)SuY%BG7-nK#+w4i8< z+CV0CBdDVl1?W0|XicL#25Qdz)f@7+&4%psQkl4-gr8fKz-BFbCVt3X zK&Gejc1zeO?i|C9nJ!^50X3X+YBcirD`6l=_2B9=%z)V4>pyd$yLmoz1BS=yK zH_y2lvcVWvN+tKWLskrK7eGTtPm>s}6_P?hDie=)dmFtOr_`Zc?Tej^KuvsC2mT!w zNpjZR>It+*_?zBL$rN5vq?7;%DJl{KPB^M~@f4MMro+WUBnGw%65J5;j2|c;Qwedv zd$DMd-w1yTj?x`7vuP_;ZQ~j3-x%fCdFu?SYI3p1R{49O4^76ohC^ zX1aXRS|PxlSI-BJ$|JW302!)CDrHtXb|gEP16VZ;33mXW6PYF8%(aHeKHa=VVNcQ_ z=GRTj=45o2r@XfxT!_jP33bLU|A<-MIsYt2PFEs=p~Q*F_Q@)!B#%6<>7?Gf%oJ>A zt(Mu7n4utTC|NEKXcU>Vh|I-}))M6bBIjmwEG&>Sc`tTFT3i!ct@HXGkMM6}^sQM3 z!0whA>J#~|0pPLR2V;jO3@TWmWPt193ysyI&Y&=iak-uGM$>G{LnwjAP?kHVXwmwQL|}U0_<9@ zh)*r$gMN^_(xJ_g+vW>Qj##^cGBm%rRJe#HWd4namjtZ|0M^YGmbuok`KFs(a#2@| z+Icu4d12ag^r5o2vTWGq3=ENoN{3u~3OgQ|s7t6JZl#m^nBTBCP0-DsF;>zP8RGUD z8|@<+ihaqg!Y6$P_jN8QI2X@j~lz=4_;RNWa zV15(T;fDf*t|kGfxVIU@Jl;eo!ESVyM7rI0;6 zmBiJ;kI+eq-;|mHAo;-aOvm)c(~~ipuyGm3Pcb_qtQF>z!B1`56HGj0hEfzW;;&4t zm+V*r3ro$2_)?B$U>X(~Om}8u@Om&AQKM2ch(f?Fxl)uZn;{k*NQ_Q1RUvmQ)YKAt z8<|@0r{~dm3S=Z6Z(#~Up9_-Ia`b!C=_Y@B8YDH})(%sSM$=#!pc=JcSAly7szD+_ zE$nR`CZaUqu>rn)WkiJoNSF6$CMZgZshp{J+L#7EeA zLl&k$+l^hr1l}98TfZ5rIcmXIu{lCki~xQPb1fp>7E*#f12JY|! zg0ns+k+M%U`GtTr95v42NKe*$h8_537Z2yTeo%CEdK1$dgw7BMoX0B-k!6(^0xV=O zek68!#xye@K2KYH_!uaW&O#=6pUO@HVqL0i2cLwD)um|Cb+&jYO*B)-OfEibly6XB zcaU%S!LA}Mr_wT)^}X+X&l0(m0g9Dl@SOG+C$%~@%BTn>`#jBoeV7J2Z}F)T`y7g^ zGqoTqB+)3~%?iY>@DJ~1tI;(%!SA zU%Yss4^$>}YGca0vZ0_NkEt>h0wwfG%T&3rgSjfMzJ{^+$=M0yR7E8-k%yxr(B{Jh1T3<5QV#WeOyzI3>i02E3gGu-CV|;x=9ou}IrL|lIPwj|Y zltuU;R*Gp59ZzAKWGCb_ZDty|17>W?Rlo&!CwJ&GF*v~Z6c$F1Ydi$1yZ9yr{WW>H z^~FQoNQEzw~+fd`{#S1GdSwcF6uM+Ol1gY88&SHh7b0}20?x{xo??O`srWTl0is0F-H5r0!%HLs6G)*m73 zgKTMfX2~po7TJpS(H;j@#mFnz$A0O9WAuXDw?B!|iUg?{$X@wwf*=aC^Jy>jdKP~>NLr$?v;S@}~ z2>&Vp#$jD&2RMeB;jVEOP#xUDX;q~|Dk;niBIqnn@1=o&1jUNbn&cOvxxYwaW+wQ(CInmu*GlDv zIOn6N0FmkIcNS-yU)CxeW`tXoL&|6hZ7fB|dFhUtDISH67yI|`udYe3br=j!DdK~u z_oeMfgawW5$F{yGy5d%1oUryoo^OS2d}nd-Ha7YfF`gd}P+3dS6Ss6uw^Y21meT&t zWV+{b&)i5Iy;C~y#>(rVaUQ2%t69IpSxjLN+~l;F49jYU8#&uBP7%naA8-09Z3j-3 zYLyNyV$;!ArLn7Las~Mrq*?}oRbQ^p!EAm0H3ssL2X1St zZKk&+i2e>aT5dIKZsa;sj`o!8tn?Bmr)-O%6HuR#vDK)vm{-Upi-$93S(K)IXe*SN zal;xEqD#9D+m^<-wb5+R?zSCMAQ$Gcg=9LU04*tSicIi{sbJe`nui$b-oITQ$zj;0 zV&pKtqfZqwR<*)}witQJvzc=`Eo;p8g;|S{DCoei!-vbT{_LysmUcPz=G}|6HesKc zZ)u~byQ=RCA_l=X5IfI}^q{`z539w`hUGJ1^kQB!0QiKpzO9Fu01e}HIElTV#|8~F z*d5~l9Z{8cja(|7uwaCc@D`-34X@=~NpSGIM+nb+uu3$kGs1IVD!;YST z{5Ue~jO1_AC3BKRy2R*Rj9fCYi>O2Hy=l+$cqM$Ldl1)sd86Yr$P2Y;U5lFA3RSAN z#SIczH@1)bHN4#SD?0q@%15~NjI&x_E#?6sqDA;&f@!#!_O{42QaaPqKuzIR8|9oX zDcG>uzy>GBLVWf4tn1ez(?6Z^*V>R1ta-N1=d^mQ5nExgf@PplZ-lw0me?fRC}9X^ zLS$PRSTr3RJfZ0<6u}HGMV+1(DMgMwH$}3Z`-jPZ#_{V)n8A_5Yl+s*giUj0^o%wO z?vOCYI({t*tL2{dVQ8>${iGKLRl3wmTLpC(%A(VPs<$BER)h;ZW?WZ zcd>>-I97KBB$xPmPyl&B0Q1~Rb3#P~{yn4sW(M)qfb%x_bzLVRle~j(oV|-y8nLp&7 zCL{boTFtao)IFO+As5W;_`wYY{o^F1=hG)C6*?cK@D+vHc}u0W6;GZ^!4VG1bm@j` zV>CoDB+Hp`Me z46%XPVMc)~I*P-CLLU8Q|7Zf??Xj)_axK@{u~ujw5Idgql?9k!Rwpk~Y9~&2srlOa zkgW;1FDqHRG0TP~)m~<{zKmfaq?%;9nT&vZeLh*}aaay-P zH7OQy1Ls$~Bz+!qaBp#Jm6QA-8!LT2qI>?QVw2G zV(R)mt=b4qG-m^?wyj$NL8YTpn!CE!+iz3cv|ed?CkfCe^9m_EK}&P&g_Y$IWTASY zLGbe)y}ddOD}Xzvia-dUBQOGzhrCP;6x8Fy=#a>?POVi2LIAR~D!gyMi=rFqv;Be!v=;Nt<#w#nbA@FizDaQ2v6 z7t-Y58g3{*h*ab^V9xxA8yty^X7+mnoIH8b`Gk2P9qK+x4Nt9dvq(qVDIkNsFX6~` zCB#%zxxZX+=H=g6ZW}Lbk_|$@924f$wzuLe4ommAEQ^8mEi&8q;2$Du$rjmH$Qa(n zSIHnyiguw4JiKVvf`1#PT#fw$FX$eSbi&^ye4rRV{FFO>7>qC|;jINH?~~r?>^*8| zalWEi{i#zD%lU!2HEa+hD^cF#PO`%`Sr7ziLzi(xNqIo&Rw1hW!B!<>E21X_@%&pf{+xqfysCGblMbfw(-i%LbUi@JE-c zkXHxi8>Jg(oH}1{S~*tOl3wRgaDjQF*pgc}0irj>3S>7CC@=)k8Zf6}tju8yWwrN< zL=-v5f9wM2U_V%~&bx({-nhXWawmsK(kNrcJ;Y*$W^IU=dbGXIqy+YiF!Bp|mfi6XGEQbw5S3(_;Kv&-nlSF- z)S`3{Plni^6{eg`Pg6IP4EiPkWFL?}7rw@MY6xz5BwJb5?v*`rqgOaD-^-EKRur$! z;P7as*M<-RBsp}9qknSI%s>1IES<#WXyM?i!!fqHfW}%dL#6KT;262#F0xYGh~9<0 zL*{8_p!KYe?9`EKKM2KeR(7=5)*osR{wZ6nETcyY-3g@s(IL*Nu8+xR8iU&}TZ^O&jZY$* zJ~1L2V`9}bmPw{zjB;*m8Kd2!1#H75@TOvBGU`jxjeISgO^Y{2h^@xL^Fk3yNDZZo z_+zB7*d8dCQNKMjD%oM=Ir3kFWzhj?DKO^~+wZ1;e~fR-4M){c`qq`?Ew-k_H*!!a zhvL~*^Dz`NrC(Ym6>W*SNePQegqbcDH!xT#KKPa4eP9=4dY9$G#DnS zzK^r;iy@jZYDd)A8s?>%6!hSRQ89^aL=kaBoK}*#WQkOETniOkqaQONkya^>!Z5;U z_D_XL?D5n7L50GTs>81b91i+FK16=cswpCAfP=$4q+AIHIY>($i0jZ!p%Z$d_o;M!WUBoh@!NY|yVkt8eU(+y_`$hgtVQ%c(e&4QM^I7A(y%@gDO9 zIu<;knnZ%dzS0ODw6Re< z5VZj|!LvbjRXyqMO?L4SuFj=TZ{Oc4B3X@RK}n3QvB~4>d!#919W&S=q;6`m>7~rc zqGCT{fAA?9UmGzQm{L8a&CyP2OzK-1t!io2=L?mejJi3IlNH_vTRCuCUh?Ay%5b89 zamF}`A`z08)ERV~&Yx4M^1!Xg#5IO>nL=mAA_YFhZp)PBqQFBb-Fb-u0Gc}$o*6gs zK|W_@OHqh3{(%l_{)Hg7O6E8ttLFPq5+;R*MOEiA`Z*k91Mlsfk@?JI7g#3>8!_4ifSq?U>hrLZ5n z8EaVv7<5UY0$2Q|^F+Bp-z;K;&fK04dZ)v7EuVG02w(&22i?)r+vCp=Zt}DDCSAp@ z(g2E9*x!OqHtS`vWccCBcE({5--(T!xHa2tJaCqqIC|^J&5-ql5YF_TQ%OI(>1$Xe+GbcJ-!HTThepnR2p$nSW!Cn|DbU3ZNHquK%=%*}&0FbB}=DJ*arV3K+S_e~RencIb)I_EDs8a;f zwOV%GQll2_tUx(Km1zQtn#fu^Iq%%t3VK44zB3^h55fW5tS3)R3R4m@qd3-Fi>c_e zq{zX-R3UTS?~ROctN2*)YH^~%tALn6!pTInAR+iLP1G6I7JQFylDxo@3qxaDK9t)( ziAj+XIz7rUwp$4Do~&iE&wq00fTKWM2k$}$MN?`r9w#-$={;8D!M!yvB6moFjlGtF&(D{mKR(7+i3f090r^>68fu&mH5pors}lSy|T0%;fW?E)I&lf0eI!=@(n*boh}~FuP(PXx4d-i#>-a*sJKGmr ze1W#6Aw*WGb7`82eK(Lr3pUSE0K^Bzha5Iqp=4*N$c3tc1S~+b6zqcMvl`*djvMP{ zBhz*%MwSq&qlG7codFh)dJcy$#Sd$7Icp&)SQx>A;4$R0&C=tkrr$}afiS1DZKrwi_{pPX#J`p6l^z; zk@VT!nQ;o$wjROd7+~6(rP5{+d@5oup;X-mQXwaBY=7jA|Br|w<0r$BrxcU{$=2?> zL^HmK-J)4U^Cu=MYXhH@{j6K*P5=A?BMXeRVC(bf-Rvd;)p9hZpDo+dl}!8Xrz+v(wl8O?iZD{!ByIEO8Hn$r_rwJ5JOqElY% zq%2l49JRa;#QX(T=WXv1#@-Qs9mxBatJNQ_+|R;(I+R>Yl?Jz#wzH*^FhNCPaIBHI zDcE-b8>3uT%GF}%hFOSKlMZ^9&s)+goWMxu;?DEV1kp@zB-rdDF(#6b7kw=U<~n>V zLwGYH8b;D7v>g79_zB-#VztB;%R;7M=Qc-+>cv{K*F|%sh(n;`E7<9q+c7}M4#ZPO zNqLJ}`D@sy<}>-l&_jWPHI$~}EVUQ8KjzNA0eusI41QdliYeeybQzjPU-pZ<+VJ4m zc)GIw@QW;azwofdA;UJ@@e>0GJBBknr6d96^Jnou9+=8dmLxE{II8?KOPLQw4;9KL zXgWX)gKT9zKE$FSN2)wAw2_%~tIOq4Ip2}xwU$!1ti~;zg^E1s4z~Je(gWv!@K8${ z6dY&i)N89J;G{1}{z=tB{M*wmC#qPC!)?w~k{LN|7;>c1r<9Mv>ywVfY6;7r-xl=5IjA2bN`8gF08&S)(NmJ=Gk9Ql(V3K|SgH3KQ*91r*9z3&# zFU$fldC)}5jX25_VV|`tZjyY7rpX4L>6y_!7fk4JR$mnrg}-rL+*T~YcU z9aR*tlI7xmRIS%8dBTA!gVFqeMhoZ@CVfXj;C-~1Gwz^*se%URuq;Rz8+wxGpV8(fmnT5Oc_Uby=D z4&)YnHcn=#pIG;TUpghc2Z#E>dlQPD}n#;vwV$Njr9D%`sZ<8FEsBv z^0Tb2Xh8GRrjXFqnD=mXYMJq9V{;sXfCiYxaczz^g6n5=BOn~4S(J0BcJ_i+8>^or zvVdH;ExczjjUSWlF(>Aj=Ba5XWPMWJ@=u!1-{?JF!x|DU4{gln*LECvu{5u?ylkIg z4+Cm8T)JLNZ9~jn@Qjd}Bz%6mh>AmYTg_`BrEW<*A2byiVF}W3D=!cPLlAx%PB3j| zNn<*dv8Fla;8*nHYu~cFwin^`$78H&H&kqmR>6|M1I_>)o++To_ONw&Bij|eE&vAQ zPp`VFSORMZl2HyT1a@Faq|I!B75DB&=-p7c{GFf~v*i7~G)pczm0o>X0}%h)y7gNX z%$>G3Bl&^#oE=|lQS%i+c+1tu`4l6dytfmBuY}CX`h$ggGtntcK~k{TI!^-;@RNNDh@3m3ShbBzyfj}Ilk~Y>eE$hRycOO#eCn1JK2rg*trN^J8Dep=nt*xtuy zOEXt|H5YXH3NU`ChwD9HU{GR=uYF;qo)&-c`{pMt0K=|+tS`qmrt`*LM)+9vbr2o;2>jRlppU#f&b{Z>{5U<5iwY4y@VJ#)6R+}vKI#{SXn>`yelP%pMPNvV z^jxbO@tD6}R8WyIx;Ww6KEzgwFe|CwIhMb*q>L^mHY!Kv5+#K7}_;;+;J$!|PauB!DpffK6SCRX-9`gcUUXuFogH z?%wTeNvtxcIxFRB3OsY*e%ADOF^X((GFy0UoNh!jr-wL*b7Pe(1B3KEv-6NUaBW!D z%&=LE(4rIb%2;la1B+U8o^VjKhmgrpPPQ!o>y5 z&UotFN6?6c1MbRZCcAj-lj#zE!cX3!l6LUz&P*+OIJBt^6o}@&kvp8(Y9hlDKA|H{ zn3F3v5IeYRm|d%_2n?l>R&RdZ5JHKFtovN-jsvTrz`U6yKl21>=_x`n20a*JOYft- zo=!Zedb_*5?Ma0_zQYl=sW_Xt7$JGyd282I8s{zX1Q-qyq|H-CC*UjuPj=v?*)0BAZ}fsbPSJ-`V-a({tM=rq+|RDoth4SceGH;&Q_r)8JaV0jw0+ zU^juVjH6&@ngYvPC{Q~wrCRPBP}ijZwHaAUwK`vn`bH%&)6H|Mwj<3~E*%wNf3a!O z(ux;Wvtcoz%Ga+YlT(wV52`D8Rg9vR7h`#n4O=>e;^ZD8s*Ir08ZhF`4=A4v5DIM_ z(6Y2>s6B^4Ngq)Ou}1*KZ%*Y~aRZV>GlRWF!7g*Q4u$LefZx32>2&3{Lvl-Mn5%Kv zJY*D&(g4&O%_@B`bj*wj+I!3U8Yw-gwbrFlGh6FoY$%J@-rAs85pRZKVc}wSnx%XLnap{Ke!eujk!}rU)rtn*=4r zn)zTtc^8nDI&0+e!LBML8=&}K$!5g_2XdBFn8wh#Gz6(tR%Y3Hgu&No%b}m3mI96# zaeJ4oVMalCFpRL|smU}NFAa?YRF41MN-!LGWxz-ZC_iy@Ktxe3;Fa`3z)VY)E}$Vyk<+TE|*&-qKq+UUuIn^Nv8 z_R2H+GLf4p@juEGe&LnV*pZMLr%5Jl6~myM^9(i$ogxC>)eP`d0nARM0>x;Q`f4^I zwAbXy@}LXT2Y^~YTMjRX63DxL-~Jmg_a1D;sP zm2a?wz3LGr#;}9ipJ1CSA5OX>a2$)mx3SQ?7lS(r#CMZR8^X*QsiJ)=kPdJ`+<@>K zs8|S-b^tRNu;)?K^0fUzy;E)^zr>Sqr`k z*9}>Ys2^$36ko(MKTG;xsS%&i)mw4=v^55t*bV2Y;j&psmnjZfT6#C4Rofg8j?h0x zRnBRntrqf_DYZGJ_=c6O0x0;O2SarAK9A+W5#jSGg?pS|bb6x-1lCU-U1kgjNC~$o zNqmM*<0tK=2mD5+K1MN(5OSFxcO&UleEHq$)g@fM4cXvMNbkzN9_NFazR2SAk7)(K zx1#+x1B)O$;wwz(^o$&*Q6SVrZPazvimFn<-14BCQ1@El!y+8cEui1(z*5ei{*OLGSQ|39NnO%1bgEcQgtJYK*ts3H3jBuEs95m)kLbQiEdpqtD#{jHzzVq57w ziZVkKDG{QN0}--Qc`v@t%-{`v&$9-*<3WmOo<_dKVCAwO6r;)nO9Y)mjcmWk?XE8Bo~p5HW=iPWHsWZO+zv7S3pc#GKKCs>|7= zq{1FSu-GgDnR87S@tuOh`#7my%gA@Tm{F)g#^ExNzB=TU8?IvQv~=qmnQ$6 z;O@Ns3Ka|woeY|2F*wkKsX6LgYmSZlh5kGCf?J%dbZtek<( zub=V+Ddyo#JN^CAw3Fn?majqB0ejPuqbB%ih8trx&G1R{sTg>Z?1OB&B;1fsZdE!_ z4E0b+B^pEDG%UJqBiIzZ!hTRq8yYrco_K;oJxis1?e&g3q7259SjW$Ck=^Q~I4H@1 z?X7<+eU^%{?ckUoc?p1{Z%&w+C*p7@9=S+FM@#N|b9yQDUKsv7UYBT~-acm4k&5XK zT3WzJ&hwsH9#ltIyUQ@2NmM8SFw?-(&2-*zM$Vn#oE^r)OJ zr?nAWLd`c#)6w@GwZ=6$Yrl-?n*!oE*Dv_=A#;9TU1X>rS{NkR3>)#JS`QW=?ZeR+ zLSqxu5#1Nf`v+c9j8PXO2=t=k> zeZRN?ru&d~t4xx#1j0zH*|`d`49WB}m5u|hvbRaZhOeoyjmn3%OJ04z%>`TlZUrNx z&I6$YA?>|*!ml9T)f%MUTDF5l$yP!K6Fpf7QZ6d$k1;q5G{nC=6xa5& zKJ1PZq$0wBW~MO7hrIe8MmIlJ^i=KIZUcm2>+APdZ?E|R>uv6y^uy>mAni{2kNSK4 zi62eR$gJDaM+9Ra8bN5pOOg&&BQ{-GOR6!*!H1TC=UOrC5YGGaELVNANLnYNqv|(~ z0ll93^!bcP=(90DojLbXOaMrxR^W2@;e_HGOyu8m90MSeyQL+xV~GtOm1T#QD?dvo zY00X6CBlZl22^blNn+g*GrL=!$A3>wGS)RPEyU+tf;BPI-PSF zYeSR$X{D@!9b=%MhODktNV654OISuR1gEfxAA7MR(;P9}sBdW(jPn7zKw+YRkS8Gr zjA`8NYto!bV4O+GcOAfWE6~GenTWU zY{wA`GF?+vFh2-cV7MhKI4<^>WK&qTgp~6nO>S?qFm;u*af64F($v!Y?H()~B&r$z zQYpOvT8jTT%{@c_-XGu$Z%PJ!P|@eSrO!s{w<;~CNa8|n0e~batYrSNe0l)(h-p~= zCAmB48$%(;0A4!rVfA@;1a(Y(QbM_d4Fw`=qeEVO`x-O~gvq1i{vLp8F%=$nz>bDH zvF+Fd^cy^kId!UNiA)TI@XS(dwa~zanAsvtcjM=Gw{(MEnNYO#_Gjo*o2PT!p(8qy zDa>(!>HWf2SO@VTPFbkY(lZwY!91xiew8q2FlkSniw$olj{)5?Kjxe75EIj3$X!S@ z@wFo_XtufoZkbTP8DW_QkLcr8WoxDM&MsFipvJh>PJ=Fi_FBH=g93W}JtS&z=&&Vz`EO`XK}2h!ZEn>qtE@y`eaw9@2n z3RrK%k<1}xC{^<=R1|wwR~A1J8KT~%O2v7}7IP2`L6y$;lX#U2-^J-Rtb^TYP@5Kn zm|V*xEH0fKB%V08S0 zO)?Eh8PYP(X&VsSNeEyK64WqkqEjH-pNL;P*Ia|K40l2{wucC}*Rie%w#xhXu&Vb_ z_xJ3%(TRv0glOv|HJnX|1+EzXVgrnGsm7H=>>?0j7*M z;|%%8XUU?nN7d87d8iTb9{A90egbfFf`Q5QeZ(f0Iy-y4uOgcaD%VCdN+pl6b0p6j znxBVdh>%aOY5$zwli|T8YtVRDD9;|W83MT}Ze`%TrT&qryx&m+O1wwPZmjQfVvp$F zTCca$+p)r_Bd>r&8@iy2#}9-Uz#H{WX|=x(hpXfeW0g1niV;vIOFagf9TImBig4IR zhSM<-;A8j%Kiv#=npt@y$$}Y~!oaOqW58g;@I-qSBjZA*nsiPy`G~1zKZ=Q z1)d$-F=u}p3|z1luAu70i=~OToLUfWIx5$PsYJqieUGzS~0}PPPPm*C$gl}@>$k-kc z)l@3NZ5OS^P%X=j@_x=(MGu*xd;(xuCQYglRFK); zh@dvm6po-*nQ+LZC_=hf6%H)&iA+9?)Kj%P8tx-2wsVLb zjVa4^!N5lwX@{7Mst~A8nWlL$6#^z z0%`arjgcY9wpM@g=n1T`*C)(){Zt9E|o+yJsIi`5YBo#KNt8gS8$tD?M`3W?ym zHtDvW8q$qE$XV9$P@rBF=|-HWAC)l3DOTA)1yFrqax}pXW|t4^q%;iv1ce2dNK0hX zyuUqmL(eyafDcW9?ukI6AZ!dKZg-G-dCWCelivQpaMT?gGY;u@v4eWdOanfyq(%4$ zh(?IHw7eEfEp6gDQmA`aIM<=x&Nv0bv&;oyA%r#^n{pEx^ht?8!}*QXtG8$A*BOjwf_stUvmZ39wG zP};!0@x}umj@%n>^zpQmqMn~`LD9MlC=;`5Eg`uGAj`gC3q7X8vIwD*pO8^9HPh6d zg=(E31*Y{E1)}vA2~WX7=IcHGBnD*Ein=9cdYsV!Vn)sUsKiXto3nYM4=i$n0eYM{ z>yi;Y!JMQn3ZgZd_QcF|Ns)CN+P65;^bUbMb8x#HLE z$|h=dHWbL~m+#z(wQAD*JX@?W`IgbKuJyA?kVgs)(EUY?1c_MzF66=Di|+)Tj6zs4 z^^pvMeew{dYzogpm|IO?swuqcN8-+1I;CuE%&W?F}Ad z#c&79i6ic$->%j_+X4c7myUc&ZXRQdduv;(pR8`w-OwN_RNVzxLqrHgNB8FzplB=b4zx)PNq%DJpgL* z*O!}R?oNq$qDPYPOaiSUOY&ZpbYU-xP6>WPT|N1d44FF$DZ>f_ZXA|D=%UkN(7Rd{ z!xAl-G8wS3v0Y2^T&wcfgbfx#;>PVyj2hLso>WSq#u;=<-~0AeZH9B9`|{{o@o$!s z{>0a`DMw*GD89K|RCJ@kh_ZN^V!-+{W~$60GPW%%l(wgEaS?REUYhN4F|y}uF58=V zSm7;$vgftcG)xB67UvWz9WlvcR`%PTFhfV33B9WFx*TcS96@RBVp zHChTiRT4t};MD<_hA-K1Xn`o5>S-RP#J-VKvw=D!FxkbruTetj&LIvqs%8-Nx) zOfwXs>?iNArsxP#o}ReB(CV-(ndvnvyfL4=P_l)!0=L>cQ0p`S>cf!YZ}wjGteZ*Q ziRm@Wg`TpVkqm}@*Q~(|PsL)2bd_~&NdgQkLF{McHjL7&=m@PAjY{5FlOt`|8DCF? zyK=5yO2=n3!)5&A$9=ICnz-pkrYd9$21?WVMzdwWWMMd36r=*nMi$M`lkep;eZi2o zX~CoEXS0ekxiHME#DLSr@st2ig0~=*?l_Y7#i+a@)Ov2iftVh%1cuekSb_j7AMsJ| z84`P)6)aoyuYAC&m~S(if@KR!_9QYVcwRGi39D@Vk^h4AM>Cfx?2g&VR{tb}KV`GY z-U!1ZO;hIWOG6;x!n9(FB_pOuIf7NjsmXA3z>k@Q!#T7P(bKw@D^RMx?O2nR1?Aev zZqc{XJ$y(}=QL_#;{Ht3R$ylfxFekme+&7ssItf+4|sCf2_CqGmGP~cTcs;M7gKTM zUEzqsQ9wGwQG)9hXTesHtkbjq{vs0nTo_ayT-`J?v}c8dXxJ-G^SLEs!3d=yCbH5H z@04ESBBvY>L8h`oZ1))sIr9$=2T$v|(L&E6AUc7HZJHq?fIqg5Avry$X_u+U^Ay3s;Xb||*5?FFq+1kZJi*Brwdf%cyqinb z2&q|{3^SRLj(9;fp^L=@gxNfy zuH+l0%H2{+gkg|#C@oEXPyvXuHRa3zT_$=i$DDpp|}85J!Sk2Y-4^dd#VUQ`oj5dwR7N z)MF+xM6O|pHhPZ^`+GaK+ITb^HUse4I?ymwH9cTM2nkp@(HD60zR6WgAE0pkX{s~t z;B{2SR3+=he0oa8sd34dQ6VpvU@@e=36qzjTBZ=D)`tsdvlEl_=!JlIC-Q1|KBJF% zM$UU`umH!T(1i6?klAZ>0?F*Om@I@4s9ahuf?l&)=&o2Tz=$+fZIBGE=nrZdOT7S6 zb)yB@=fg#0^k{eNlD+ZLhQA?X4C7jX&2$ymtf}Lr4!K^=CjE#GHxV!TPRUe|Pa-gZ zFi{twCRj$o0D)+HRFzo3gs7^;@x;h1+}r**2MhCBzLvBr*1{c*dt01UjvP}OhIq%4 zQhbwK3Pg;BTmtcgR*@zVPv_@L-n%nse;hg= z5!-`>`@_e-*?IHwn?)|Jc(Zo6&*-pp724}dacZ@-A7#i9pu(pbAB!eCZ(ez`-hE3a z__R|#VNAkny_uybu&Xr;EU-V>xdOP|+z4U!&K_oyhUDB732W_j8ts{h#8F`l>b*D} zp+73B)$kFV)AX4}=;E7owJhow4ccU=`V&G0!C7EbN{L)o-2_C*Tii;KmCI(oKXm*@nxjFz20cNusPXT znT+=C_Qup!pk^xI$a%PxNZ4F3PZ z?tk{}pZ6F1`DOh7*Zlsc-~I)^il1NS#cOd_{hi;^ 0) THEN node.obj.used := TRUE END + END MarkAsUsed; + + + PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object); + VAR n: DevCPT.Name; o: DevCPT.Object; + BEGIN + n := "@@ "; DevCPT.Insert(n, obj); obj.name^ := name$; (* avoid err 1 *) + obj.mode := Var; obj.typ := typ; + o := DevCPT.topScope.scope; + IF o = NIL THEN DevCPT.topScope.scope := obj + ELSE + WHILE o.link # NIL DO o := o.link END; + o.link := obj + END + END GetTempVar; + + + (* ---------- constant operations ---------- *) + + PROCEDURE Log (x: DevCPT.Node): INTEGER; + VAR val, exp: INTEGER; + BEGIN + exp := 0; + IF x.typ.form = Int64 THEN + RETURN -1 + ELSE + val := x.conval.intval; + IF val > 0 THEN + WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END + END; + IF val # 1 THEN exp := -1 END + END; + RETURN exp + END Log; + + PROCEDURE Floor (x: REAL): REAL; + VAR y: REAL; + BEGIN + IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x + ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN + y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0); + RETURN SHORT(ENTIER(x - y)) + y + ELSE RETURN SHORT(ENTIER(x)) + END + END Floor; + + PROCEDURE SetToInt (s: SET): INTEGER; + VAR x, i: INTEGER; + BEGIN + i := 31; x := 0; + IF 31 IN s THEN x := -1 END; + WHILE i > 0 DO + x := x * 2; DEC(i); + IF i IN s THEN INC(x) END + END; + RETURN x + END SetToInt; + + PROCEDURE IntToSet (x: INTEGER): SET; + VAR i: INTEGER; s: SET; + BEGIN + i := 0; s := {}; + WHILE i < 32 DO + IF ODD(x) THEN INCL(s, i) END; + x := x DIV 2; INC(i) + END; + RETURN s + END IntToSet; + + PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct); + CONST MAXL = 9223372036854775808.0; (* 2^63 *) + BEGIN + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF form IN intSet THEN + IF x.realval = 0 THEN typ := DevCPT.int32typ + ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ + ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ + END + ELSIF form IN realSet THEN (* SR *) + typ := DevCPT.real64typ + ELSIF form IN charSet THEN + IF x.intval <= 255 THEN typ := DevCPT.char8typ + ELSE typ := DevCPT.char16typ + END + ELSE typ := DevCPT.undftyp + END + END GetConstType; + + PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT); + VAR type: DevCPT.Struct; + BEGIN + GetConstType(x, form, errno, type); + IF ~DevCPT.Includes(form, type.form) + & ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + & ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + & ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN + err(errno); x.intval := 1; x.realval := 0 + END +(* + IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER)) + & (x.realval + x.intval <= MAX(INTEGER)) THEN + x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0 + END; + IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval)) + OR (form = Int32) & (x.realval # 0) + OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) + OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127)) + OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535)) + OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255)) + OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN + err(errno); x.intval := 1; x.realval := 0 + END +*) + END CheckConstType; + + PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER); + VAR sr: SHORTREAL; + BEGIN + IF from = Set THEN + x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {}; + ELSIF from IN intSet + charSet THEN + IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval) + ELSIF to IN intSet THEN CheckConstType(x, to, 203) + ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc + ELSE (*to IN charSet*) CheckConstType(x, to, 220) + END + ELSIF from IN realSet THEN + IF to IN realSet THEN CheckConstType(x, to, 203); + IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END (* reduce precision *) + ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203) + END + END + END ConvConst; + + PROCEDURE Prepare (x: DevCPT.Const); + VAR r: REAL; + BEGIN + x.realval := x.realval + x.intval DIV 32768 * 32768; + x.intval := x.intval MOD 32768; + r := Floor(x.realval / 4096) * 4096; + x.intval := x.intval + SHORT(ENTIER(x.realval - r)); + x.realval := r + (* ABS(x.intval) < 2^15 & ABS(x.realval) MOD 2^12 = 0 *) + END Prepare; + + PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x + y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval + y.intval; z.realval := x.realval + y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = - y.realval) THEN err(212) + ELSE z.realval := x.realval + y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 206, type) + END AddConst; + + PROCEDURE NegateConst (y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := - y *) + BEGIN + IF type.form IN intSet THEN Prepare(y); z.intval := -y.intval; z.realval := -y.realval + ELSIF type.form IN realSet THEN z.realval := -y.realval + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END NegateConst; + + PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x - y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.intval := x.intval - y.intval; z.realval := x.realval - y.realval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = y.realval) THEN err(212) + ELSE z.realval := x.realval - y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 207, type) + END SubConst; + + PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x * y *) + BEGIN + IF type.form IN intSet THEN + Prepare(x); Prepare(y); + z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval; + z.intval := x.intval * y.intval + ELSIF type.form IN realSet THEN + IF (ABS(x.realval) = DevCPM.InfReal) & ( y.realval = 0.0) THEN err(212) + ELSIF (ABS(y.realval) = DevCPM.InfReal) & (x.realval = 0.0) THEN err(212) + ELSE z.realval := x.realval * y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END MulConst; + + PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x / y *) + BEGIN + IF type.form IN realSet THEN + IF (x.realval = 0.0) & (y.realval = 0.0) THEN err(212) + ELSIF (ABS(x.realval) = DevCPM.InfReal) & (ABS(y.realval) = DevCPM.InfReal) THEN err(212) + ELSE z.realval := x.realval / y.realval + END + ELSE HALT(100) + END; + GetConstType(z, type.form, 204, type) + END DivConst; + + PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct); + (* x := x DIV y | x MOD y *) + BEGIN + IF type.form IN intSet THEN + IF y.realval + y.intval # 0 THEN + Prepare(x); Prepare(y); + quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval)); + quot.intval := 0; Prepare(quot); + x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval; + x.intval := x.intval - quot.intval * y.intval; + IF y.realval + y.intval > 0 THEN + WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + ELSE + WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END; + WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END + END; + IF div THEN x.realval := quot.realval; x.intval := quot.intval END; + GetConstType(x, type.form, 204, type) + ELSE err(205) + END + ELSE HALT(100) + END + END DivModConst; + + PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x = y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0 + | Real32, Real64: res := x.realval = y.realval + | Set: res := x.setval = y.setval + | String8, String16, Comp (* guid *): res := x.ext^ = y.ext^ + | NilTyp, Pointer, ProcTyp: res := x.intval = y.intval + END; + RETURN res + END EqualConst; + + PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < y *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Undef: res := TRUE + | Byte, Char8..Int32, Char16: res := x.intval < y.intval + | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0 + | Real32, Real64: res := x.realval < y.realval + | String8, String16: res := x.ext^ < y.ext^ + | Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108) + END; + RETURN res + END LessConst; + + PROCEDURE IsNegConst (x: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < 0 OR x = (-0.0) *) + VAR res: BOOLEAN; + BEGIN + CASE form OF + | Int8..Int32: res := x.intval < 0 + | Int64: Prepare(x); res := x.realval + x.intval < 0 + | Real32, Real64: res := (x.realval <= 0.) & (1. / x.realval <= 0.) + END; + RETURN res + END IsNegConst; + + + PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x + END NewIntConst; + + PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x + END NewLargeIntConst; + + PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node; + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc; + IF typ = NIL THEN typ := DevCPT.real64typ END; + x.typ := typ; + RETURN x + END NewRealConst; + + PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node; + VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt; + BEGIN + x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst(); + IF lstr # NIL THEN + x.typ := DevCPT.string16typ; + NEW(ext, 3 * len); i := 0; j := 0; + REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0; + x.conval.ext := ext + ELSE + x.typ := DevCPT.string8typ; x.conval.ext := str + END; + x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len; + RETURN x + END NewString; + + PROCEDURE CharToString8(n: DevCPT.Node); + VAR ch: SHORTCHAR; + BEGIN + n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2); + IF ch = 0X THEN n.conval.intval2 := 1 ELSE n.conval.intval2 := 2; n.conval.ext[1] := 0X END ; + n.conval.ext[0] := ch; n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString8; + + PROCEDURE CharToString16 (n: DevCPT.Node); + VAR ch, ch1: SHORTCHAR; i: INTEGER; + BEGIN + n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4); + IF n.conval.intval = 0 THEN + n.conval.ext[0] := 0X; n.conval.intval2 := 1 + ELSE + i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i); + n.conval.ext[i] := 0X; n.conval.intval2 := 2 + END; + n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL + END CharToString16; + + PROCEDURE String8ToString16 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string16typ; ext := n.conval.ext; + NEW(new, 2 * n.conval.intval2); i := 0; j := 0; + REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String8ToString16; + + PROCEDURE String16ToString8 (n: DevCPT.Node); + VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt; + BEGIN + n.typ := DevCPT.string8typ; ext := n.conval.ext; + NEW(new, n.conval.intval2); i := 0; j := 0; + REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0; + n.conval.ext := new; n.obj := NIL + END String16ToString8; + + PROCEDURE StringToGuid (VAR n: DevCPT.Node); + BEGIN + ASSERT((n.class = Nconst) & (n.typ.form = String8)); + IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END; + n.typ := DevCPT.guidtyp + END StringToGuid; + + PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT); + VAR ntyp: DevCPT.Struct; + BEGIN + ntyp := n.typ; + IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n) + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN + IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *) + ELSE err(e) + END + ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN + IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n) + ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n) + ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN + (* ok *) + ELSE err(e) + END + ELSE err(e) + END + END CheckString; + + + PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.typ := typ; + node.left := x; node.right := y; x := node + END BindNodes; + + PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN; + BEGIN + RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst)) + OR (x.typ.form IN {String8, String16}) + END NotVar; + + + PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL; + BEGIN f := x.typ.form; g := typ.form; + IF x.class = Nconst THEN + IF g = String8 THEN + IF f = String16 THEN String16ToString8(x) + ELSIF f IN charSet THEN CharToString8(x) + ELSE typ := DevCPT.undftyp + END + ELSIF g = String16 THEN + IF f = String8 THEN String8ToString16(x) + ELSIF f IN charSet THEN CharToString16(x) + ELSE typ := DevCPT.undftyp + END + ELSE ConvConst(x.conval, f, g) + END; + x.obj := NIL + ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g)) + THEN + (* don't create new node *) + IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END + ELSE + IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN (* propagate to leaf nodes *) + Convert(x.left, typ); Convert(x.right, typ) + ELSE + node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node; + END + END; + x.typ := typ + END Convert; + + PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER); (* check expression compatibility *) + VAR f, g: INTEGER; new: DevCPT.Struct; + BEGIN + f := left.typ.form; g := right.typ.form; new := left.typ; + IF f IN intSet + realSet THEN + IF g IN intSet + realSet THEN + IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst) + (* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(right.conval.realval) = DevCPM.InfReal)) *) + OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst) + (* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32) + OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN + new := DevCPT.real32typ (* SR *) + ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ + ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ (* SR *) + ELSIF op = slash THEN new := DevCPT.real64typ + ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ + ELSE new := DevCPT.int32typ + END + ELSE err(100) + END + ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN + IF f = String8 THEN StringToGuid(left) END; + IF g = String8 THEN StringToGuid(right) END; + IF left.typ # right.typ THEN err(100) END; + f := Comp + ELSIF f IN charSet + {String8, String16} THEN + IF g IN charSet + {String8, String16} THEN + IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN + new := DevCPT.string16typ + ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ + ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ + ELSIF op = plus THEN + IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ + ELSE new := DevCPT.string8typ + END + END; + IF (new.form IN {String8, String16}) + & ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst)) + THEN + err(100) + END + ELSE err(100) + END + ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN + IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp) + & ~((f = Pointer) & (g = Pointer) + & (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END + ELSIF f # g THEN err(100) + END; + IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN + IF g # new.form THEN Convert(right, new) END; + IF f # new.form THEN Convert(left, new) END + END + END Promote; + + PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *) + VAR ft, at: DevCPT.Struct; + BEGIN + WHILE fp # NIL DO + IF ap # NIL THEN + ft := fp.typ; at := ap.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ap.ptyp # NIL THEN at := ap.ptyp END; (* get original formal type *) + IF ~DevCPT.EqualType(ft, at) + OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis) + OR checkNames & (fp.name^ # ap.name^) THEN err(115) END ; + ap := ap.link + ELSE err(116) + END; + fp := fp.link + END; + IF ap # NIL THEN err(116) END + END CheckParameters; + + PROCEDURE CheckNewParamPair* (newPar, iidPar: DevCPT.Node); + VAR ityp, ntyp: DevCPT.Struct; + BEGIN + ntyp := newPar.typ.BaseTyp; + IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN + IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev) + THEN (* ok *) + ELSE err(168) + END + ELSIF ntyp.extlev = 0 THEN (* ok *) + ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN + IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END + ELSE err(168) + END + END CheckNewParamPair; + + + PROCEDURE DeRef*(VAR x: DevCPT.Node); + VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF typ.form = Pointer THEN + btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj; + IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN + btyp.pbused := TRUE + END ; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 0 + ELSE err(84) + END + END DeRef; + + PROCEDURE StrDeref*(VAR x: DevCPT.Node); + VAR typ, btyp: DevCPT.Struct; + BEGIN + typ := x.typ; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78) + ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN + IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ + ELSE btyp := DevCPT.string16typ + END; + BindNodes(Nderef, btyp, x, NIL); x.subcl := 1 + ELSE err(90) + END + END StrDeref; + + PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; + BEGIN + f := y.typ.form; + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79) + ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ; + IF f = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.typ.comp = Array THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & ((y.conval.intval < 0) OR (y.conval.intval >= x.typ.n)) THEN err(81) END + ELSIF x.typ.comp = DynArr THEN typ := x.typ.BaseTyp; + IF (y.class = Nconst) & (y.conval.intval < 0) THEN err(81) END + ELSE err(82); typ := DevCPT.undftyp + END ; + BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly + END Index; + + PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object); + BEGIN (*x.typ.comp = Record*) + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(77) END ; + IF (y # NIL) & (y.mode IN {Fld, TProc}) THEN + BindNodes(Nfield, y.typ, x, NIL); x.obj := y; + x.readonly := x.left.readonly OR ((y.vis = externalR) & (y.mnolev < 0)) + ELSE err(83); x.typ := DevCPT.undftyp + END + END Field; + + PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN); + + PROCEDURE GTT(t0, t1: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN + IF ~guard THEN x := NewBoolConst(TRUE) END + ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint) + OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN + IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly + ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node + END + ELSE err(85) + END + END GTT; + + BEGIN + IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112) + ELSIF x.typ.form = Pointer THEN + IF x.typ = DevCPT.sysptrtyp THEN + IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF x.typ.BaseTyp.comp # Record THEN err(85) + ELSIF obj.typ.form = Pointer THEN GTT(x.typ.BaseTyp, obj.typ.BaseTyp) + ELSE err(86) + END + ELSIF (x.typ.comp = Record) & (x.class = Nvarpar) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN + GTT(x.typ, obj.typ) + ELSE err(87) + END ; + IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END + END TypTest; + + PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f: SHORTINT; k: INTEGER; + BEGIN f := x.typ.form; + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (f IN intSet) & (y.typ.form = Set) THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202) + ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in + END + ELSE err(92) + END ; + x.typ := DevCPT.booltyp + END In; + + PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node); + VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Nmop); node.subcl := op; node.typ := typ; + node.left := z; RETURN node + END NewOp; + + BEGIN z := x; + IF ((z.class = Ntype) OR (z.class = Nproc)) & (op # adr) & (op # typfn) & (op # size) THEN err(126) (* !!! *) + ELSE + typ := z.typ; f := typ.form; + CASE op OF + | not: + IF f = Bool THEN + IF z.class = Nconst THEN + z.conval.intval := BoolToInt(~IntToBool(z.conval.intval)); z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(98) + END + | plus: + IF ~(f IN intSet + realSet) THEN err(96) END + | minus: + IF f IN intSet + realSet + {Set} THEN + IF z.class = Nconst THEN + IF f = Set THEN z.conval.setval := -z.conval.setval + ELSE NegateConst(z.conval, z.conval, z.typ) + END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(97) + END + | abs: + IF f IN intSet + realSet THEN + IF z.class = Nconst THEN + IF IsNegConst(z.conval, f) THEN NegateConst(z.conval, z.conval, z.typ) END; + z.obj := NIL + ELSE + IF f < Int32 THEN Convert(z, DevCPT.int32typ) END; + z := NewOp(op, z.typ, z) + END + ELSE err(111) + END + | cap: + IF f IN charSet THEN + IF z.class = Nconst THEN + IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END; + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111); z.typ := DevCPT.char8typ + END + | odd: + IF f IN intSet THEN + IF z.class = Nconst THEN + DivModConst(z.conval, two, FALSE, z.typ); (* z MOD 2 *) + z.obj := NIL + ELSE z := NewOp(op, typ, z) + END + ELSE err(111) + END ; + z.typ := DevCPT.booltyp + | adr: (*ADR*) + IF z.class = Nproc THEN + IF z.obj.mnolev > 0 THEN err(73) + ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc + END; + z := NewOp(op, typ, z) + ELSIF z.class = Ntype THEN + IF z.obj.typ.untagged THEN err(111) END; + z := NewOp(op, typ, z) + ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN + z := NewOp(op, typ, z) + ELSE err(127) + END ; + z.typ := DevCPT.int32typ + | typfn, size: (*TYP, SIZE*) + z := NewOp(op, typ, z); + z.typ := DevCPT.int32typ + | cc: (*SYSTEM.CC*) + IF (f IN intSet) & (z.class = Nconst) THEN + IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN + z := NewOp(op, typ, z) + ELSE err(219) + END + ELSE err(69) + END; + z.typ := DevCPT.booltyp + END + END; + x := z + END MOp; + + PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node); + VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct; + BEGIN + f := x.typ.form; + IF f = y.typ.form THEN + xval := x.conval; yval := y.conval; + CASE op OF + | times: + IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval * yval.setval + ELSIF f # Undef THEN err(101) + END + | slash: + IF f IN realSet THEN DivConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval / yval.setval + ELSIF f # Undef THEN err(102) + END + | div: + IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ) + ELSIF f # Undef THEN err(103) + END + | mod: + IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ) + ELSIF f # Undef THEN err(104) + END + | and: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) & IntToBool(yval.intval)) + ELSE err(94) + END + | plus: + IF f IN intSet + realSet THEN AddConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval + yval.setval + ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN + NEW(ext, LEN(xval.ext^) + LEN(yval.ext^)); + i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END; + j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END; + ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1) + ELSIF f # Undef THEN err(105) + END + | minus: + IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ) + ELSIF f = Set THEN xval.setval := xval.setval - yval.setval + ELSIF f # Undef THEN err(106) + END + | min: + IF f IN intSet + realSet THEN + IF LessConst(yval, xval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | max: + IF f IN intSet + realSet THEN + IF LessConst(xval, yval, f) THEN xval^ := yval^ END + ELSIF f # Undef THEN err(111) + END + | or: + IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval)) + ELSE err(95) + END + | eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp + | lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + | leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp + | geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp + END + ELSE err(100) + END; + x.obj := NIL + END ConstOp; + + PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER; + + PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ; + node.left := x; node.right := y; x := node + END NewOp; + + BEGIN z := x; + IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSE + Promote(z, y, op); + IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y) + ELSE + typ := z.typ; f := typ.form; g := y.typ.form; + CASE op OF + | times: + do := TRUE; + IF f IN intSet THEN + IF z.class = Nconst THEN + IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y + ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE + ELSE val := Log(z); + IF val >= 0 THEN + t := y; y := z; z := t; + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + ELSIF y.class = Nconst THEN + IF EqualConst(y.conval, one, f) THEN do := FALSE + ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL + END + END + END + ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | slash: + IF f IN realSet THEN (* OK *) + ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y) + | div: + do := TRUE; + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSIF EqualConst(y.conval, one, f) THEN do := FALSE + ELSE val := Log(y); + IF val >= 0 THEN + op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp + END ; + IF do THEN NewOp(op, typ, z, y) END; + | mod: + IF f IN intSet THEN + IF y.class = Nconst THEN + IF EqualConst(y.conval, zero, f) THEN err(205) + ELSE val := Log(y); + IF val >= 0 THEN + op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL + END + END + END + ELSIF f # Undef THEN err(104); typ := DevCPT.undftyp + END ; + NewOp(op, typ, z, y); + | and: + IF f = Bool THEN + IF z.class = Nconst THEN + IF IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & IntToBool(y.conval.intval) THEN (* optimize z & TRUE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp + END + | plus: + IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END; + do := TRUE; + IF f IN intSet THEN + IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END + ELSIF f IN {String8, String16} THEN + IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ; + IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END; + IF do THEN + IF z.class = Ndop THEN + t := z; WHILE t.right.class = Ndop DO t := t.right END; + IF (t.right.class = Nconst) & (y.class = Nconst) THEN + ConstOp(op, t.right, y); do := FALSE + ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE + ELSE + NewOp(op, typ, t.right, y); do := FALSE + END + ELSE + IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN + ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE + END + END + END + END ; + IF do THEN NewOp(op, typ, z, y) END; + | minus: + IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END; + IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y) + END; + | min, max: + IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END; + NewOp(op, typ, z, y); + | or: + IF f = Bool THEN + IF z.class = Nconst THEN + IF ~IntToBool(z.conval.intval) THEN z := y END + ELSIF (y.class = Nconst) & ~IntToBool(y.conval.intval) THEN (* optimize z OR FALSE -> z *) + ELSE NewOp(op, typ, z, y) + END + ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp + END + | eql, neq, lss, leq, gtr, geq: + IF f IN {String8, String16} THEN + IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN + z := z.left; y := y.left (* remove LONG on both sides *) + ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *) + y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0 + ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *) + z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0 + END; + typ := DevCPT.booltyp + ELSIF (f IN {Undef, Char8..Real64, Char16, Int64}) + OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN + typ := DevCPT.booltyp + ELSE err(107); typ := DevCPT.undftyp + END; + NewOp(op, typ, z, y) + END + END + END; + x := z + END Op; + + PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR k, l: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126) + ELSIF (x.typ.form IN intSet) & (y.typ.form IN intSet) THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END + END ; + IF y.class = Nconst THEN + l := y.conval.intval; + IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) THEN err(202) END + END ; + IF (x.class = Nconst) & (y.class = Nconst) THEN + IF k <= l THEN + x.conval.setval := {k..l} + ELSE err(201); x.conval.setval := {l..k} + END ; + x.obj := NIL + ELSE BindNodes(Nupto, DevCPT.settyp, x, y) + END + ELSE err(93) + END ; + x.typ := DevCPT.settyp + END SetRange; + + PROCEDURE SetElem*(VAR x: DevCPT.Node); + VAR k: INTEGER; + BEGIN + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END; + IF x.typ.form IN intSet THEN + IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF x.class = Nconst THEN + k := x.conval.intval; + IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k} + ELSE err(202) + END ; + x.obj := NIL + ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit + END ; + ELSE err(93) + END; + x.typ := DevCPT.settyp + END SetElem; + + PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node); + (* x := y, checks assignment compatibility *) + VAR f, g: SHORTINT; y, b: DevCPT.Struct; + BEGIN + y := ynode.typ; f := x.form; g := y.form; + IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ; + CASE f OF + | Undef, String8, String16, Byte: + | Bool, Set: + IF g # f THEN err(113) END + | Int8, Int16, Int32, Int64, Real32, Real64: (* SR *) + IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN + IF ynode.class = Nconst THEN Convert(ynode, x) + ELSIF ~DevCPT.Includes(f, g) THEN err(113) + END + ELSE err(113) + END +(* + IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN + err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END +*) + | Char8, Char16: + IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113) + ELSIF ynode.class = Nconst THEN Convert(ynode, x) + END + | Pointer: + b := x.BaseTyp; + IF DevCPT.Extends(y, x) + OR (g = NilTyp) + OR (g = Pointer) + & ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp)) + THEN (* ok *) + ELSIF (b.comp = DynArr) & b.untagged THEN (* pointer to untagged open array *) + IF ynode.class = Nconst THEN CheckString(ynode, b, 113) + ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113) + END + ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN (* p := ADR(r) *) + IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113) + ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113) + END + ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8})) + THEN + IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END + ELSE err(113) + END + | ProcTyp: + IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *) + ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN + IF ynode.obj.mode = LProc THEN + IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END + END; + IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN + IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE) + ELSE err(117) + END + ELSE err(113) + END + ELSE err(113) + END + | NoTyp, NilTyp: err(113) + | Comp: + x.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *) + IF x.comp = Record THEN + IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END + ELSIF g IN {Char8, Char16, String8, String16} THEN + IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ) + ELSE CheckString(ynode, x, 113); + END; + IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN + err(114) + END + ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *) + ELSE err(113) + END + END + END CheckAssign; + + PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node); (* x := str or x[0] := 0X *) + BEGIN + ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16})); + IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN (* x := "" -> x[0] := 0X *) + Index(x, NewIntConst(0)); + str.typ := x.typ; str.conval.intval := 0; + END; + BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign + END AssignString; + + PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN); + BEGIN + IF (x.class = Nmop) & (x.subcl = val) THEN x := x.left END ; + IF x.class = Nguard THEN x := x.left END ; (* skip last (and unique) guard *) + IF (x.class = Nvar) & (dynArrToo OR (x.typ.comp # DynArr)) THEN x.obj.leaf := FALSE END + END CheckLeaf; + + PROCEDURE CheckOldType (x: DevCPT.Node); + BEGIN + IF ~(DevCPM.oberon IN DevCPM.options) + & ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN + err(198) + END + END CheckOldType; + + PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT); (* par0: first param of standard proc *) + VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node; + BEGIN x := par0; f := x.typ.form; + CASE fctno OF + haltfn: (*HALT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(218) + END + ELSIF (DevCPM.java IN DevCPM.options) + & ((x.class = Ntype) OR (x.class = Nvar)) + & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x) + ELSE err(69) + END ; + x.typ := DevCPT.notyp + | newfn: (*NEW*) + typ := DevCPT.notyp; + IF NotVar(x) THEN err(112) + ELSIF f = Pointer THEN + IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ; + IF x.readonly THEN err(76) + ELSIF (x.typ.BaseTyp.attribute = absAttr) + OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + f := x.typ.BaseTyp.comp; + IF f IN {Record, DynArr, Array} THEN + IF f = DynArr THEN typ := x.typ.BaseTyp END ; + BindNodes(Nassign, DevCPT.notyp, x, NIL); x.subcl := newfn + ELSE err(111) + END + ELSE err(111) + END ; + x.typ := typ + | absfn: (*ABS*) + MOp(abs, x) + | capfn: (*CAP*) + MOp(cap, x) + | ordfn: (*ORD*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f = Char8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Set THEN Convert(x, DevCPT.int32typ) + ELSE err(111) + END + | bitsfn: (*BITS*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp) + ELSE err(111) + END + | entierfn: (*ENTIER*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | lentierfcn: (* LENTIER *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ) + ELSE err(111) + END ; + x.typ := DevCPT.int64typ + | oddfn: (*ODD*) + MOp(odd, x) + | minfn: (*MIN*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(FALSE) + | Char8: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0); x.typ := DevCPT.char8typ + | Int8: x := NewIntConst(-128) + | Int16: x := NewIntConst(-32768) + | Int32: x := NewIntConst(-2147483648) + | Int64: x := NewLargeIntConst(0, -9223372036854775808.0E0) (* -2^63 *) + | Set: x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | maxfn: (*MAX*) + IF x.class = Ntype THEN + CheckOldType(x); + CASE f OF + Bool: x := NewBoolConst(TRUE) + | Char8: x := NewIntConst(0FFH); x.typ := DevCPT.char8typ + | Char16: x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ + | Int8: x := NewIntConst(127) + | Int16: x := NewIntConst(32767) + | Int32: x := NewIntConst(2147483647) + | Int64: x := NewLargeIntConst(-1, 9223372036854775808.0E0) (* 2^63 - 1 *) + | Set: x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *) + | Real32: x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ) + | Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ) + ELSE err(111) + END; + x.hint := 1 + ELSIF ~(f IN intSet + realSet + charSet) THEN err(111) + END + | chrfn: (*CHR*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | lchrfn: (* LCHR *) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ) + ELSE err(111); x.typ := DevCPT.char16typ + END + | shortfn: (*SHORT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int16 THEN Convert(x, DevCPT.int8typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ) + ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ) + ELSIF f = String16 THEN Convert(x, DevCPT.string8typ) + ELSE err(111) + END + END + | longfn: (*LONG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSE + IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form + END; + IF f = Int8 THEN Convert(x, DevCPT.int16typ) + ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ) + ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ) + ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ) + ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ) + ELSIF f = String8 THEN Convert(x, DevCPT.string16typ) + ELSE err(111) + END + END + | incfn, decfn: (*INC, DEC*) + IF NotVar(x) THEN err(112) + ELSIF ~(f IN intSet) THEN err(111) + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | inclfn, exclfn: (*INCL, EXCL*) + IF NotVar(x) THEN err(112) + ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp + ELSIF x.readonly THEN err(76) + END; + MarkAsUsed(x) + | lenfn: (*LEN*) + IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126) (* !!! *) + (* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.class = Nconst THEN + IF x.typ.form = Char8 THEN CharToString8(x) + ELSIF x.typ.form = Char16 THEN CharToString16(x) + END + END; + IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END + END + | copyfn: (*COPY*) + IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END; + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END + ELSE err(111); x.typ := DevCPT.int32typ + END + | adrfn: (*ADR*) + IF x.class = Ntype THEN CheckOldType(x) END; + CheckLeaf(x, FALSE); MOp(adr, x) + | typfn: (*TYP*) + CheckLeaf(x, FALSE); + IF x.class = Ntype THEN + CheckOldType(x); + IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(adr, x) + ELSE + IF x.typ.form = Pointer THEN DeRef(x) END; + IF x.typ.comp # Record THEN err(111) END; + MOp(typfn, x) + END + | sizefn: (*SIZE*) + IF x.class # Ntype THEN err(110); x := NewIntConst(1) + ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN + CheckOldType(x); x.typ.pvused := TRUE; + IF typSize # NIL THEN + typSize(x.typ); x := NewIntConst(x.typ.size) + ELSE + MOp(size, x) + END + ELSE err(111); x := NewIntConst(1) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ) + ELSIF f # Int32 THEN err(111) + END + | ccfn: (*SYSTEM.CC*) + MOp(cc, x) + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet + charSet + {Byte, Set}) THEN err(111) + END + | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END + | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (f IN intSet) & (x.class = Nconst) THEN + IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220) + END + ELSE err(69) + END + | valfn: (*SYSTEM.VAL*) + IF x.class # Ntype THEN err(110) + ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111) + ELSE CheckOldType(x) + END + | assertfn: (*ASSERT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := NewBoolConst(FALSE) + ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE) + ELSE MOp(not, x) + END + | validfn: (* VALID *) + IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN + MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil()) + ELSE err(111) + END; + x.typ := DevCPT.booltyp + | iidfn: (* COM.IID *) + IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x) + ELSE + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN + IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END + ELSE err(111) + END; + x.class := Nconst; x.typ := DevCPT.guidtyp + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f # Pointer THEN err(111) + END + END ; + par0 := x + END StPar0; + + PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE); + (* x: second parameter of standard proc *) + VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node; + + PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node; + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(class); node.subcl := subcl; + node.left := left; node.right := right; RETURN node + END NewOp; + + BEGIN p := par0; f := x.typ.form; + CASE fctno OF + incfn, decfn: (*INC DEC*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); p.typ := DevCPT.notyp + ELSE + IF f # p.typ.form THEN + IF f IN intSet THEN Convert(x, p.typ) + ELSE err(111) + END + END ; + p := NewOp(Nassign, fctno, p, x); + p.typ := DevCPT.notyp + END + | inclfn, exclfn: (*INCL, EXCL*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202) + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | lenfn: (*LEN*) + IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69) + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + L := SHORT(x.conval.intval); typ := p.typ; + WHILE (L > 0) & (typ.comp IN {DynArr, Array}) DO typ := typ.BaseTyp; DEC(L) END ; + IF (L # 0) OR ~(typ.comp IN {DynArr, Array}) THEN err(132) + ELSE x.obj := NIL; + IF typ.comp = DynArr THEN + WHILE p.class = Nindex DO + p := p.left; INC(x.conval.intval) (* possible side effect ignored *) + END; + p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ + ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ + END + END + END + | copyfn: (*COPY*) + IF NotVar(x) THEN err(112) + ELSIF x.readonly THEN err(76) + ELSE + CheckString(p, x.typ, 111); t := x; x := p; p := t; + IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x) + ELSE p := NewOp(Nassign, copyfn, p, x) + END + END ; + p.typ := DevCPT.notyp; MarkAsUsed(x) + | ashfn: (*ASH*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208) + ELSIF (p.class = Nconst) & (x.class = Nconst) THEN + n := x.conval.intval; + IF n > 0 THEN + WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END + ELSE + WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END + END; + p.obj := NIL + ELSE + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ + END + ELSE err(111) + END + | minfn: (*MIN*) + IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END + | maxfn: (*MAX*) + IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) END + | newfn: (*NEW(p, x...)*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp = DynArr THEN + IF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) + & (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END + ELSE err(111) + END ; + p.right := x; p.typ := p.typ.BaseTyp + ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN + typ := p.left.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF typ.sysflag = interface THEN + typ := x.typ; + WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END; + IF (f = Pointer) & (typ.sysflag = interface) THEN + p.right := x + ELSE err(169) + END + ELSE err(64) + END + ELSE err(111) + END + | thisrecfn, (*THISRECORD*) + thisarrfn: (*THISARRAY*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Int8, Int16, Int32} THEN + IF f < Int32 THEN Convert(x, DevCPT.int32typ) END; + p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp + ELSE err(111) + END + | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF ~(f IN intSet) THEN err(111) + ELSE + IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ; + p.typ := p.left.typ + END + | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN {Undef..Set, NilTyp, Pointer, ProcTyp, Char16, Int64} THEN + IF (fctno = getfn) OR (fctno = getrfn) THEN + IF NotVar(x) THEN err(112) END ; + t := x; x := p; p := t + END ; + p := NewOp(Nassign, fctno, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.notyp + | bitfn: (*SYSTEM.BIT*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + p := NewOp(Ndop, bit, p, x) + ELSE err(111) + END ; + p.typ := DevCPT.booltyp + | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN (* ok *) + ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN + typ := x.typ; + WHILE typ.comp = DynArr DO typ := typ.BaseTyp END; + tp1 := p.typ; + WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END; + IF typ.size # tp1.size THEN err(115) END + ELSE err(115) + END + ELSIF p.typ.comp = DynArr THEN err(115) + ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN + i := 0; n := 0; + WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END; + x := NewIntConst(n) + ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111) + END ; + IF (x.class = Nconst) & (x.typ = p.typ) THEN (* ok *) + ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet)) + OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN + t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t + ELSE x.readonly := FALSE + END ; + x.typ := p.typ; p := x + | movefn: (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ) + ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ + END ; + p.link := x + | assertfn: (*ASSERT*) + IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN + IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(218) + END + ELSIF + (DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer) + THEN + BindNodes(Ntrap, DevCPT.notyp, x, x); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + ELSE err(69) + END; + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + | queryfn: (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp + END; + p.link := x + ELSE err(64) + END ; + par0 := p + END StPar1; + + PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT); + (* x: n+1-th param of standard proc *) + VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct; + BEGIN p := par0; f := x.typ.form; + IF fctno = newfn THEN (*NEW(p, ..., x...*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF p.typ.comp # DynArr THEN err(64) + ELSIF f IN intSet THEN + IF f = Int64 THEN Convert(x, DevCPT.int32typ) END; + IF (x.class = Nconst) & (x.conval.intval <= 0) THEN err(63) END; + node := p.right; WHILE node.link # NIL DO node := node.link END; + node.link := x; p.typ := p.typ.BaseTyp + ELSE err(111) + END + ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF f IN intSet THEN + node := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p; + node.left := p.link; p.link := x; p := node + ELSE err(111) + END ; + p.typ := DevCPT.notyp + ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *) + IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) + ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN + IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END; + IF x.readonly THEN err(76) END; + CheckNewParamPair(x, p.link); + MarkAsUsed(x); + node := DevCPT.NewNode(Ndop); node.subcl := queryfn; + node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node + ELSE err(111) + END; + p.typ := DevCPT.booltyp + ELSE err(64) + END ; + par0 := p + END StParN; + + PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT); + VAR dim: SHORTINT; x, p: DevCPT.Node; + BEGIN p := par0; + IF fctno <= ashfn THEN + IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN + IF p.typ.comp = DynArr THEN err(65) END ; + p.typ := DevCPT.notyp + ELSIF (fctno = minfn) OR (fctno = maxfn) THEN + IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END; + p.hint := 0 + ELSIF fctno <= sizefn THEN (* 1 param *) + IF parno < 1 THEN err(65) END + ELSE (* more than 1 param *) + IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*) + BindNodes(Nassign, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ + ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*) + IF p.typ.form IN {String8, String16} THEN + IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1) + ELSIF (p.class = Ndop) & (p.subcl = plus) THEN (* propagate to leaf nodes *) + StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ + ELSE + WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END; + IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END; + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len + END + ELSIF p.typ.comp = DynArr THEN dim := 0; + WHILE p.class = Nindex DO p := p.left; INC(dim) END ; (* possible side effect ignored *) + BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(dim)); p.subcl := len + ELSE + p := NewIntConst(p.typ.n) + END + ELSIF parno < 2 THEN err(65) + END + END + ELSIF fctno = assertfn THEN + IF parno = 1 THEN x := NIL; + BindNodes(Ntrap, DevCPT.notyp, x, NewIntConst(AssertTrap)); + Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p); + IF p = NIL THEN (* ASSERT(TRUE) *) + ELSIF p.class = Ntrap THEN err(99) + ELSE p.subcl := assertfn + END + ELSIF parno < 1 THEN err(65) + END + ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN + IF parno < 1 THEN err(65) END + ELSIF fctno < validfn THEN (*SYSTEM*) + IF (parno < 1) OR + (fctno > ccfn) & (parno < 2) OR + (fctno = movefn) & (parno < 3) THEN err(65) + END + ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN + IF parno < 2 THEN err(65) END + ELSE (* COM *) + IF fctno = queryfn THEN + IF parno < 3 THEN err(65) END + ELSE + IF parno < 1 THEN err(65) END + END + END ; + par0 := p + END StFct; + + PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN); + (* check array compatibility *) + VAR atyp: DevCPT.Struct; + BEGIN (* ftyp.comp = DynArr *) + atyp := ap.typ; + IF atyp.form IN {Char8, Char16, String8, String16} THEN + IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ) + ELSE CheckString(ap, ftyp, 67) + END + ELSE + WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END; + IF ftyp.comp = DynArr THEN err(67) + ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *) + ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66) + END + END + END DynArrParCheck; + + PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.Object); + BEGIN + IF (x.obj # NIL) & (x.obj.mode IN {LProc, XProc, TProc, CProc}) THEN + fpar := x.obj.link; + IF x.obj.mode = TProc THEN + IF fpar.typ.form = Pointer THEN + IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END + END; + fpar := fpar.link + END + ELSIF (x.class # Ntype) & (x.typ # NIL) & (x.typ.form = ProcTyp) THEN + fpar := x.typ.link + ELSE err(121); fpar := NIL; x.typ := DevCPT.undftyp + END + END PrepCall; + + PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object); (* checks parameter compatibilty *) + VAR at, ft: DevCPT.Struct; + BEGIN + at := ap.typ; ft := fp.typ; + IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *) + IF ft.form # Undef THEN + IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END; + IF fp.mode = VarPar THEN + IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *) + ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *) + ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN + (* ok *) + ELSE + IF fp.vis = inPar THEN + IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN + StringToGuid(ap); at := ap.typ +(* + ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp)) + & ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *) + ELSIF NotVar(ap) THEN err(122) +*) + END; + IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END + ELSE + IF NotVar(ap) THEN err(122) + ELSIF ap.readonly THEN err(76) + ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN + err(167) + ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE) + END + END; + IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar) + ELSIF ODD(fp.sysflag DIV newBit) THEN + IF ~DevCPT.Extends(at, ft) THEN err(123) END + ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *) + ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *) + ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *) + ELSIF fp.vis = inPar THEN CheckAssign(ft, ap) + ELSIF ~DevCPT.EqualType(ft, at) THEN err(123) + END + END + ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE) + ELSE CheckAssign(ft, ap) + END + END + END Param; + + PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN); + VAR scope: DevCPT.Object; + BEGIN + scope := DevCPT.topScope; + WHILE dlev > 0 DO DEC(dlev); + INCL(scope.link.conval.setval, slNeeded); + scope := scope.left + END; + IF var THEN INCL(scope.link.conval.setval, imVar) END (* !!! *) + END StaticLink; + + PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object); + VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE; + BEGIN + IF x.class = Nproc THEN typ := x.typ; + lev := x.obj.mnolev; + IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) END ; (* !!! *) + IF x.obj.mode = IProc THEN err(121) END + ELSIF (x.class = Nfield) & (x.obj.mode = TProc) THEN typ := x.typ; + x.class := Nproc; p := x.left; x.left := NIL; p.link := apar; apar := p; fp := x.obj.link + ELSE typ := x.typ.BaseTyp + END ; + BindNodes(Ncall, typ, x, apar); x.obj := fp + END Call; + + PROCEDURE Enter*(VAR procdec: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object); + VAR x: DevCPT.Node; + BEGIN + x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc; + x.left := procdec; x.right := stat; procdec := x + END Enter; + + PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object); + VAR node: DevCPT.Node; + BEGIN + IF proc = NIL THEN (* return from module *) + IF x # NIL THEN err(124) END + ELSE + IF x # NIL THEN CheckAssign(proc.typ, x) + ELSIF proc.typ # DevCPT.notyp THEN err(124) + END + END ; + node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node + END Return; + + PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node); + VAR z: DevCPT.Node; + BEGIN + IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ; + CheckAssign(x.typ, y); + IF x.readonly THEN err(76) + ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167) + END ; + MarkAsUsed(x); + IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y) + ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign + END + END Assign; + + PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct); + VAR node: DevCPT.Node; + BEGIN + node := DevCPT.NewNode(Ninittd); node.typ := typ; + node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos; + IF inittd = NIL THEN inittd := node ELSE last.link := node END ; + last := node + END Inittd; + + (* handling of temporary variables for string operations *) + + PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN; + BEGIN + IF right.class = Nconst THEN + RETURN FALSE + ELSIF (right.class = Ndop) & (right.subcl = plus) THEN + RETURN Overlap(left, right.left) OR Overlap(left, right.right) + ELSE + WHILE right.class = Nmop DO right := right.left END; + IF right.class = Nderef THEN right := right.left END; + IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END; + LOOP + IF left.class = Nvarpar THEN + WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO + right := right.left + END; + RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev) + ELSIF right.class = Nvarpar THEN + WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END; + RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev) + ELSIF (left.class = Nvar) & (right.class = Nvar) THEN + RETURN left.obj = right.obj + ELSIF (left.class = Nderef) & (right.class = Nderef) THEN + RETURN TRUE + ELSIF (left.class = Nindex) & (right.class = Nindex) THEN + IF (left.right.class = Nconst) & (right.right.class = Nconst) + & (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END; + left := left.left; right := right.left + ELSIF (left.class = Nfield) & (right.class = Nfield) THEN + IF left.obj # right.obj THEN RETURN FALSE END; + left := left.left; right := right.left; + WHILE left.class = Nguard DO left := left.left END; + WHILE right.class = Nguard DO right := right.left END + ELSE + RETURN FALSE + END + END + END + END Overlap; + + PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER); + VAR x: INTEGER; + BEGIN + IF n.class = Nconst THEN + length := n.conval.intval2 - 1 + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetStaticLength(n.left, length); GetStaticLength(n.right, x); + IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := n.typ.n - 1 + ELSIF n.typ.comp = DynArr THEN + length := -1 + ELSE (* error case *) + length := 4 + END + END + END GetStaticLength; + + PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node); + VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object; + BEGIN + IF n.class = Nconst THEN + length := NewIntConst(n.conval.intval2 - 1) + ELSIF (n.class = Ndop) & (n.subcl = plus) THEN + GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x); + IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x) + ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus + END + ELSE + WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END; + IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END; + IF n.typ.comp = Array THEN + length := NewIntConst(n.typ.n - 1) + ELSIF n.typ.comp = DynArr THEN + d := 0; + WHILE n.class = Nindex DO n := n.left; INC(d) END; + ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar)); + IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN + GetTempVar("@tmp", n.left.typ, obj); + x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x); + n.left := NewLeaf(obj); (* tree is manipulated here *) + n := NewLeaf(obj); DeRef(n) + END; + IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN + StrDeref(n); + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus + ELSE + BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len; + END; + length := n + ELSE (* error case *) + length := NewIntConst(4) + END + END + END GetMaxLength; + + PROCEDURE CheckBuffering* ( + VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node + ); + VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER; + BEGIN + IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) + & ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right)) + OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL) + OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN + IF (par # NIL) & (par.typ.comp = Array) THEN + len := par.typ.n - 1 + ELSE + IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END; + GetStaticLength(n, xlen); + IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END + END; + IF len # -1 THEN + typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp; + GetTempVar("@str", typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + ELSE + IF left # NIL THEN GetMaxLength(left, stat, last, length) + ELSE GetMaxLength(n, stat, last, length) + END; + typ := DevCPT.NewStr(Pointer, Basic); + typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp; + GetTempVar("@ptr", typ, obj); + x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x); + x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj); DeRef(n) + END; + StrDeref(n) + ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL) + & ((par # NIL) OR (n.class = Ncall)) + & ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN + GetTempVar("@cip", DevCPT.punktyp, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckBuffering; + + PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node); + VAR x: DevCPT.Node; obj: DevCPT.Object; + BEGIN + IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN + GetTempVar("@ptr", n.typ, obj); + x := NewLeaf(obj); Assign(x, n); Link(stat, last, x); + n := NewLeaf(obj) + END + END CheckVarParBuffering; + + + (* case optimization *) + + PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node); + VAR a: INTEGER; + BEGIN + IF n.left # NIL THEN + a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head); + IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END + ELSIF n.conval.intval < min THEN + min := n.conval.intval + END; + IF n.right # NIL THEN + a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head); + IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END + ELSIF n.conval.intval2 > max THEN + max := n.conval.intval2 + END; + INC(num); + IF n.conval.intval < n.conval.intval2 THEN + INC(num); + IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END + END + END Evaluate; + + PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node); + VAR n: DevCPT.Node; + BEGIN + IF root # head THEN + IF head.conval.intval2 < root.conval.intval THEN + Rebuild(root.left, head); + root.left := head.right; head.right := root; root := head + ELSE + Rebuild(root.right, head); + root.right := head.left; head.left := root; root := head + END + END + END Rebuild; + + PROCEDURE OptimizeCase* (VAR n: DevCPT.Node); + VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node; + BEGIN + IF n # NIL THEN + min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n; + Evaluate(n, min, max, num, dist, head); + limit := 6 * num; + IF limit < 100 THEN limit := 100 END; + IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN + INCL(n.conval.setval, useTable) + ELSE + IF num > 4 THEN Rebuild(n, head) END; + INCL(n.conval.setval, useTree); + OptimizeCase(n.left); + OptimizeCase(n.right) + END + END + END OptimizeCase; +(* + PROCEDURE ShowTree (n: DevCPT.Node; opts: SET); + BEGIN + IF n # NIL THEN + IF opts = {} THEN opts := n.conval.setval END; + IF useTable IN opts THEN + IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END; + DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END + ELSIF useTree IN opts THEN + DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")") + ELSE + ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1); + IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1) + END; + DevCPM.LogW(" "); ShowTree(n.right, opts) + END + END + END ShowTree; +*) +BEGIN + zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0; + one := DevCPT.NewConst(); one.intval := 1; one.realval := 0; + two := DevCPT.NewConst(); two.intval := 2; two.realval := 0; + dummy := DevCPT.NewConst(); + quot := DevCPT.NewConst() +END Dev0CPB. diff --git a/Trurl-based/Dev0/Mod/CPC486.odc b/Trurl-based/Dev0/Mod/CPC486.odc new file mode 100644 index 0000000000000000000000000000000000000000..4c058872e69cbb85a899fcb5af675ce471c6504e GIT binary patch literal 85407 zcmd_T+izrNwjV~dW&4zKI=-Ca#0e5-k90g!-Az&?yVYu`N1DUtrJFXJWJu~VQ8YlY zSnMvTSXEP1>?T`MV=(jJ011o}_{9e>U;_sH;wQg2FM(k{1ju9lfFL-50YBs+@CXQy zhX5zP-@1I4y>}Jay4W$&kXTiFf0y;G`&!>^ZGCqzhkw8R?fRg7cG~Gr#)}7&WB;+< z8Mo(>SNZd`L4VTf_B*5T;z!-ib1lqo$?t!2Fd2+GY!n|-g5B}opU40I+2hyv^*2cu zj|az{o;H=VpFEYX9>R(>OG7!+tE0feno!29OUSv&vj-+XQEFXH=e@Tvb^5IBX&s;y2Y zqwdk!q%+P(@)N7^pW5e~G;wq8tADO-{gHeS%GZAV&2=j@U#j${^1EC~ko7xwbuHGs zU8I_jJo~E$|NS)#1^9T>X&q-Q@y(yH)(-6R1NlVFAJ5&#|0nqQ-~2N+ z^y9f>dp5LZH}T0a#!h9Rq1VIz`Og^w_s@Fl6#&RL1-=E3@{Q2L$cx~=q|Bm5(yW9U_yvV=GI*#@K5(WA1k$$}Phxi1R z)=rPdi@U>4|8Owqt#@0!!IS1s4lc%%&gonG<5Byq)uX}LC2tNq1; z!TC>a%>9|^tdcSrK~PrtJ$w_Q1(3h_eLUj7H}qqU81#SFWSsm}E$>+VUdQvQ@coAX zZOV8)vq7xs=WF-znd1AwXz+a888v@GW%|~G2MgQXcBen?5Ydj}!k+=vR2fscszqJf z%m34Vm2k)Apa**MZ_XXRMd{zg|Nkrg_kX|n=0EVS_+lNd(;czgT6eojGF&quro#V4nr+C&Hbz4Wh zPQfzcQ1{N#yIObm!^2`Y==LX_QPJ&pCt%?2i`Jw&=;LS6IUPPId%t1$s zw)}OrwaQye-L^@g8ZU1{!G4++!T-W-yiUYAd6q7DJ{Oc_GkH*19?4i%|GTd z{Hx;{KK~yDVzHaV@oQqD2zL1!$*9l%7mVa}VcS3YDZUASY(O;0++RTpuSi@hu_b0c0Hus0!hphQ_s9GT*UlXYBOhPd>XehNiKVs|rw*~UQE+l!1&R+j7 z_>8Lkb#jml?DfCKZ+{v=XK$|e~AIT{x|rH%yI3n z@Eg&3P2T7YoSp6UD8?L+s1RH z^E=_&yZ^a!3%UDGAMdVzxV=%Vcb+Y+?XBIpclZAF=FOYeuU%_E4Sn8ePa5wRZ@5N& z<9cH-deZ8flHsf8&z~<2jyj`3f3f`(@7r*P#d#Zy#(cjk?~2oIdo&n}VI8B?Gk7V` zQY>(-#@t?$hK3iT?vtkiz_da=wHne+$&#>*QRk#H>h#+k0p(;eeDAHd@OQD>KUwTd zp1uIcZw=3m-Wm^1CeK@=&RYtteSCE1EopOiZ)I_>HSCNQhlIWTwAFv2EnZ_M-SPM= z{=9bm=FJ<|uQ#?H@9pj%76(5+INW$VPyDX!JucpR-!Scu4&$RkE42|HZOj+f8x5(u z4bsFH{B<9_tnKa`9HK~2{+(4AllP0w)$N0g`;F$!XcjsJ?M!a~QxfgUWKg^S?FxXL zHnMv*nbnAxoz|#z+JWI27gHKpzv$0uWB{+LXpKg#i{fhS9ZW{k+CywLDF!FS7_8TS zg5mYfI>m4bgc#}O@Qh*AXwcj5Jn6#QW6QU1Z#)u|X?0rSli^t*3_a)-BQF_nt%g=m zhcK&~T&j=~%J)VgI;ug65a*7Y{Bb9ei8HH@KVlwsOB%d)gY^WAFEit^S1H z?#Q?0yZHLHe7(JbuON4$vEOO+b3 z2fExD*!LB-v}axe-l69`cpUZ?y{`>UrPA9hNcaSn<-6Xz{sagBSRhyi2oKM?$LMM0 zHY`D#vp)f6@i_@`;8$;|t%b=L_0#PQcE9j;rC|W@`?G~AR1>Fpe2{kyl=np7Qw}qEm z#{_o;Xl;{fE9mg3%hxODv8Px-k0YtFf*yf7zLg%IbS9${0>HwsI2h5m zx6{Ed4hy5|o+_)N$L{#yS!-l(fR65X4c6fZp)HF-9+eqdo`@-|dp=kMM&?b%7DI`7 zfpxJCzJBL9Ohc z5so4Xv@2@k+SO0A{2D)jpmlx%HxKv;tQ_p&6DWDWPm0VIJ^|-CKLO$DBYnTdPrP5} zC*D8crx0>1LI$iAr%)GY6bJ<#@QsS^q&H{@yI_1z;m`0fnjJr7xTlPPOp%xf^44>J zkH=rGeliab=ZiJ`zmES8w(z+HWoL5wu+u+y+C7=<4psX1cehauJ@4=Ce7GV{SNZiez8b#J(t~bj=fR=Zd2o2(bsii_9kirm0B54s=DK&jxw^iNvgm#D z@rUe`9c`}dKE~H&_RsIc@3Oo&`0xR~3t*f09zfe%-}(qIZc7b(cR=X`DQ(&7O%!#UhC2ZMS7S)DWv1C=af}BYp#);2FMv;y~J2f82f2hdf#} zqG}nu*ls^$X==E38{Rm+ioSWsZ(s^k%`38ql-S`nlxVj(dazi#y~A%{ymosRU&xE? z9exul3ut=JTNh*eUZC=8?{wgc^Ot}@Ex;ea+Q4O}=qtcy$aFt>BI<;7qsBnp{$RC- zv7s^san>h>Ogv!NJEN0UyMqVR@NHIPC;agws3HF94^HS+vY_}okZiCfe?lAd&rb1! zkYkw8Df+mpZU-52Jc0gl+rAuh29YO$M==>e*P|JPB&HmmcPCE|`P9$>Q|~`9rjxUN z+kawIP|p5K4A7_(-hu+7R^Q)(>fQdi{{rdTgW-k$yccB%78Ci};#qgxJ?i$lNY=oI zRS(196WsO1pa4Bkh@FxCB0}t!h!1;I=L3KuWvSnTBajm z0mWCA?w|%6vm_chY#lj#jz9pJlz~Y=BN*mU&){Ulwz%Co>hz=y zx9cB{J7Yv62`E(Xd;7a<8|xqLZ@~TSPHq;>!Ehqr++bx1`U(sP_ybq8^cy&Wqase} zdOX;8xV0k~BTg7O@?&cU?%V_%q8Q?1sqW7eVU@>0m$0M^8_n= z8{*oUv{iXI(~2j)*wer-~Xw?a=!<2CBdeH}pf|wUNJ%%9*_F7}(mRHKq?l z-}3O$#!j)naroi>4*g0%wXuB=i_q0fi=axm2>sHu2z=6V5xS{q5meD48{Rb`;-j5) z9kq`UluL)c)yL2$GW7O)&R`h3vzkWuR%XluI#o!-1C5jjdV-AI_4Q`EeIo;~-CkHO zfQSfR`xYKJbPh&N7bu0bH83Xxw>VGPd<$U{BR2592rj-V1>rV|{R`|)eojF1ata$7 zAe%U9n)rQ#Fo_JT0#+8--2@toq7cvUz2bavpxO!*&A8$HS5WN>`;^WpA z9Z+sOX`+_}G$V?Zkw#J1CaBIyg|W7c0%YHe1kM>?Okr(UwJ$XV z=Q%1>T1n&0g?r#tD%I@aorHnC!x9`@{qGfyIxtcwygPxSd2^xs4{WPRQe?i5d&sbs z3oIC+(mgUhGw+|js zh{Bus;tp7pE*k6HGf9-bODGlIN4cALF5-k{)WeGs#Fo*Ffwv%lvAF1~C*avHzs{NV z@nUB*YA(F<&O3ktaRwStL@|K`>(oI!VZk07K`H`l!(PN%2;WN+gVAGT*3fnN(XHYQ z)Ov%;mVmGkb`HsFgJWRrrdH5R$dL5oA(cwUIZF%g6vhw&hjZ03ZijStCf* ze2YfblSZ5cmGnsN>}RY{&xpn+{*t^18X2iTDPhZ>7Wc~3Cd1rI*|tI6(LB)%4pQYQ zjebzy=(}m73W`dEGk={-)ETDWldT>cZ0sM3$N|H|l36=5CHIkb#(`l~5E7BDUhIVjN^=uPJ-MZae6RKfnhBOWgkqZ}M4fDqORRst-0CxFSoAZciz zjH%#BBD62z=*NPuTg9C^oC$Z31`(&CtOW&qSfV@T`MRJtHa=O~ZffG74~olAl6}7D z7nogFt?(5mvX<|fyMlCX2mEidb@Mh+H(%JS9KPs;9Jm^jTFTq3?9*!RF(axRE)144 zcFNbPdxX#6;krF__95!NBlk+a+S`kSB&}S~93G*cAk)e%*F!Xmn1Fam$fg5R#w0RS zJFb-9t;BbC%kS>Sckh(ny%XOpm)|YhyA2Q+e0y7dnt@KKuMRLE?!zg+qX5@2i}4P5 z%fL1!i^_AL;pu$RC1ys=8#3H==ZqPC78*9=M-UbXB4RdE4 zY}`BtBhMEn91Y4K@lVeVKT^HFIqEPpD4Hx8ba?9X0r->Rr|(k?)F2XTP*sWO$Pvd%IC6W(x~J=VR4@+W)15^2a6wCOq8Wr@1)dr)0(a$Tn;MwiIAs+ z1BMh$hLIXPiNrRer7L0S-xhELqXxQZ`J5C=F~Sz|OaA36&VA3@1o%AXpTPs0i2BFK z^>;$BR}d-e7qNU7%OcJryJI5yz4Y}6o(7;31N#ciplxkNJ3%Y+mWxPQllVHND#eId zw0b&nGL~A1CKLjcJ#82bzk2&HI1vEkX#iStq@wAyuq66w)t+j-QAjnS+FeYFjtsvr z&7-HxI~sxsnpz?C#Z>e~Jje(H^T|`uNTPTg9vHOCN5C$e0vJ@ zVlqfjPArK?O6pfKzk*W3^K?mvG{_n+AvE3EEP&GmX8=w#v-BzakS3MofvW`qff)~% zrvQTzJ7vy5ha4%Q4XFb(P)hiBCgmm53G5pGHX1Pr4h5d%yhmih6#NsSNEyaITmu;{ z53r;pcqa6mYW$k3!nsNAX`Vy$JkMt;SFL~#TST$U>;x2yEdp`r@Kmi)>{J5FL)I~V zFML6`XtZTmQBp5e92?x4h6Hsa+ohutn}9({+vwLuVfEgmu~xG}W66fas^rwWDia1C ztQlL07lnmHot0Q4SFlce%|mCpHzFcP(krsCsJy87$Y;6cE4Z3qn&J}m&54bR*#^e^ zgVHcLer4==WMBBd*cQ#3JA(_~23$r`L%igbs4wUju%VK(w5(sr_hBWf72Xk%fV{261q}HUIR)`fK;97 zDcyKPTIq(a^|x#jO2md)B}*A4kYFiWwGkd(7)FF#T3e_W=Y5*ZJpN$9n&WqOEO8Me zbzR}0X)JUFW-(CkAz18mQ!4Rs5l#IL)JgTzMMKOiYRafjW^*QFmd+)xsRl0%NX%G@=N$$Y9lDwdLe9)8L`O#6 zMbtp*%5Hd>fFI`sBu2LX9b?4#)##4gvACX^@imtL(U$DXiAJL_Qr{sr+jJ^2T)6{` z;QU;zvu1(J1ULyO@H9i#-Q^%yTDU&wSLbskRh{YCYv3RllCl?O(LOlZ(PSXLiKs(d z67ei*#|#D>LAvNNW$z>Z1Sn?mP#V{0r)93%25@Bs_p0%~`XB(Ad&DcQ2=a(0OtOY$ zshN%xM3mi5U^b!_#w(~#YzCVlofhx}qPR0k7LgbX55OlQrdpLzu^CL}2XsO!k9Wp2zBew5cmtzjns@Zr(Od`76Adk1+%L8F_#Tb#i@1P zMNEV#P>G-t?_GXVdJ#0x{f*W!wh!cM`_o*GFb5w8s1jT&X|;H*wK8NRAXIoU_;^Xo z4Z!N8#M4g(7GYQ07rE75u{QG-kT`+raIw|Dz#4r#BL~!_gN^=5YT@v>>YffG;GOCW zVQ&uB(qb8{ZK4n)(S?U=@vOownG+8cWOPMbRwbiY@JKOu0UTNlB7{i{j$qAnFhsNX z>@nL-BqVa+t62dq_u851Vwq=QF*Dc>`#D3`QiczrGQ|FiXBI#L@A8Wbi0@)YN_|4L z9s*}HjL(4kvS|$>fy%Bt1%xT1-=H!yp2`9gcI&QO?(2kLk8*D$&gEXV-(a(JM=9T` zkP_>rL0|Vg>a>+F<+5EnuDn|LpjsK;T4gM^O3d8lT$1rJL=ixE)=m~D<9Da0-eSuw z_=7#gv50zn`iZT2ICz8;8k+jowjF&MY5(>BuqfbWAxH?AH+Z+vvP!h`RPM;?inNZGi344`3K$1N?#7SU0 zk^puQQ$koRFKga$Uc>gr4kcs(MHi8IDoxTtkC=SgmUdUu0jwrErmewdwZ+r^0H{f_ zuy~gsLkqQzM`TKILd=Lk3wSqCy(ju!QH{n#nq((;(yVVe)8}dgR07$(D+`fW_NzLR z?oWhno;&&$`&fi@N0x99KyVfx`nE@`N{gEcMK8tb1Z%-ogHf8cl{O`cVFR7pQ1sVA z8Yr?DXJCWctWpgvx#-}f>J)rQz%)PK41jXK6~)IQ8R!r-ee@F0@%@`_Auvw05Tb=y zrxmt*n~8nd6o4PwDKE6G{$R+Buu$Mc4CfqAy4;+IR%|P6N!vn^L-zp(^TkqF>ju`u z6EYG9C@pU+0_YC5^)=B{swN3v&5$WS(;TA)8_#qpA7m<8`wzQ@bVsAcq3kfS0yL0q zWED;jutT*aVp%y{90h0XsSkWz zhY}}Ep%s&_ywe5vzah+tEE_k9p!k*PD2|CxQst0cr6SAUF0#R!;X@E0u*D%sq1>u& z>tUts3K*^l?78C)g^pW;whfivpE`^>Vjf0 z)tEa8jbTJjBW%WrHejX7&dy-5+V18bE=m>j;VcHqzLeG;FMfnG36I$y`}l?7!`^ZC z%<|p0LpaoamPk7`1xvF{>9GBbbF(%clcf{vRmu z5PXAz41jgRG&v6s3|iG}2?-Z)oMoC=^=(m0h|$d|n*SA&yRvRV8)D;#V*n@PB2)j- zo#bnEez1TA{@c);Ky33D;|r3RE&`c@@rZ=>bQaL5D|N&N)oeN1Ht{Kqj-AFPqS3>~ z#>{nzWzY@R>T}njEeHao0vibr=q~qC{?Rs<;-oi}PZkg;!m{=yc0=QZphNf>U|Xn| zAXFkh<{-3<*|;6%-jQRMkRzIf`y(rO{a3|EX8=m-HQ+gI3IWm3y)MhE8k8k;aFcCQ zw~m%bqS{FiiOmyol0p+G^I>AJI5*Djm@vm#O! zZW!aIa#0bntj+22gcERn5cx4dDG3nHa=~GWo$2BeQ>A$>7&(G2lN4#b2my3$)*Ci9 zcpz{~khK65Zq`5;Pa4vuC96_W+md#$XaRAV_ZyW<) z?xEUgfpCuzchPz7;RMX$_yP_h&K7LRv4UNM3UV@}ov?#tYMK~e!bJv;2BE|wOk}RJ zo~Bd)m$+~!fMOInc5e=#0A-PBH9?~sfgY4Wv(V6myrIby)#^AiNY#8CYg4zZt%Uq~ z7t_zs9~iOJ?Bfiwk9c|-EpazUg2*beVaqBvKu!yXqKvvdRgEha~(YJFOaE zSy6aNf-4}O@2~+Oo?nozoI^sJ*bI>~sc)&gCTNSgc}7qQD@lc-Z`vjrL8QJ+<_KUa z^qI|%=)rN22nwJCPO~RS7=~3EW!9N)Z%k^3ghS{|GN>4qFEfnDVPa2Lp<#GY4}gEO z9JaNj9tj!>v#heDQQjJT_|Dx75k>ih5?|@bne%#TCU}EUzLG0;1&=--3p8wO&$d-c zV{)=4wpOOCc)w{mH_zOCiL<5PrfQ#1N#*5NUqWx;bcB0xqoyxok08V$Mb}tk3)8aT zvo!kO>~?xH*8ZRHb;$$#c&WEH*L$47{14Zt;L!tXG_jSrj4YQ z^B=SfLWGNs)bP4%DPv_k2 zZmrpjB4?(TdjI^>i_cWOGJ@|OtL3T2qZ~t-YDK3v#yDe;8kvd3t8}pnd=apOVNj`Q zQ#2-u9PwE=>ufkwVK6F0B;q|Za6d#QBGi0fSz;tU*a3UE@T3mPM4g#0a|lZ7rU66% zqK4+gEOm3lBo}V@ydhQw^Q2B+#eptyv>%UBi@G#g^61Wr0n_0{GsbRHd*@E96s|1I zwh3FDBndA{j}sKY-H^%n-Pi>bC+iy$)oRPTvMSu0ZUjnC;{k*iB)lz^N!h_3+yN_} zJQSg^$KU{Fjrq?ERN6{(Dw0<0VW}0_wXLmeIE-jqHeT~_Fe9}=x}Y<#qIfLYWAG;o z$Vj+a7fegV&SLQjofTK~IBI*!YckUzGHJ9bffWmj>eD1*4pdoDm&gj^TvKwsP}xM#oV}zQqIH6n7U~Mjni*QY{Z4cpw@co! z)D^p;ZjqukwV&o9R0IhJ}jwJ)F#{U@{&&E#_7S%i>rGw1$Pi6llyjh*#lxC&vgsff#(qU;N<>7Ka#LNv9mpJ+@b` zs#rq!2#lx(si=>rD&UKtSaFJDGK-@Qvq?Bl??)QuBx0CPOJAls5;ftRahV(w;lvJr znaZ21SYyWb-!{o{~c zF73sP=!w|IBmkQArPgJKY0YKyIhf!G zz_Pzl&uVyydGQ_Q5+oNa5D1;O525`^zz!0 zm)^$NzlTd!S}kU^_2tbqFTcODj>WTDzFKf8g29U_1O_{7vAOz*Fh;eKTyZhw-P`N$ zdd~-kdvRb;r&&Y10i($aFTl_@k?{}5{)%3}J6?<-ePFRg>lLQ9$wX4cX1A%uV(ZB| z49Hb{KInIR_hrq%aPvr$SBGGUMCmOi?`&?EQ1T^Bm+)E1aBcJ_UEDxgyT(OkUyPl6 z5pC^`$b`LMY9UiHg6cT}0st+phVX87;&_4O(!NdN3EIPToNTBR53#!4c=`q|jS7eY z9d0gui1eRvk}<3&t{%m}yECxrCJ12-79`_HxBNoc6`V!8hpVtq5m)0CgMJUeWg05a z%Vl(5bo)4WTMw+~0r6Z-O0{aSlHHv40Z(_~5%*}HEompR$_x`zpR^KiUuoaFar=)$5;%mOKj4!`r;YE zpq`xEA_qms!~9|a(w8>|=}0pl5FxdBGTefE7pFSFM)4jw-I1I|25coD7g2+1IHooC zao~fq8ax(VH>!z7J1E0i!_gDLm%$+U(|r#uQL;V8s-UW$coE!1IE>~X3Hx3NFhc`+ zcI|B7ouuGPsq#9PO4_s}MREAzswi}vzCD*)zD7W_+2O(en}`N^!q?|WnxY<=_8%-QoPq=8`?v#oz7_KQ9>!s!&+z~ArU4F z)D?6eyJ#7ARU-R{@a1`GZ1g;}3if-z2sIuVhTD$xjrk zfuRZk#qi^NdI1Qx{A>VS>cuVdIk>X4go0d&^lAqZp_lM2ay$8`lA#T4M0`1=AFDJQ8(EWM3Rf>d-@tQ*9*z8Q4iZe`?OO zXH;|s5-wKc#)l_SZwPl%OFL(qDOIKxc;n_PauQ%QdM2D`V-!IskI}#u`pziFX{j+S zke81Ff&Mr`48=|x7nhL`E-bIyo5#&fJfWUceAIM@_jVavlt$F01AO8+t^& zyKldJTaKPBcNif~P@R&ksyl)8Tv^7k+VPz>n#8=t##KcXFT~K_FJ9zSFX>qqrx&?q zdf^U9u&pmV2lc{sF$?LK)qW9HrzYnxktv`pEN^w8buRBa;rV22nR0fBE!bo~LHy%4 ze`KHfAs|z?mF*z#TQ-AupFhndl4@tW zq$#5mCLqL4tr_V|nI!T!tCBMU7G>d&afX~)%Oxeel2;EP)Kwj3iqf+abSodWfR|t^ z36Vn;y|40Myn?A^9F)W(>#P0N2;x#zWHD$zzE&{zLjkyaw*;X;t)on3{xV$wc*_I3 znr;&6R{N_#i7I$43eFyU;hvrAWYdw~25-1_IT*)F3Cpow4Qn-{__sk=!Rgf?yo|0X z(o=q@AKABNfmfkf)96e$n|g^qkryxxQKx4rq6q{sU_-5BOM)#6`(g2>w$lL$7Md(o z5`u3pJ`1;3-nk36fFJLC7u6C}nJ{gJ7+L`y>>6(JRz^vJUnplt=_ziNV&3yf2R9Vr zeyVZtqaRsTpXN+r*34;fuh!JNxfHMum&e*=yB0#Xns6;f{BzZ)Vhe~?p8*>73RF3WC1s4f>X!6802{+#(-IV)j zC}#mt^!KetWdp%=<{r@PLp%2@K(n9PtWz}N7afd4>b*!W2E#^b;L)97n?8jHuL+oZ zLzKxy^*ql~_QS{%0ura8!R3_9i&^$Uv`wjCj9g22&rd+LU6Fw;OjJED6y0+R-fKyW zhs~yiaj7O(J#s^Q$~1UQ)cXv%OhpZ@q4ZoGFdpZ=g5d$r(=HR2pz405)C}Ajhb|Td z5y`iVOaMtWF0rJEh9_?VR3un&%L3yb3qGzKu)J!x65Q-m)g;L}vf2!?q^U{2Z!pW$ z7>ibvKc0il8k*+!e0DXMS9wv!CV?Mf?J&$>3 zBaJ1ub(WE`4mvhNlVXYy)aa8pxo!xHMEF{`-3r=02DXGmD|1RyP^A72jW6d1ReRjU zehV?s8i*MTnz_cjJ0k3_Ax`4nidoWCdMhhfsU{k!c~b#3^GN{BJh?_CcrTl3fVE%m z&;2h;LP|NSEIZG$(zAdNESvBl-6Iw|O-7#F=Q?(o&S0R1WKuwDmQaeE0-nejg*=Kj z!gBlC1=pL%!lv^JI?-6=6`+hf(c!$oAto`S!M7Ti?y9bqiVOqBNRHZ7>X=c$*!0N! zxMVrl4)W6`taa>8x19Y_cEZNS53yB9)7|tE(Fl&M>GWGixKBpbLl&RoT2>42Vmo2_ zPp2xA92XvSF8)eY!k>6Gl9ZPe9EgRyc(=*r{1#bU>z0Rm2>);(Uv^L+3b zXc+b@ffo7$L_!bsA;1Sg*SOW!w6kZuA=;AKAje}2>82A1FJ@R>Vb+Sl`0S|7SwWe6 z!)?A{f>7{5&X+mgD&I#AHEK4MQU8 zL0DNUL9GDXi!C+^H^#maN?PKwDs0e7*5+9*>z+k1l6%E%(%sVzCLBpcD)68TL5oC< zZu81_biUe`1=_@WHG_}6Y^ts7N_G)sH2hUD?zP5GYsT`)U?f#Y?5~Pp?`*7vE(c`S zD%QYZYg(aMDsW)s$r=3H)A1LfpQ!#ZVkMbU;(Zn~Ee@&0b+Hl)BpyEyT!SJU;viQ! zWJC*iBbxaSEnb8+&qH!Y-MHYkgG00j*CkXxxZZpL{*W#VOyx4Ak4|J0=!>6BYdy$P z1}fpN%tWT}1N8F%x=mqYL{)~U#e@^C1h|%U)bugE)8wD?0&8k8U*uR1ZaBD4B5o2i zyan4hO%%ZkXuzwAdy-<-ylz`yNxY^u+c{nV6Y;1WBTtNtoK_lDl@$qBIOT}L^$`jF zlxm=EggT?m!P!ws#1t@ZL_fdcGA&(+Camq2L{2dw=P`>K74jMAqI ziE>6W_d=q)Ml{UslvmMcdsY6i;#^FYF1oSe?ml}YrrPUU0km4*Lq)?GKwO7510WB4 zGrX2(H{#1+^rXqe?0KMt@d~cvT53hDDS!I4>IkZ-E7`y8*62wGx8=;VfX5xILkmmO z$c3`40oL*c1(4|lFuBR0uM-MkK$=GolL>HN`aX)_nnRcQ7E(H=JVTniZ1asCVY)?A z(?&g1$sU#CPQ?#~P{VN$7$op$DJ|$`ty~JbEo+YUY!>*H!qN|VE1VZfEP@4Htsl-wDsXV*QR+LDRxt%OO8lgN z-ITSIyyTs9Ef9FEN(5Q~Sjw0DG&Ilfu@cu7CUjF4yBslja7!T`<7*hT%KWl zXLh6x(?Cxt^pPc{rInvy1!|)q(<-aaWc_DpP+Ylct3R1%&9Hs-6`j~_J9SN`K#O5i zELzr=M@J!&$%)v0;Qo705H_D8!W(DUke$w#q`G9}?tD{i5R&gm^++VD4{#a}(moo9lHY?r z{7QoG9hhibmqiL{MKm1#a2JC3jG%QX+XhkgSfk?gspZvFn}`*YYujltPbjC)N)BVy zlT+`9=+a2ZyhgBPO-P^teT@m($wPV4O%!PhSAa{~+qKExM7FZzC-Slyx>PI&gkQq! zn4L{z2`^1PxdjQ{r6!IAfJ`_`;EK>C?F59l+I}218VmmGP+u)B-d@(%hYfkXw77Wwbwf-YMHdvT z&iinyOxOYmLOHIXEsef%wt}FPUDMl;H8aGqz=9_LRdH^|{aD}=mS}9OzH4&WfK$V7hf(-H4vFL7QP@ogA ze^c5^oAW`*Suv=TVT9<^w6BlBpU4?9COnDcXJRc_02_f5<1Tjm&gKzITq>RqNgE)I z^vU`8;A!_{0+v2_1Vx4M@ub#DYQhWc@5VxwBMa6ooS`NMOJbllESbItY8S_*cX*~l zniRrVREkVqN}9ot5#~Y5b|qM$>PF1VITz6A-t+YO4QGWLH_RPRymDuVs1!0{l}tt~ zm0OH#+9$x!@BFf+L)S5mhZ1^V45ulWfEiqy;y0v3l=vt~n=RSW*1^TxE^QJWbakg& zyDeT66&-pj^}l=k{ZS_DX((+WoR(pX=*@_bn=Oc9P+Fejqa4cfkoksD;^pu7xO+!e z1)`R`74%^JB@Xb;9|Zjs!2p$03+v31Rm5qjSFg}AJ zjAK=Fz&gQ27(Z2vp*$rCdh|Z4$@kTL>OrvvUcNW0{39#B!QR;d6mDp3e^=gylyk_L z`V^xvwa+WceL%q=XOwe&E@NbF-Hj^-7OMX=JybM21yBqA19ZZ_DJ_q{cA;hQ!(AH8 z$qMj8DAi0U)1lVFZ4k=M>~{T%4G@wTioN>^4+0gRW{LsYSy{d8)wwfoIigs-ak^Vj1@U$;}pMOLK@J--Ocv zKEZx}nGrL*Wpn^8$PefYhjb4ZMkGoRaNtF7pY{0v;NHOtQv;!$+11%{Kf*dM@YI&z zs39uA$r)J5e0+W%TiE%n^%SN$o1q49s#lddImI4#PF=B9aj$-L)PFpE%1Zeu1gdS% ziDWeO>G>_KqsM(F1|}HbfOUI17-Ga8_Lzfr^_hkL5n? z;PMk*PsQT}EWmlZ`;jK65;UO|-`(ek0@!3*zOgum*Su9@*#}4+ej#o@bW|+u6G5(f zg^TezXRWnQzLxErJUj_J+d0K@MLAp`QLoU1SszQzh-i)G!-Rlb&bvFB2U}J^eywkr zbvLw?kh$Ht%v+J=i&X}^kAyr?5>6=>dOi zQt#OF#@K+LhAva=C=x1ROuQYBK_mV{QR+K1$g9~(!`G9VKR)1M-ufdzZq$uY(rD&O z${xb6uzJ?ceE!J3z2~?6Fx2$-^mMHNHq?0u#;#w*=aa#`@QOzRV}~Ht@P6YkoTmlT;4(sL+Ml^MTCqu;RMW9`C;V3>sVxWCCvc`-@|k;#=I;F@Q~bODzH_~ zZF=9Gov7VB0j*00OmCH{jgLg*K)KD=oZwQlYMP4f3E!&r!52Vimw>VV%H<7sOI;-I z{Cv>Bt4G)n%(k2zS(1&HS_!Yi`x$C2Iqf#y1_4(^hRVj(Ei`ZGRgVe{wGXXxm+ zWb7!mO3~{b;#WBL1tvr<(;Vpqwz6jgUJkJVH7-bS)k_pQj%%>vm#c-VFECg@r$a3P zg$1y9C16>Qs*Mw|I1a*m$K)DCb;e$(*3TR-!c+&YHfWXwWg=E$tYYAaS~WaY@HY)q z@iQ?3ik7-e+GAZmGEhMow|d&Qa+QR$@Nf_O4C@C% z!?72iS{IQf4q}LzOYWf=5M8NPfBaLzXBgwAFNyG+GH6%3wGZ@|5)3lqli{tj+mCc| zGM(~RF9b_CEK?`hOJ+;bZc)qS3(9oWJK`ur3V!mv4H$G0qLxx>Ox9(fiL${EeWAU( zg{q|GT+DLRfdzuI+mI!dAxL5IEUkA}4xe|wJI8(mha4tM69i2JAfzQ}LfvNG^Dl|} zhG)T%)3hZ~4ou4tW!R)L)WbRr?eS(>n_#so>P%WOzrYK;fhfzka!Zr(zdFvAKOx?% zs*ONo1+eoL5{G_-qn?m%5KoJ%N&R`ZKas~0#n{=9-lxPJ?sqr9=DLRp9yCf=`Y;}F zV_H;H9+O!3U8sNoo-|sM>m0VzC<6jsj@W8Wlf&p_maI}V8heotAjxfVyg4G_pQzd~ zE2FM+P)H&02S~waCY!11_zeqrvs@c>{N2UNp{&Bb-oE z99`E*ncn%0@cb5DKCis9au+vPH59pZ{d$ir_SoWcw)p(|_U_KZ=2#k($I{XB#!Y<@ z`eTRsURt}!x+p{l!TA6Y&|%sVAnKC{0AAdZ(tOGOQ64R^KB2HD3I^b{cG$RjKWw|WNqvbcz_{{sKx3)@XBjYdt*(|&0FkBxUT zYfcT2X8}O>JQvDXSteV*V`FmGN1_>Kr6agz9M~&qi%StId;UUV z5<-<*Y|$BGh}{@UYkYxtYkYAhMyvIc?h*ZCG5)G0=$BzHX(g(S+O+1Lr(j9P7i!^T z=QYk77j5n-3-K;pZ)WdOQH9Z(w2nXLDc6LgfC|Ul1a_Pu-8jVk<2bmo)o=R^ z>kW*R9irP?{KK1BV2Uw#eYzr#SLFE}>6v~tUt`e}MlA+GVa7x9m8mzjTT_G?i&zB7 z8E->4$gcNTrfJqj^~x5o2J5NfwEJ_gVOTMcakkh}qTX)PgMxc9VTM)uHLHWvaLn{X zJu5{bCr1MSmay2_JyOL)EDQfkLT8l3fwGAe!HaN|GS|tr!Mbvwy0#zywFNk1|6DG! z{M~rk%}2@oQyfDuZy9DvqXS@x(3_c_9r?S^2gfHal&i&Of(GJ}DMn1C@WNnq>q~eN z?E`A?axue84VqsaXgx?sSx7l3k;LGNA$JxWv-oZKZai-$qxP$VVJ?LFZTW;u93Qt|XG)vB*IPkC1p*lNcs#%t$#;gD-U~RY56_=7Z z;!1j|+i&-la2|cw+65|I=8?L!z$943bky)2V1ia_lIUqVR|J$Y6ZBl%@Gl})nL`k6 z%sSAOnrs9JeyL+o_KC%!W`wvRJ6bEw2iP`A-RfySCtRRHoL~?n=P@@fG+podOc%6j z^+;y9T%I?BCRQ5B{3=CsR!7cBc|n7!Om`VYQucz&tSDf2w2Sgd+Z-pVY}Fa6VciyQ ze8IsL<(uB7U=VZMwHOqO0u)xl_Fz#SLR;F2|5ODo8nGW}c{{L1R4Jf)QJ${S6J#!= zeq|XM@0BI?!)Dt!EZ5R{8mOsPpSe`>q0iLsMFbgX3cjf1aAj(!j(~L5kWenRH+Gum zzW|#np%;-_5)Fda7nZD`x6{X5SPL!yj-kh}Na-5(!EpzvJnOQO=+VuXua=-VMALej zfT0z9;u4hg3 zK-BmOoFMpa^2`a-HDOfn6I9wni@DVR%sfpG43sMh%ub^3X&Rc1dx#|6n}>Oa(Tg-G z)$=Bk_OQ}-aKf3b2)nLw$P|wZ0T@ve?;2S=bItFy2O}oK7))aof?Q{2*B6sHkuH+^ zYpSau**o|HGiN;}8j$|*X;WGrP^4Ft7Q~K68Ng-EMiuI?3|ON9Ud@_by%(%66bZ{( z@Uh?F0EKAcf46!)p0@J0I-`E4w+M8iKodiJk2geNUKCqe_BRd=lwlHwH`*1!2lQe{ zcImZDy5K-)k=&W&^B({T5;19Y`{S*>$!JXbXs!=;R-;Xm!Z3`aZ`YJ4CFD$QVgH2Z zHezW?>CUFVr2`}CMB0QH#4ItBPITnRijf*BHX2G{R>R5$VYW0=scE*Ff>uJ zl3ED2&rEMxngp7%_7biVu*3T-tWn7{vA!KSG)-`PJH8TNlo#j=<*cPIRZmT0F7@Vh zOu5aFdOoO^S|S^jyi2%q`Uog+<6)=WZS{&nu3q59Rw{WC`mgTqul^h-+?3PGDR4NK zi^?2ngl-?V&x3xQ2;p=n7U251fL+} zuQMJON3C(UO_>ZS4_SnfkR=@EEN6n@_#`>gSq|2CPp_>v!TE~v$K@Atm;H)LlRU(_ z3wd@sd3GDiR^_4PO>kH=j*PNrZ+k)5G<$T{AL*=)J$)yAdKW1vY4V;w)x!+!>AU_E zV1}a0Oa9c4pVcOoZBW3W7KkRU#BH!V0qb&<+YH%KwCdDksHE!1JAy1FdM<8Dv8T~d zq8@Pt7;kPS;YHup!3&$nT2mZqdb21Yz1MlP(sX5hF=9jOia`d3F)>-nV2G=2lkpKc zw=B}Fd(Hl%TI|&f5R@*dXSmH;TZ0*H0vew_fX8hV$-_Y3i3_^WOqfkia!MlG@V?dI zgC;BbT^M*w0?e@Bh+8uIor8v?Wn3^X(;-RMCB-iczjJoFdjh1BhsCZ7&ytlw-hg0s zgZ?`0Or8#o;WqHVx1p&T#1LnG=3A{^yCT#oFz~Zzx8um*5NsdyN=y;`XOvIZ2g?P3 zk=qyKddX%VAwmD_bZ><7V`Q{ufrh~?kN{)o2XgYJKzJsICqNj(u21TOU+z2@ z^~=%@{uDo5d@f%~k_)LEHyQl9v;G(L7=_Oi0WlSopxHYT-p3kS8<}P+R3KcdmtlmK z)PMmv)M~2wYv9z1FD3{J}{~(Ci+4-l0YrbwFmYFgZA+X>?gp3nC6Yl>L28 zA&kI1qyCr$itY)UQU0e7ACCaV%t3mW)Ubt|Cw8>gIQMAau$n)L0Sl@Iq9dgSI^zN4 zgoHgA@|!+#`r2!mv?T&T!`=0DU|`V=JTDl>z_AU){9?lbTa*;ACuvZ%B|XGNcr1#( zec=*HG@IUI76<4uz0xaHCvxcSOMg}Mctn&uMALO2rrB~f5=Dz!NvZindw7#o3j`T5N2Nla~=Z7oDCRdicONC=nQ~s zaV$cL(hj$?q)>eDA|pC{lnjzFFhQkX(-kGjJNjHv}{jdTH$ zOBM$%fJWXR`JEyrzB&|%(3Bq_^3`>3q@Ai9LaGQAf?{y`T$w0jwnWzL6{}dGBqa3e z4z6QoUlIZ`1@TffRY)tuQx+PBxGvfhZsaULSqOuyw1c~9eWU^HFlf8tPT2gg2bqT6NN=Qug zD;e-Isy-2ZdeWE+b_Ff_Xk3-0vqjy0cY(72QJ# ziLwwoNK*r$ALz}&X{CC-T!K@;Du*|w!VadZuvAM19YhT_tGyX2(c1(061|vnYd$sX zD3#F2dQ}Wq_%~%xR|i5Hb$%3rj5&X=$23eGC=`2o7*JHinE^$pP#aN+3{(Brpc0x~ zaG+NQAQv&l5v}8~s>>ia2}1I|zcW>9o4YzbjW=Q|7>`PT44Ru3-9yn;IN+!J0k{KC zT*PhhYaN}xXBuQ6CnQkl6EhYU&cx6u0y8PfHyC9$X)Xm`g!^v7 zjoz8~pcP3sOwr&bMIKm|s3~tT9)T-IB%N&o!W_N86Y2p)FV;gX833^DzLpSMmd(@6 z3=5-^5(>cxblXq)q4uiNfU=;Uk4tKaDyhwBZ};Uoc7V(|oqMmq%ZlD)}Jm(X)6 zV&VkzK|IwI`k6SpFeFkNUa+)VWp+?Gy z_J%zVdVxq#S&WY|_7jfj z)tQhID4_g`ETa-6guK2ld|hJpEd+j>!!s5q_hN}!#DD3yzxX2R`g2Iw@C-msMuQ&Q zn(i2Lg|oE2ZrzDZkqvnk+w#g9&oa$k$XUZH;Vjba^|gc^luXL9scyc& z1;ExU5QA4>SoZ@hxaX9&#|TNrt!JHhTnW-Rru0mg5>^p2Bo(8v0FlF8AVxGlUal^M(Mk?HjZ(Cfbb zk!^;n5+iie*iNC*6(kBH7LCMeP!po)u~dpn!MSNqw~$IbRr%yj89`P}W;|`fppcjJ z^0^P>{xB= zCyHkBc!V08$%v^;cOjGeCC*n}olKyck%qA^=M#SU8Z(7(N#uS$A<1JjfGvW3ELl{V z;{moIVMno=DDi;0eb@uTfzdN+q{=`v(Wtq6$C%!eG@^!5xvc{z&=gBi;b2UhtFV>=Z0Oo5JGVAlW&zJSUt^+R z-asyqSAV7Bh^m>o+($fLJf1vV+SP>^x|qW&sWvdgW>gc46%Jy|_IJ6E(-o1y5rr8l z%m}$b17abAC*2X&<%m`DL1&d*c_d~^*rj1%jIdBCjA7J)UEX%i6m$aT+QK}RavOs+ zZ3t>waxT+aD%W=~8yd8j=Ar3TL879-jgkzBaELN4fokbYYBEyVZ*Rs$&d}YZ0>`1l zV#Ig%*K@_zIiLLE)1}WeC|29v<+jB>OnWZc5}?%A?|#OU>&OdTpVXu567C_1_pIf> zRcQ}zMKPJWExF9Sn%ly<|K7SSvL>Ab%ND1Dt;_&|lZnyJ@!6>J;kYwKJjw~o;J%3a zE~-h*m-_111E(QW_V5F2VP3hXx)N;!wmTZNaJ;Gbce;{Ah<3R6uy^!$aQx{)+Q?@> zby_}JHZUvZ_ObgG5UO#ps51^m_I$wv&`61hl5~}{D`jftE-qQV=WG06Cy=qdy^^o+ zlQRg}kewk#42#LBI{?GImH-V^L0yNjrZG2n z-08}o7PrH2-zZ4O2^JZJeh~nPLKVEWtl#WY@P8zZ#pv*&fn6K`1vyMi8eJ zVDAK1c}2<7{ToOAEQFC+WXQo!HBbx7x8sRS=q?YT_`qYNJw%}R84WH*cniCH_%NDX z{VkLSVLa3V>LSqYjmS2T`n-o1;kXa>LSCk}8Nmy&C(HsBRP6~^(^WfGBx}b*G>k(} zwYXm#$?8Mm%{*nYwQAI(iLVO@+YIooL4_Hy!zd|*gI#dBuJz!%2)!e;Y5kxn(+;sQ zGB{9OZV&OEHi+?y%FlwB;WpC^G? zPS9ry(nSPU?kM7AuW-%q=r-7h45>@MiSb>*$*=W>_2=zJFY{4-R>E@7B&`FU&k zGctp|0zV*`@OcP+5yPQ|6~Te5YQiH!0nARXi;GT}mGAr#xhtcNI~4+ufD?R&06A1T zo9})GTOwZ;0E&d;3XFrrfwAKRtTG(pyL@gN)nK<_sF% zvv~eypw>yxw?iH-?%G1xqq_F;G+m@A$Lj`+8MP3v(1AU?7{+uOO2YL9ogTN&1#ZC# z*!K|l!W*F&z>ZVvo~;m_ff52WjV4R+$cj5avhE%y(@65`6?@=jOw%K(n%E5+!$We! zC5zOFDxqku011h_(tME&)XCN43oLCph7M(C>|QrlffnADxN-!;*qyJ;H-XcFU+&Lu z_7H+uJ_?=6t3EPYzwi~jj~5@2OLp*#evRO%QD5xC$rTHdwAvs?rcH+7i3-E*5f@{S zR)$J&NwHgT&{9Vt-B6FEW*7I!7A1)%Rv@0())Z>xo9^m}r2zu^UF1=(j&GK9;}!O| zi8#s|D6j&{bGc(5FMZdp5ze zET&&uev)|9K2%jN;7OI8x1h4%gu>rdQ(P`IWf!a*i37hd8YK{~LWC~z_jMaw*otdYNpTwvI3)fSz6CV$4$NqW z*GlKpkiNcE3Rk#r!c#0na+ac(mi6psX_aG_XCafFo&9$Y2M)0fJ#Wa=y_L80b5?%& zu2s+jjWo5Nl^}G|q@Ict(9viRmti_x>(qIwigG3h=nwcn!Mt<<;l~g<{*vK2vh&7; zrGyrqOUpPXS-Z#OlN5Ll1YuaJ>YuP`Ce2$W#M(oeo8QTCntQt zDVSEz*;W`^EOQhL=dzp#A#P&(L60RdC6yFLUJaUZN+;}yl_Zh`7ITh2P>yaaaw8%^ z6)y1Mdwid=kVmWc*27d_$JXBluQebJ>e;bRoeo_2u8!511D~6uz`wY9Gai4;iS$P;G4z`!4xqy1fkqN8=C5??*;;T}Q2E!OI`6y7zJT7C2 zI*uUjWF9cHY-o?%C%_0pLj7agKD!fDflTk-hX;?qpPDyQBuPm-%0Ko6#*$SF>?zZV zchW>G6+*1zY6HYgCw5{1H>nD~9$gZw2Y|h;_8n~ zI^nxOl&HzC86C7tk_1X*(TATq9Z3NnepI4P=Jq6lx(3Wl|mqO;~piPCbUfwq9yjbeyoPaMdW*}sx_vI^vNIx>LSyC;2@W}afGB|qkT?ytp~cFg;cf|y z?hAnwXCgtWQzV2leEP~0I)Wf5JRB)VJ=FrHv@a%~M2$-a;h8#=u=qyNLnq;w7qRE2AR(bs#v(3fSSASJU^m)+3Ylr&7O z9dUKaj&+@)uB=Rm6PZt)vy}gcbLb*R^aq~c5}^~iMIv9BL4yxygCyI;)sx?eWm8VH z)KDtr4&p37&9{k?W))8mjEq@R-5e>dqA{h2n^`}x+md3Y&j24MUka(Zj%7VQ5j;}k z({5HH4nEBz4kxM{bOvo_o`AGNaiWOK+lZ6uaIZL9*w47uj+Ne7%k%$JM6ODYA$aoo^AOg;4K@`|( zFno38-F*$BjAdQIQbup{T1zv+YmrnLcnFDN${Gb?t;lT>y)$$ z{7|_OO^H8@F$S9yj1DM~1~A;tz&!qB#1gd@31>dW8$o6B3Hqtn5fjU3JZ72+130QM z(&PUx8p|&Lq%8_W4MH-DmK3A?jl&Q3cXZ=|&MN0LED?BvtCj1w#o$m!9=2OVCUQzOZ>RO~Rw zqA)GSsYaXj^rdcVM?Nkmg@o2}Y?1}pc2wh=v~M)m8UT^^b44t9u@gUnBEsPQtrEt( z27n?CF~j&${Hk#&FuV|~3*haJAD*>F+y`5`iz)hC2~dtou)^iLkci)GNJ;G(XDrwr zrdhSg3xSFWrGc2d_GmfSX2he|#kd?MZ6u*7PZI53K^~S3V_FH-OdferZh2UtSGyUy z(LmzhQLB#we@Ba8>hgY_R|E>lh1h>=`3hhp9mzU;{Pr2ny3uP#>6*6K@04-NirTx} z@>fTNfRBuIr_~V$hAcgb^}-a{itWFN=AImUicI+o?xp)V#@4~(!SlZ7+&#scidw># zSK#Vo;x23o3a*XF6<0|f@$mA?1gl=Mt}Gk%)vq8N$q;PyY}J{tech7M`hdxPWjGEH zE`lCDgb+7T6KTMU@1pE%Z46tXDNs*75;3j9V0gK05VGRHeu4H5)fIIODp1vwYX|lnh=W#aAf923k6>wWZz49>PV4G1fi_4 zuEy{pkYf0aY?d>T56}>!HM_qL7m{H< z60^YByl3>Ot7EM=ISHa19~Eawhh66gVPL5r1muX{hKzw+%k>@Z0=B=%)yg7~eFC zgr%Jg0@uW7Fc%GP0ucI}X+`0l*D9p;2A-Fm;rI7Khh1|iK0S3`*KikQ&y0`U;~=k_tIJx?$Bcoy|Q=F+}Z*| zJ8HDdLII}4j0wDPAPIS{MBCb$mk?IDBGxQnx$Ig;ygFL5swv`R==f96K$UFP7B)(> zdcC-<;U?jb6*UM+eUAVZO5olBF+^*RR`)T_i9~f9|I^N3F;I=|>S0Mi59j7bsLHpO zkZ&itmtq^|Z)0g>IF?F}-wxayUxc_jsX5Kw6UJm+2uT_na*A>gi8ik<54T`)Jrx0odr%s^Wrp#wtyu?>?;HTtKsQrJb;t-XEKLDH ztd_t~t{(8+vuG?rL=1+O7qBO#R;^$`myWL7va>hGeF^IBEWJAwdD?un0W{BR%g6(y zUV_;;f>!{6_f^!6@8D_oWU@PK9z5C?NpMJdau;XpYZm=BC@CrVE+_s~=`xMt!m+w@ zsw5PFq`>;rLF~ z8KsO#>c-)`6gX<#{&7dvF0A1=l`zS0kWYE*ey7M4&VjWufR|Gg%gk!osHak}#J25< z@KJdL87z^IZXN){YEAq2M4f)G9tAMtQSO5|u{xI>7f zy@XpLQgM}Lic{unh}VRAu`KYfV^<4=Vw%y?T?F43$Z^QAXQ-AG$`XVbYKX)uu~_X8 zw@YJWPo8>>fPIf0mheAoWYfj3MDz$~#NflafiWvdUFm`Yb#02?&s(#yTHcRim zd3{d*{l0xR?9)D8`}H?}(Z06u`RDQf&-M3jzWK}cf*-$w|9@t`fBntx**E|A1AckU zf6e`afqZ@V$FIp(zW9;7{Pj22LoxmG*ZsHDU&Wf<-rS%3ciPw=>4%m0-T!-Tj{hJ2 zqfh64_ix<);Mc!hAGFU-F^gJ3$v1z^TeVNZFaKox|K{&KoBM|^{&? 8 THEN DevCPM.err(-779); FReg := 8 + END + END CheckReg; + + PROCEDURE CheckAv* (reg: INTEGER); + BEGIN + ASSERT(reg IN WReg) + END CheckAv; + + PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR n: INTEGER; s, s1: SET; + BEGIN + CASE f OF + | Byte, Bool, Char8, Int8: + s := BReg * {0..3} - stop; + IF (high IN stop) OR (high IN hint) & (s - hint # {}) THEN n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + IF s - hint # {} THEN s := s - hint END; + WHILE ~(n IN s) DO INC(n) END + ELSE + s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END; + s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4); + IF s1 # {} THEN s := s1 END; + WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END; + IF ~(n IN s) THEN n := n + 4 END + END; + EXCL(BReg, n); EXCL(WReg, n MOD 4) + | Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16: + s := WReg - stop; + IF high IN stop THEN s := s * {0..3} END; + IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END; + s1 := s - hint; + IF high IN hint THEN s1 := s1 * {0..3} END; + IF s1 # {} THEN s := s1 END; + IF 0 IN s THEN n := 0 + ELSIF 2 IN s THEN n := 2 + ELSIF 6 IN s THEN n := 6 + ELSIF 7 IN s THEN n := 7 + ELSIF 1 IN s THEN n := 1 + ELSE n := 3 + END; + EXCL(WReg, n); + IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END + | Real32, Real64: + IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END; + DEC(FReg); n := 0 + END; + DevCPL486.MakeReg(x, n, f); + END GetReg; + + PROCEDURE FreeReg (n, f: INTEGER); + BEGIN + IF f <= Int8 THEN + INCL(BReg, n); + IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END + ELSIF f IN realSet THEN + INC(FReg) + ELSIF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeReg; + + PROCEDURE FreeWReg (n: INTEGER); + BEGIN + IF n IN AllReg THEN + INCL(WReg, n); + IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END + END + END FreeWReg; + + PROCEDURE Free* (VAR x: DevCPL486.Item); + BEGIN + CASE x.mode OF + | Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END + | Ind: FreeWReg(x.reg); + IF x.scale # 0 THEN FreeWReg(x.index) END + | Reg: FreeReg(x.reg, x.form); + IF x.form = Int64 THEN FreeWReg(x.index) END + ELSE + END + END Free; + + PROCEDURE FreeHi (VAR x: DevCPL486.Item); (* free hi byte of word reg *) + BEGIN + IF x.mode = Reg THEN + IF x.form = Int64 THEN FreeWReg(x.index) + ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4) + END + END + END FreeHi; + + PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN; (* x.mode = Reg *) + BEGIN + IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END; + IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop)) + ELSIF x.form IN realSet THEN RETURN ~(float IN stop) + ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop) + ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop)) + END + END Fits; + + PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET); + VAR rh: DevCPL486.Item; + BEGIN + IF f = Int64 THEN + GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r); + GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh); + r.form := Int64; r.index := rh.reg + ELSE + IF f < Int16 THEN INCL(stop, high) END; + GetReg(r, f, hint, stop); DevCPL486.GenPop(r) + END + END Pop; + + PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + + PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET); (* = Assert(x, hint, stop + {mem, stk}) *) + VAR r: DevCPL486.Item; f: BYTE; + BEGIN + f := x.typ.form; + IF x.mode = Con THEN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END; + IF con IN stop THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + ELSIF x.mode = Stk THEN + IF f IN realSet THEN + GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form) + ELSE + Pop(r, f, hint, stop) + END; + x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f + ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN + Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r); + x.mode := Reg; x.reg := r.reg; x.form := Int32 + ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN + IF f = Int64 THEN LoadLong(x, hint, stop) + ELSE + Free(x); GetReg(r, f, hint, stop); + IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := f + END + END + END Load; + + PROCEDURE Push* (VAR x: DevCPL486.Item); + VAR y: DevCPL486.Item; + BEGIN + IF x.form IN realSet THEN + Load(x, {}, {}); DecStack(x.form); + Free(x); x.mode := Stk; + IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END; + DevCPL486.GenFStore(x, TRUE) + ELSIF x.form = Int64 THEN + Free(x); x.form := Int32; y := x; + IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END; + DevCPL486.GenPush(y); DevCPL486.GenPush(x); + x.mode := Stk; x.form := Int64 + ELSE + IF x.form < Int16 THEN Load(x, {}, {high}) + ELSIF x.form = Int16 THEN Load(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x); x.mode := Stk + END + END Push; + + PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN + IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x) + ELSE Load(x, hint, stop); + END + ELSE + CASE x.mode OF + | Var, VarPar: IF ~(mem IN stop) THEN RETURN END + | Con: IF ~(con IN stop) THEN RETURN END + | Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END + | Stk: IF ~(stk IN stop) THEN RETURN END + | Reg: IF Fits(x, stop) THEN RETURN END + ELSE RETURN + END; + IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x) + ELSE Load(x, hint, stop) + END + END + END Assert; + + (*------------------------------------------------*) + + PROCEDURE LoadR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN + Free(x); DevCPL486.GenFLoad(x); + IF x.mode = Stk THEN IncStack(x.form) END; + GetReg(x, Real32, {}, {}) + END + END LoadR; + + PROCEDURE PushR (VAR x: DevCPL486.Item); + BEGIN + IF x.mode # Reg THEN LoadR(x) END; + DecStack(x.form); + Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE) + END PushR; + + PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSE + Free(x); GetReg(r, x.form, hint, stop); + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg + END + END LoadW; + + PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop); + IF (x.form < Int32) OR (x.form = Char16) THEN + r := x; x.form := Int32; DevCPL486.GenExtMove(r, x) + END + ELSE + Free(x); + IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END; + IF x.mode = Con THEN x.form := r.form END; + IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := r.form + END + END LoadL; + + PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r, rh, c: DevCPL486.Item; offs: INTEGER; + BEGIN + IF x.form = Int64 THEN + IF x.mode = Stk THEN + Pop(x, x.form, hint, stop) + ELSIF x.mode = Reg THEN + FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop); + FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop); + x.form := Int32; DevCPL486.GenMove(x, r); + x.reg := x.index; DevCPL486.GenMove(x, rh); + x.reg := r.reg; x.index := rh.reg + ELSE + GetReg(rh, Int32, hint, stop + {AX}); + Free(x); + GetReg(r, Int32, hint, stop); + x.form := Int32; offs := x.offset; + IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END; + DevCPL486.GenMove(x, rh); + x.offset := offs; + DevCPL486.GenMove(x, r); + x.mode := Reg; x.reg := r.reg; x.index := rh.reg + END + ELSE + LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh); + x.index := rh.reg + END; + x.form := Int64 + END LoadLong; + + (*------------------------------------------------*) + + PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET); + BEGIN + ASSERT(x.mode = Reg); + GetReg(y, x.form, hint, stop); + DevCPL486.GenMove(x, y) + END CopyReg; + + PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR r: DevCPL486.Item; + BEGIN + IF x.mode = DInd THEN + x.mode := Ind + ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN + x.mode := Reg + ELSE + Free(x); GetReg(r, Pointer, hint, stop); + IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END; + x.mode := Reg; x.reg := r.reg; x.form := Pointer + END; + x.form := Pointer; x.typ := DevCPT.anyptrtyp; + Assert(x, hint, stop) + END GetAdr; + + PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN); + VAR r, v: DevCPL486.Item; + BEGIN + IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer + ELSIF niltest THEN + GetAdr(x, {}, {mem, stk}); + DevCPL486.MakeReg(r, AX, Int32); + v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg; + DevCPL486.GenTest(r, v) + ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer + ELSE GetAdr(x, {}, {}) + END; + Free(x); DevCPL486.GenPush(x) + END PushAdr; + + PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET); + VAR n: BYTE; + BEGIN + a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ; + IF lev = DevCPL486.level THEN a.reg := BP + ELSE + a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev])); + WHILE n > 0 DO + a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n) + END + END + END LevelBase; + + PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *) + BEGIN + IF x.tmode = VarPar THEN + LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr; + ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind)); + len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32 + END; + INC(len.offset, typ.n * 4 + 4); + IF typ.sysflag = stackArray THEN len.offset := -4 END + END LenDesc; + + PROCEDURE Tag* (VAR x, tag: DevCPL486.Item); + VAR typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final type *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ) + ELSIF x.typ.form = Pointer THEN + ASSERT(x.mode = Reg); + tag.mode := Ind; tag.reg := x.reg; tag.offset := -4; + IF x.typ.sysflag = interface THEN tag.offset := 0 END + ELSIF x.tmode = VarPar THEN + LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4; + Free(tag) (* ??? *) + ELSIF x.tmode = Ind THEN + ASSERT(x.mode = Ind); + tag := x; tag.offset := -4 + ELSE + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ) + END; + tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp + END Tag; + + PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER; + BEGIN + WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END; + IF typ # NIL THEN RETURN typ.n + ELSE RETURN 0 + END + END NumOfIntProc; + + PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN; + VAR fld: DevCPT.Object; + BEGIN + WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END; + IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + REPEAT + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) + OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END; + fld := fld.link + END; + typ := typ.BaseTyp + UNTIL typ = NIL + END; + RETURN FALSE + END ContainsIPtrs; + + PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item); + VAR cv: DevCPT.Const; + BEGIN + IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END; + cv := DevCPT.NewConst(); + cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str; + DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp + END GuidFromString; + + PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END + END; + IF x.mode # Reg THEN + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + ELSE r := x + END; + IF nilTest THEN + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + DevCPL486.GenPush(r); p := r; + IF x.mode # Reg THEN Free(r) END; + GetReg(r, Pointer, {}, {}); + p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r); + p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPAddRef; + + PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN); + VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label; + BEGIN + ASSERT(x.mode IN {Ind, Abs}); + ASSERT({AX, CX, DX} - WReg = {}); + IF hints THEN + IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END + END; + GetReg(r, Pointer, {}, {}); + p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r); + DevCPL486.MakeConst(c, 0, Pointer); + IF nilTest THEN + DevCPL486.GenComp(c, r); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nilSet THEN DevCPL486.GenMove(c, p) END; + DevCPL486.GenPush(r); + p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r); + p.offset := 8; Free(r); DevCPL486.GenCall(p); + IF nilTest THEN DevCPL486.SetLabel(lbl) END; + END IPRelease; + + PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET); + VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN + DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ; + WHILE typ.comp = DynArr DO (* complete dynamic array iterations *) + LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + END; + n := x.scale; i := 0; + WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END; + IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *) + DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n + END + END; + CASE x.mode OF + Var, VarPar: + lev := x.obj.mnolev; + IF lev <= 0 THEN + x.mode := Abs + ELSE + LevelBase(y, lev, hint, stop); + IF x.mode # VarPar THEN + x.mode := Ind + ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN + x.mode := DInd; x.offset := x.obj.adr + ELSE + y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind + END; + x.reg := y.reg + END; + x.form := x.typ.form + | LProc, XProc, IProc: + x.mode := Con; x.offset := 0; x.form := ProcTyp + | TProc, CProc: + x.form := ProcTyp + | Ind, Abs, Stk, Reg: + IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END + END + END Prepare; + + PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object); + BEGIN + INC(x.offset, field.adr); x.tmode := Con + END Field; + + PROCEDURE DeRef* (VAR x: DevCPL486.Item); + VAR btyp: DevCPT.Struct; + BEGIN + x.mode := Ind; x.tmode := Ind; x.scale := 0; + btyp := x.typ.BaseTyp; + IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0 + ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size + ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4 + ELSE x.offset := 0 + END + END DeRef; + + PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET); (* x[y] *) + VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER; + BEGIN + btyp := x.typ.BaseTyp; elsize := btyp.size; + IF elsize = 0 THEN Free(y) + ELSIF x.typ.comp = Array THEN + len.mode := Con; len.obj := NIL; + IF y.mode = Con THEN + INC(x.offset, y.offset * elsize) + ELSE + Load(y, hint, stop + {mem, stk, short}); + IF inxchk THEN + DevCPL486.MakeConst(len, x.typ.n, Int32); + DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap) + END; + IF x.scale = 0 THEN x.index := y.reg + ELSE + IF x.scale MOD elsize # 0 THEN + IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4 + ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2 + ELSE elsize := 1 + END; + DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32); + DevCPL486.GenMul(len, y, FALSE) + END; + DevCPL486.MakeConst(len, x.scale DIV elsize, Int32); + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END; + x.scale := elsize + END; + x.tmode := Con + ELSE (* x.typ.comp = DynArr *) + IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END; + LenDesc(x, len, x.typ); + IF x.scale # 0 THEN + DevCPL486.MakeReg(idx, x.index, Int32); + DevCPL486.GenMul(len, idx, FALSE) + END; + IF (y.mode # Con) OR (y.offset # 0) THEN + IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN + Load(y, hint, stop + {mem, stk, con, short}) + ELSE y.form := Int32 + END; + IF inxchk & ~x.typ.untagged THEN + DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap) + END; + IF (y.mode = Con) & (btyp.comp # DynArr) THEN + INC(x.offset, y.offset * elsize) + ELSIF x.scale = 0 THEN + WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END; + x.index := y.reg; x.scale := btyp.size + ELSE + DevCPL486.GenAdd(y, idx, FALSE); Free(y) + END + END; + IF x.tmode = VarPar THEN Free(len) END; (* ??? *) + IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END + END + END Index; + + PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN); + VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct; + BEGIN + typ := x.typ; + IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END; + IF ~guard & typ.untagged THEN DevCPM.err(139) + ELSIF ~guard OR typchk & ~typ.untagged THEN + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + IF (x.typ.form = Pointer) & (x.mode # Reg) THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag) + ELSE Tag(x, tag) + END; + IF ~guard THEN Free(x) END; + IF ~equal THEN + GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r); + tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev + END; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + IF guard THEN + IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END + ELSE setCC(x, eql, FALSE, FALSE) + END + END + END + END TypTest; + + PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct); + VAR tag, tdes: DevCPL486.Item; + BEGIN + (* tag must be in AX ! *) + IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END; + IF testtyp.untagged THEN DevCPM.err(139) + ELSE + tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer; + DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp); + DevCPL486.GenComp(tdes, tag); + setCC(x, eql, FALSE, FALSE) + END + END ShortTypTest; + + PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER); + VAR c: DevCPL486.Item; + BEGIN + ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4)); + IF ranchk & (x.mode # Con) THEN + DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x); + IF min # 0 THEN + DevCPL486.GenAssert(ccLE, ranTrap); + c.offset := min; DevCPL486.GenComp(c, x); + DevCPL486.GenAssert(ccGE, ranTrap) + ELSIF max # 0 THEN + DevCPL486.GenAssert(ccBE, ranTrap) + ELSE + DevCPL486.GenAssert(ccNS, ranTrap) + END + END + END Check; + + PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN); + VAR c: DevCPL486.Item; local: DevCPL486.Label; + BEGIN + IF useSt1 THEN DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + ELSE DevCPL486.GenFMOp(1C0H); (* FLD ST0 *) + END; + DevCPL486.GenFMOp(1FCH); (* FRNDINT *) + DevCPL486.GenFMOp(0D1H); (* FCOM *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.AllocConst(c, DevCPL486.one, Real32); + DevCPL486.GenFDOp(FSUB, c); + DevCPL486.SetLabel(local); + END Floor; + + PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET); + BEGIN + IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END; + DevCPL486.GenFStore(x, TRUE); + IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END + END Entier; + + PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET); (* x := y *) + (* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *) + VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item; + BEGIN + f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk}); + IF y.form IN {Real32, Real64} THEN + IF f IN {Real32, Real64} THEN + IF m = Undef THEN + IF (y.form = Real64) & (f = Real32) THEN + IF y.mode # Reg THEN LoadR(y) END; + Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE) + END + ELSE + IF y.mode # Reg THEN LoadR(y) END; + IF m = Stk THEN DecStack(f) END; + IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END; + END + ELSE (* x not real *) + IF sysval THEN + IF y.mode = Reg THEN Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN + x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f + ELSE + ASSERT(y.form # Real64); + DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32; + IF m # Stk THEN + Pop(y, y.form, hint, stop); + IF f < Int16 THEN ASSERT(y.reg < 4) END; + y.form := f; + IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END + END + END + ELSE (* y.mode # Reg *) + y.form := f; + IF m # Undef THEN LoadW(y, hint, stop); Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END + END + END + ELSE (* not sysval *) + IF y.mode # Reg THEN LoadR(y) END; + Free(y); + IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN + Entier(x, y.typ, hint, stop); + ELSE + DecStack(f); y.mode := Stk; + IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END; + IF m = Stk THEN Entier(y, y.typ, {}, {}) + ELSIF m = Undef THEN Entier(y, y.typ, hint, stop) + ELSE Entier(y, y.typ, hint, stop + {stk}) + END; + IF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y) + END; + y.form := f; + IF (m # Undef) & (m # Stk) THEN + IF f = Int64 THEN + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + Free(y); DevCPL486.GenMove(y, x); + END + END + END + END + END + ELSE (* y not real *) + IF sysval THEN + IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END; + IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END + ELSE + CASE y.form OF + | Byte, Bool: + IF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char8: + IF f = Int8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Char16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, 0, 0) + ELSIF f = Char16 THEN (* ok *) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int32 THEN LoadL(y, hint, stop) + END + | Int8: + IF f = Char8 THEN Check(y, 0, 0) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF f >= Int16 THEN LoadL(y, hint, stop) + END + | Int16: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 0) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop) + END + | Int32, Set, Pointer, ProcTyp: + IF f = Char8 THEN Check(y, 0, 255); FreeHi(y) + ELSIF f = Char16 THEN Check(y, 0, 65536) + ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y) + ELSIF f = Int16 THEN Check(y, -32768, 32767) + ELSIF f = Int64 THEN LoadLong(y, hint, stop) + END + | Int64: + IF f IN {Bool..Int32, Char16} THEN + (* make range checks !!! *) + FreeHi(y) + END + END + END; + IF f IN {Real32, Real64} THEN + IF sysval THEN + IF (m # Undef) & (m # Reg) THEN + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); + IF m = Stk THEN DevCPL486.GenPush(y) + ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f + END + ELSE + IF y.mode = Reg THEN Push(y) END; + y.form := f; + IF m = Reg THEN LoadR(y) END + END + ELSE (* not sysval *) (* int -> float *) + IF y.mode = Reg THEN Push(y) END; + IF m = Stk THEN + Free(y); DevCPL486.GenFLoad(y); s := -4; + IF f = Real64 THEN DEC(s, 4) END; + IF y.mode = Stk THEN + IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END + END; + IF s # 0 THEN AdjustStack(s) END; + GetReg(y, Real32, {}, {}); + Free(y); DevCPL486.GenFStore(x, TRUE) + ELSIF m = Reg THEN + LoadR(y) + ELSIF m # Undef THEN + LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE) + END + END + ELSE + y.form := f; + IF m = Stk THEN + IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END; + Push(y) + ELSIF m # Undef THEN + IF f = Int64 THEN + IF y.mode # Reg THEN LoadLong(y, hint, stop) END; + Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z); + IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END; + y.reg := y.index; DevCPL486.GenMove(y, z); + ELSE + IF y.mode # Reg THEN LoadW(y, hint, stop) END; + Free(y); DevCPL486.GenMove(y, x) + END + END + END + END + END ConvMove; + + PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET); (* size >= 0: sysval *) + VAR y: DevCPL486.Item; + BEGIN + ASSERT(x.mode # Con); + IF (size >= 0) + & ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4)) + OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END; +(* + IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.form IN {Comp, Int64})) THEN DevCPM.err(220) END; +*) + y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop) + END Convert; + + PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET); + VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item; + BEGIN + IF mem IN stop THEN GetReg(x, Bool, hint, stop) END; + IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *) + DevCPL486.GenSetCC(y.offset, x) + ELSE + end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl; + DevCPL486.GenJump(y.offset, T1, TRUE); (* T1 to enable short jump *) + DevCPL486.SetLabel(F); + DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x); + DevCPL486.GenJump(ccAlways, end, TRUE); + DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1); + DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x); + DevCPL486.SetLabel(end) + END; + IF x.mode # Reg THEN Free(x) END + END LoadCond; + + PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con)); + CASE subcl OF + | eql..geq: + DevCPL486.GenComp(y, x); Free(x); + setCC(x, subcl, rev, x.typ.form IN {Int8..Int32}) + | times: + IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END + | slash: + DevCPL486.GenXor(y, x) + | plus: + IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END + | minus, msk: + IF (x.form = Set) OR (subcl = msk) THEN (* and not *) + IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x) (* y and not x *) + ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x) (* x and y' *) + ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x) (* x and not y *) + ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x) (* not (not x or y) *) + END + ELSE (* minus *) + IF rev THEN (* y - x *) + IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x) + ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk) (* ??? *) + END + ELSE (* x - y *) + DevCPL486.GenSub(y, x, ovflchk) + END + END + | min, max: + local := DevCPL486.NewLbl; + DevCPL486.GenComp(y, x); + IF subcl = min THEN + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE) + ELSE DevCPL486.GenJump(ccLE, local, TRUE) + END + ELSE + IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE) + ELSE DevCPL486.GenJump(ccGE, local, TRUE) + END + END; + DevCPL486.GenMove(y, x); + DevCPL486.SetLabel(local) + END; + Free(y); + IF x.mode # Reg THEN Free(x) END + END IntDOp; + + PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN); (* INC(x, y) or DEC(x, y) *) + BEGIN + ASSERT(x.form = Int64); + IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END; + Free(x); Free(y); x.form := Int32; y.form := Int32; + IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END; + INC(x.offset, 4); + IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END; + IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END; + END LargeInc; + + PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN); + VAR local: DevCPL486.Label; a, b: DevCPL486.Item; + BEGIN + ASSERT(x.mode = Reg); + IF y.form = Int64 THEN LoadR(y) END; + IF y.mode = Reg THEN rev := ~rev END; + CASE subcl OF + | eql..geq: DevCPL486.GenFDOp(FCOMP, y) + | times: DevCPL486.GenFDOp(FMUL, y) + | slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END + | plus: DevCPL486.GenFDOp(FADD, y) + | minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END + | min, max: + IF y.mode = Reg THEN + DevCPL486.GenFMOp(0D1H); (* FCOM ST1 *) + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END; + DevCPL486.GenFMOp(5D1H); (* FST ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D8H) (* FSTP ST0 *) + ELSE + DevCPL486.GenFDOp(FCOM, y); + CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; + IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END; + DevCPL486.GenFMOp(5D8H); (* FSTP ST0 *) + DevCPL486.GenFLoad(y); + DevCPL486.SetLabel(local) + END + (* largeint support *) + | div: + IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END; + Floor(y, FALSE) + | mod: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1F8H); (* FPREM *) + DevCPL486.GenFMOp(1E4H); (* FTST *) + CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX}); + DevCPL486.GenMove(a, b); + DevCPL486.GenFMOp(0D1H); (* FCOM *) + DevCPL486.GenFMOp(FSTSW); + DevCPL486.GenXor(b, a); Free(b); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE); + DevCPL486.GenFMOp(0C1H); (* FADD ST1 *) + DevCPL486.SetLabel(local); + DevCPL486.GenFMOp(5D9H); (* FSTP ST1 *) + | ash: + IF y.mode # Reg THEN LoadR(y); rev := ~rev END; + IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END; + DevCPL486.GenFMOp(1FDH); (* FSCALE *) + Floor(y, TRUE) + END; + IF y.mode = Stk THEN IncStack(y.form) END; + Free(y); + IF (subcl >= eql) & (subcl <= geq) THEN + Free(x); CheckAv(AX); + DevCPL486.GenFMOp(FSTSW); + (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF); + setCC(x, subcl, rev, FALSE) + END + END FloatDOp; + + PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + VAR L: DevCPL486.Label; c: DevCPL486.Item; + BEGIN + CASE subcl OF + | minus: + IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END + | abs: + L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccNS, L, TRUE); + DevCPL486.GenNeg(x, ovflchk); + DevCPL486.SetLabel(L) + | cap: + DevCPL486.MakeConst(c, -1 - 20H, x.form); + DevCPL486.GenAnd(c, x) + | not: + DevCPL486.MakeConst(c, 1, x.form); + DevCPL486.GenXor(c, x) + END; + IF x.mode # Reg THEN Free(x) END + END IntMOp; + + PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE); + BEGIN + ASSERT(x.mode = Reg); + IF subcl = minus THEN DevCPL486.GenFMOp(FCHS) + ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS) + END + END FloatMOp; + + PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET); + (* range neg result + F F {x} + F T -{x} + T F {x..31} + T T -{0..x} *) + VAR c, r: DevCPL486.Item; val: INTEGER; + BEGIN + IF x.mode = Con THEN + IF range THEN + IF neg THEN val := -2 ELSE val := -1 END; + x.offset := SYSTEM.LSH(val, x.offset) + ELSE + val := 1; x.offset := SYSTEM.LSH(val, x.offset); + IF neg THEN x.offset := -1 - x.offset END + END + ELSE + Check(x, 0, 31); + IF neg THEN val := -2 + ELSIF range THEN val := -1 + ELSE val := 1 + END; + DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r); + IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END; + Free(x); x.reg := r.reg + END; + x.typ := DevCPT.settyp; x.form := Set + END MakeSet; + + PROCEDURE MakeCond* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Con THEN + setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE) + ELSE + DevCPL486.MakeConst(c, 0, x.form); + DevCPL486.GenComp(c, x); Free(x); + setCC(x, neq, FALSE, FALSE) + END + END MakeCond; + + PROCEDURE Not* (VAR x: DevCPL486.Item); + VAR a: INTEGER; + BEGIN + x.offset := Inverted(x.offset); (* invert cc *) + END Not; + + PROCEDURE Odd* (VAR x: DevCPL486.Item); + VAR c: DevCPL486.Item; + BEGIN + IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END; + Free(x); DevCPL486.MakeConst(c, 1, x.form); + IF x.mode = Reg THEN + IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END; + DevCPL486.GenAnd(c, x) + ELSE + c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x) + END; + setCC(x, neq, FALSE, FALSE) + END Odd; + + PROCEDURE In* (VAR x, y: DevCPL486.Item); + BEGIN + IF y.form = Set THEN Check(x, 0, 31) END; + DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y); + setCC(x, lss, FALSE, FALSE); (* carry set *) + END In; + + PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE); (* ASH, LSH, ROT *) + VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER; + BEGIN + IF subcl = ash THEN opl := SHL; opr := SAR + ELSIF subcl = lsh THEN opl := SHL; opr := SHR + ELSE opl := ROL; opr := ROR + END; + IF y.mode = Con THEN + IF y.offset > 0 THEN + DevCPL486.GenShiftOp(opl, y, x) + ELSIF y.offset < 0 THEN + y.offset := -y.offset; + DevCPL486.GenShiftOp(opr, y, x) + END + ELSE + ASSERT(y.mode = Reg); + Check(y, -31, 31); + L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl; + DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y); + DevCPL486.GenJump(ccNS, L1, TRUE); + DevCPL486.GenNeg(y, FALSE); + DevCPL486.GenShiftOp(opr, y, x); + DevCPL486.GenJump(ccAlways, L2, TRUE); + DevCPL486.SetLabel(L1); + DevCPL486.GenShiftOp(opl, y, x); + DevCPL486.SetLabel(L2); + Free(y) + END; + IF x.mode # Reg THEN Free(x) END + END Shift; + + PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN); + VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN; + BEGIN + ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE; + IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END; + DevCPL486.GenDiv(y, mod, pos); Free(y); + IF mod THEN + r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *) (* ??? *) + END + END DivMod; + + PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct); (* x := Mem[x+offset] *) + BEGIN + IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset) + ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset + END; + x.scale := 0; x.typ := typ; x.form := typ.form + END Mem; + + PROCEDURE SysMove* (VAR len: DevCPL486.Item); (* implementation of SYSTEM.MOVE *) + BEGIN + IF len.mode = Con THEN + IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END + ELSE + Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len) + END; + FreeWReg(SI); FreeWReg(DI) + END SysMove; + + PROCEDURE Len* (VAR x, y: DevCPL486.Item); + VAR typ: DevCPT.Struct; dim: INTEGER; + BEGIN + dim := y.offset; typ := x.typ; + IF typ.untagged THEN DevCPM.err(136) END; + WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END; + LenDesc(x, x, typ); + END Len; + + PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER; + BEGIN + CASE x.form OF + | String8, VString8: RETURN 1 + | String16, VString16: RETURN 2 + | VString16to8: RETURN 0 + | Comp: RETURN x.typ.BaseTyp.size + END + END StringWSize; + + PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN); + VAR sw, dw: INTEGER; + BEGIN + CheckAv(CX); + IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN + DevCPL486.GenBlockComp(4, 4) + ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index) + ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index) + ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index) + ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index) + ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x)) + END; + FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE); + END CmpString; + + PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item); + VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct; + BEGIN + atyp := y.typ; + WHILE ftyp.comp = DynArr DO + IF ftyp.BaseTyp = DevCPT.bytetyp THEN + IF atyp.comp = DynArr THEN + IF atyp.untagged THEN DevCPM.err(137) END; + LenDesc(y, len, atyp); + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z); + len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp; + WHILE atyp.comp = DynArr DO + LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE); + IF y.tmode = VarPar THEN Free(z) END; (* ??? *) + atyp := atyp.BaseTyp + END; + DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE); + Free(len) + ELSE + DevCPL486.MakeConst(len, atyp.size, Int32) + END + ELSE + IF atyp.comp = DynArr THEN LenDesc(y, len, atyp); + IF atyp.untagged THEN DevCPM.err(137) END; + IF y.tmode = VarPar THEN Free(len) END; (* ??? *) + ELSE DevCPL486.MakeConst(len, atyp.n, Int32) + END + END; + DevCPL486.GenPush(len); + ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp + END + END VarParDynArr; + + PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *) + BEGIN + IF y.mode = Con THEN + IF y.form IN {Real32, Real64} THEN + DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {}); + IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END (* ??? move const *) + ELSIF x.form = Int64 THEN + ASSERT(x.mode IN {Ind, Abs}); + y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x); + y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x); + DEC(x.offset, 4); x.form := Int64 + ELSE + DevCPL486.GenMove(y, x) + END + ELSE + IF y.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(x.form = Pointer); + GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer + END; + IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END; + ConvMove(x, y, FALSE, {}, {}) + END; + Free(x) + END Assign; + + PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET); + VAR c: DevCPL486.Item; + BEGIN + IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len) + ELSE len.mode := Con + END; + len.typ := DevCPT.int32typ + END ArrayLen; + +(* + src dest zero +sx = sy x b y b +SHORT(lx) = sy x b+ x w y b +SHORT(lx) = SHORT(ly) x b+ x w y b+ + +lx = ly x w y w +LONG(sx) = ly x b y w * +LONG(SHORT(lx)) = ly x b+ x w* y w * + +sx := sy y b x b +sx := SHORT(ly) y b+ y w x b + +lx := ly y w x w +lx := LONG(sy) y b x w * +lx := LONG(SHORT(ly)) y b+ y w* x w * +*) + + PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *) + BEGIN + IF (x.typ.comp = DynArr) & x.typ.untagged THEN + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1) + ELSE + DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0) + END; + FreeWReg(SI); FreeWReg(DI) + END AddCopy; + + PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *) + VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item; + BEGIN + sx := x.typ.size; CheckAv(CX); + IF y.form IN {String8, String16} THEN + sy := y.index * y.typ.BaseTyp.size; + IF x.typ.comp = Array THEN (* adjust size for optimal performance *) + sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4; + IF sy4 <= sx THEN sy := sy4 + ELSIF sy2 <= sx THEN sy := sy2 + ELSIF sy > sx THEN DevCPM.err(114); sy := 1 + END + ELSIF inxchk & ~x.typ.untagged THEN (* check array length *) + Free(x); LenDesc(x, c, x.typ); + DevCPL486.MakeConst(y, y.index, Int32); + DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap); + Free(c) + END; + DevCPL486.GenBlockMove(1, sy) + ELSIF x.typ.comp = DynArr THEN + IF x.typ.untagged THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1) + ELSE + Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c); + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0) + END + ELSIF y.form IN {VString16to8, VString8, VString16} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + ASSERT(y.mode # Stk) + ELSIF short THEN (* COPY *) + sy := y.typ.size; + IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END; + DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n); + IF y.mode = Stk THEN AdjustStack(sy) END + ELSE (* := *) + IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END; + IF y.mode = Stk THEN AdjustStack(sy) END + END; + FreeWReg(SI); FreeWReg(DI) + END Copy; + + PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + CheckAv(AX); CheckAv(CX); + DevCPL486.GenStringLength(typ.BaseTyp.size, -1); + Free(x); GetReg(x, Int32, {}, wreg - {CX}); + DevCPL486.GenNot(x); + IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END; + FreeWReg(DI) + END StrLen; + + PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct); (* z := z * y *) + VAR c: DevCPL486.Item; + BEGIN + IF y.mode = Con THEN fact := fact * y.offset + ELSE + IF ranchk OR inxchk THEN + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap) + END; + DevCPL486.GenPush(y); + IF z.mode = Con THEN z := y + ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y) + END + END + END MulDim; + + PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *) + (* y const or on stack *) + VAR z: DevCPL486.Item; end: DevCPL486.Label; + BEGIN + ASSERT((x.mode = Reg) & (x.form = Pointer)); + z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32; + IF y.mode = Con THEN y.form := Int32 + ELSE Pop(y, Int32, {}, {}) + END; + end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE); (* flags set in New *) + DevCPL486.GenMove(y, z); + DevCPL486.SetLabel(end); + IF y.mode = Reg THEN Free(y) END + END SetDim; + + PROCEDURE SysNew* (VAR x: DevCPL486.Item); + BEGIN + DevCPM.err(141) + END SysNew; + + PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER); + (* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *) + VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label; + BEGIN + typ := x.typ.BaseTyp; + IF typ.untagged THEN DevCPM.err(138) END; + IF typ.comp = Record THEN (* call to Kernel.NewRec(tag: Tag): ADDRESS *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ); + IF ContainsIPtrs(typ) THEN INC(tag.offset) END; + DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewRec; + ELSE eltyp := typ.BaseTyp; + IF typ.comp = Array THEN + nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n + ELSE (* DynArr *) + nofdim := typ.n+1; + WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END + END ; + WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END; + IF eltyp.comp = Record THEN + IF eltyp.untagged THEN DevCPM.err(138) END; + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp); + IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END; + ELSIF eltyp.form = Pointer THEN + IF ~eltyp.untagged THEN + DevCPL486.MakeConst(tag, 0, Pointer) (* special TDesc in Kernel for ARRAY OF pointer *) + ELSIF eltyp.sysflag = interface THEN + DevCPL486.MakeConst(tag, -1, Pointer) (* special TDesc in Kernel for ARRAY OF interface pointer *) + ELSE + DevCPL486.MakeConst(tag, 12, Pointer) + END + ELSE (* eltyp is pointerless basic type *) + CASE eltyp.form OF + | Undef, Byte, Char8: n := 1; + | Int16: n := 2; + | Int8: n := 3; + | Int32: n := 4; + | Bool: n := 5; + | Set: n := 6; + | Real32: n := 7; + | Real64: n := 8; + | Char16: n := 9; + | Int64: n := 10; + | ProcTyp: n := 11; + END; + DevCPL486.MakeConst(tag, n, Pointer) +(* + DevCPL486.MakeConst(tag, eltyp.size, Pointer) +*) + END; + IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL + ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk) + END; + DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p); + DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag); + p.mode := XProc; p.obj := DevCPE.KNewArr; + END; + DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX}); + IF typ.comp = DynArr THEN (* set flags for nil test *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x) + ELSIF typ.comp = Record THEN + n := NumOfIntProc(typ); + IF n > 0 THEN (* interface method table pointer setup *) + DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE); + tag.offset := - 4 * (n + numPreIntProc); + p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer; + DevCPL486.GenMove(tag, p); + IF nofel.mode # Con THEN (* unk pointer setup *) + p.offset := 8; + DevCPL486.GenMove(nofel, p); + Free(nofel) + END; + DevCPL486.SetLabel(lbl); + END + END + END New; + + PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item); (* returns tag if rec *) + VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct; + BEGIN + par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form; + IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END; + IF ap.typ = DevCPT.niltyp THEN + IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN + DevCPM.err(142) + END; + DevCPL486.GenPush(ap) + ELSIF par.typ.comp = DynArr THEN + IF ap.form IN {String8, String16} THEN + IF ~par.typ.untagged THEN + DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c) + END; + ap.mode := Con; DevCPL486.GenPush(ap); + ELSIF ap.form IN {VString8, VString16} THEN + DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a); + IF ~par.typ.untagged THEN + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c); + Free(ap); StrLen(c, ap.typ, TRUE); + DevCPL486.GenPush(c); Free(c) + END; + DevCPL486.GenPush(a) + ELSE + IF ~par.typ.untagged THEN + IF ap.typ.comp = DynArr THEN niltest := FALSE END; (* ap dereferenced for length descriptor *) + VarParDynArr(par.typ, ap) + END; + PushAdr(ap, niltest) + END + ELSIF fp.mode = VarPar THEN + recTyp := ap.typ; + IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END; + IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN + Tag(ap, tag); + IF rec & (tag.mode # Con) THEN + GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c + END; + DevCPL486.GenPush(tag); + IF tag.mode # Con THEN niltest := FALSE END; + PushAdr(ap, niltest); + IF rec THEN Free(tag) END + ELSE PushAdr(ap, niltest) + END; + tag.typ := recTyp + ELSIF par.form = Comp THEN + s := par.typ.size; + IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN + s := (s + 3) DIV 4 * 4; AdjustStack(-s); + IF ap.form IN {String8, String16} THEN + IF ap.index > 1 THEN (* nonempty string *) + ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4; + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenBlockMove(1, ss); + ELSE + ss := 0; + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c) + END; + IF s > ss THEN + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(1, s - ss) + END; + ELSE + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n); + DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a); + DevCPL486.GenBlockStore(StringWSize(par), 0) + END + ELSE + IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN (* empty string *) + AdjustStack((4 - s) DIV 4 * 4); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c) + ELSE + AdjustStack((-s) DIV 4 * 4); + DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap); + DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c); + IF ap.form IN {String8, String16} THEN + DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4) + ELSIF ap.form IN {VString8, VString16, VString16to8} THEN + DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n) + ELSE + DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4) + END + END + END + ELSIF ap.mode = Con THEN + IF ap.form IN {Real32, Real64} THEN (* ??? push const *) + DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE) + ELSE + ap.form := Int32; + IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END; + DevCPL486.GenPush(ap) + END + ELSIF ap.typ.form = Pointer THEN + recTyp := ap.typ.BaseTyp; + IF rec THEN + Load(ap, {}, {}); Tag(ap, tag); + IF tag.mode = Con THEN (* explicit nil test needed *) + DevCPL486.MakeReg(a, AX, Int32); + c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg; + DevCPL486.GenTest(a, c) + END + END; + DevCPL486.GenPush(ap); Free(ap); + tag.typ := recTyp + ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(par.form = Pointer); + PushAdr(ap, FALSE) + ELSE + ConvMove(par, ap, FALSE, {}, {high}); + END + END Param; + + PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item); + VAR r: DevCPL486.Item; + BEGIN + DevCPL486.MakeReg(r, AX, proc.typ.form); (* don't allocate AX ! *) + IF res.mode = Con THEN + IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res); + ELSIF r.form = Int64 THEN + r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r); + r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r) + ELSE DevCPL486.GenMove(res, r); + END + ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN (* convert to pointer *) + ASSERT(r.form = Pointer); + GetAdr(res, {}, wreg - {AX}) + ELSE + r.index := DX; (* for int64 *) + ConvMove(r, res, FALSE, wreg - {AX} + {high}, {}); + END; + Free(res) + END Result; + + PROCEDURE InitFpu; + VAR x: DevCPL486.Item; + BEGIN + DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x); + DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H); (* FLDCW 0(SP) *) + DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x); (* reset stack *) + END InitFpu; + + PROCEDURE PrepCall* (proc: DevCPT.Object); + VAR lev: BYTE; r: DevCPL486.Item; + BEGIN + lev := proc.mnolev; + IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r) + END + END PrepCall; + + PROCEDURE Call* (VAR x, tag: DevCPL486.Item); (* TProc: tag.typ = actual receiver type *) + VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object; + BEGIN + IF x.mode IN {LProc, XProc, IProc} THEN + lev := x.obj.mnolev; saved := FALSE; + IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN (* pass static link *) + n := imLevel[DevCPL486.level] - imLevel[lev]; + IF n > 0 THEN + saved := TRUE; + y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4; + DevCPL486.MakeReg(r, BX, Pointer); + WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END + END + END; + DevCPL486.GenCall(x); + IF x.obj.sysflag = ccall THEN (* remove parameters *) + p := x.obj.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + IF saved THEN DevCPL486.GenPop(r) END; + ELSIF x.mode = TProc THEN + IF x.scale = 1 THEN (* super *) + DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp) + ELSIF x.scale = 2 THEN (* static call *) + DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ; + IF typ.form = Pointer THEN typ := typ.BaseTyp END; + tag.obj := DevCPE.TypeObj(typ) + ELSIF x.scale = 3 THEN (* interface method call *) + DevCPM.err(200) + END; + IF tag.mode = Con THEN + y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0 + ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN (* final method *) + y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0; + IF tag.mode = Ind THEN (* nil test *) + DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag) + END + ELSE + IF tag.mode = Reg THEN y.reg := tag.reg + ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y) + END; + y.mode := Ind; y.offset := 0; y.scale := 0 + END; + IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset + ELSIF tag.typ.untagged THEN DevCPM.err(140) + ELSE + IF x.obj.link.typ.sysflag = interface THEN (* correct method number *) + x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset + END; + INC(y.offset, Mth0Offset - 4 * x.offset) + END; + DevCPL486.GenCall(y); Free(y) + ELSIF x.mode = CProc THEN + IF x.obj.link # NIL THEN (* tag = first param *) + IF x.obj.link.mode = VarPar THEN + GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag) + ELSE + (* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *) + Result(x.obj.link, tag) (* use result load for first parameter *) + END + END; + i := 1; n := ORD(x.obj.conval.ext^[0]); + WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END + ELSE (* proc var *) + DevCPL486.GenCall(x); Free(x); + IF x.typ.sysflag = ccall THEN (* remove parameters *) + p := x.typ.link; n := 0; + WHILE p # NIL DO + IF p.mode = VarPar THEN INC(n, 4) + ELSE INC(n, (p.typ.size + 3) DIV 4 * 4) + END; + p := p.link + END; + AdjustStack(n) + END; + x.typ := x.typ.BaseTyp + END; + IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128) + & ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN (* restore fpu *) + InitFpu + END; + CheckReg; + IF x.typ.form = Int64 THEN + GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX}); + x.index := y.reg; x.form := Int64 + ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high}) + END + END Call; + + PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct); (* needs CX, SI, DI *) + VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct; + BEGIN + IF typ.untagged THEN DevCPM.err(-137) END; + ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer; + DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32); + DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp + END; + ptr.offset := adr; DevCPL486.GenMove(ptr, src); + DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE); + (* CX = length in bytes *) + StackAlloc; + (* CX = length in 32bit words *) + DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr); + DevCPL486.GenBlockMove(4, 0) (* 32bit moves *) + END CopyDynArray; + + PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER); + VAR i, j, x: INTEGER; + BEGIN + (* align *) + i := 1; + WHILE i < n DO + x := tab[i]; j := i-1; + WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END; + tab[j+1] := x; INC(i) + END; + (* eliminate equals *) + i := 1; j := 1; + WHILE i < n DO + IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END; + INC(i) + END; + n := j + END Sort; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form IN {Pointer, ProcTyp} THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END; + INC(num); + IF adr MOD 4 # 0 THEN + IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END; + INC(num) + END + ELSIF typ.comp = Record THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF (fld.name^ = DevCPM.HdPtrName) OR + (fld.name^ = DevCPM.HdUtPtrName) OR + (fld.name^ = DevCPM.HdProcName) THEN + FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num) + ELSE FindPtrs(fld.typ, fld.adr + adr, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, num); + IF num # i THEN i := 1; + WHILE (i < n) & (num <= MaxPtrs) DO + INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i) + END + END + END + END + END FindPtrs; + + PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item); + VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct; + BEGIN + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr; + DevCPL486.MakeReg(y, DI, Int32); + IF par.typ.comp # DynArr THEN + DevCPL486.GenMove(x, y); + lbl := DevCPL486.NewLbl; + IF ODD(par.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zreg, y); + DevCPL486.GenJump(ccE, lbl, TRUE) + END; + size := par.typ.size; + IF size <= 16 THEN + x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0; + WHILE size > 0 DO + IF size = 1 THEN x.form := Int8; s := 1 + ELSIF size = 2 THEN x.form := Int16; s := 2 + ELSE x.form := Int32; s := 4 + END; + zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s) + END; + zreg.form := Int32 + ELSE + DevCPL486.GenBlockStore(1, size) + END; + DevCPL486.SetLabel(lbl) + ELSIF initializeDyn & ~par.typ.untagged THEN (* untagged open arrays not initialized !!! *) + DevCPL486.GenMove(x, y); + DevCPL486.MakeReg(len, CX, Int32); + INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *) + bt := par.typ.BaseTyp; + WHILE bt.comp = DynArr DO + INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp + END; + size := bt.size; + IF size MOD 4 = 0 THEN size := size DIV 4; s := 4 + ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2 + ELSE s := 1 + END; + DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE); + DevCPL486.GenBlockStore(s, 0) + END + END InitOutPar; + + PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); + VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER; + BEGIN + op := 0; par := proc.link; + WHILE par # NIL DO (* count out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END; + par := par.link + END; + DevCPL486.MakeConst(zero, 0, Int32); + IF (op = 0) & (size <= 8) THEN (* use PUSH 0 *) + WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END + ELSE + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); + IF size <= 32 THEN (* use PUSH reg *) + WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END + ELSE (* use string store *) + AdjustStack(-size); + DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + DevCPL486.GenBlockStore(1, size) + END; + IF op > 0 THEN + par := proc.link; + WHILE par # NIL DO (* init out parameters [with COM pointers] *) + IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END; + par := par.link + END + END + END + END AllocAndInitAll; + + PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER); (* needs AX *) + VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object; + BEGIN + IF ptrinit & (proc.scope # NIL) THEN + nofptrs := 0; obj := proc.scope.scope; (* local variables *) + WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO + FindPtrs(obj.typ, obj.adr, nofptrs); + obj := obj.link + END; + IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN + base := proc.conval.intval2; + Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END; + INC(i) + END; + IF a # base THEN INC(gaps) END; + IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN + DevCPL486.MakeConst(z, 0, Pointer); + IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END; + i := 0; a := size + base; + WHILE i < nofptrs DO + DEC(a, 4); + IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END; + DevCPL486.GenPush(z); INC(i) + END; + IF a # base THEN AdjustStack(base - a) END + ELSE + AdjustStack(-size); + DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z); + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END + ELSE + AdjustStack(-size) + END + ELSE + nofptrs := 0; + AdjustStack(-size) + END + END AllocAndInitPtrs1; + + PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER); (* needs AX, CX, DI *) + VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label; + BEGIN + IF ptrinit THEN + zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer); + IF nofptrs > MaxPtrs THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y); + DevCPL486.GenStrStore(size) + END; + obj := proc.link; (* parameters *) + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN + IF ~zeroed THEN + DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE + END; + x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr; + DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y); + IF ODD(obj.sysflag DIV nilBit) THEN + DevCPL486.GenComp(zero, y); + lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE) + END; + IF nofptrs > MaxPtrs THEN + DevCPL486.GenStrStore(obj.typ.size) + ELSE + Sort(ptrTab, nofptrs); + x.reg := DI; i := 0; + WHILE i < nofptrs DO + x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i) + END + END; + IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END + END + END; + obj := obj.link + END + END + END InitPtrs2; + + PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN; + VAR obj: DevCPT.Object; nofptrs: INTEGER; + BEGIN + IF ptrinit THEN + obj := proc.link; + WHILE obj # NIL DO + IF (obj.mode = VarPar) & (obj.vis = outPar) THEN + nofptrs := 0; + IF obj.typ.comp = DynArr THEN (* currently not initialized *) + ELSE FindPtrs(obj.typ, 0, nofptrs) + END; + IF nofptrs > 0 THEN RETURN TRUE END + END; + obj := obj.link + END + END; + RETURN FALSE + END NeedOutPtrInit; + + PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN); + VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER; + BEGIN + procedureUsesFpu := useFpu; + SetReg({AX, CX, DX, SI, DI}); + DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer); + IF proc # NIL THEN (* enter proc *) + DevCPL486.SetLabel(proc.adr); + IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + adr := proc.conval.intval2; size := -adr; + IF isGuarded IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); + r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL; + DevCPL486.GenPush(r1); + intHandler.used := TRUE; + r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler; + DevCPL486.GenPush(r1); + r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenPush(r1); + DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1); + DEC(size, 24) + ELSE + IF imVar IN proc.conval.setval THEN (* set down pointer *) + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4) + END; + IF isCallback IN proc.conval.setval THEN + DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8) + END + END; + ASSERT(size >= 0); + IF initializeAll THEN + AllocAndInitAll(proc, adr, size, np) + ELSE + AllocAndInitPtrs1(proc, adr, size, np); (* needs AX *) + InitPtrs2(proc, adr, size, np); (* needs AX, CX, DI *) + END; + par := proc.link; (* parameters *) + WHILE par # NIL DO + IF (par.mode = Var) & (par.typ.comp = DynArr) THEN + CopyDynArray(par.adr, par.typ) + END; + par := par.link + END; + IF imVar IN proc.conval.setval THEN + DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r) + END + END + ELSIF ~empty THEN (* enter module *) + DevCPL486.GenPush(fp); + DevCPL486.GenMove(sp, fp); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r); + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r) + END; + IF useFpu THEN InitFpu END + END Enter; + + PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN); + VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER; + BEGIN + DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer); + IF proc # NIL THEN (* exit proc *) + IF proc.sysflag # noframe THEN + IF ~empty OR NeedOutPtrInit(proc) THEN + IF isGuarded IN proc.conval.setval THEN (* remove exception frame *) + x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32; + DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r); + x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL; + DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x); + size := 12 + ELSE + size := 0; + IF imVar IN proc.conval.setval THEN INC(size, 4) END; + IF isCallback IN proc.conval.setval THEN INC(size, 8) END + END; + IF size > 0 THEN + x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32; + DevCPL486.GenLoadAdr(x, sp); + IF size > 4 THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r) + END; + IF size # 8 THEN + DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r) + END + ELSE + DevCPL486.GenMove(fp, sp) + END; + DevCPL486.GenPop(fp) + END; + IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0) + ELSE DevCPL486.GenReturn(proc.conval.intval - 8) + END + END + ELSE (* exit module *) + IF ~empty THEN + DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r); + DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r); + DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp) + END; + DevCPL486.GenReturn(0) + END + END Exit; + + PROCEDURE InstallStackAlloc*; + VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label; + BEGIN + IF stkAllocLbl # DevCPL486.NewLbl THEN + DevCPL486.SetLabel(stkAllocLbl); + DevCPL486.MakeReg(ax, AX, Int32); + DevCPL486.MakeReg(cx, CX, Int32); + DevCPL486.MakeReg(sp, SP, Int32); + DevCPL486.GenPush(ax); + DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE); + l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx); + DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax); + DevCPL486.GenSub(ax, sp, FALSE); + DevCPL486.GenMove(cx, ax); + DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax); + l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE); + l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1); + DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c); + DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE); + DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE); + DevCPL486.GenJump(ccNE, l1, TRUE); + DevCPL486.SetLabel(l2); + DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE); + x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1; + DevCPL486.GenMove(x, ax); + DevCPL486.GenPush(ax); + DevCPL486.GenMove(x, ax); + DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx); + DevCPL486.GenReturn(0); + name := "$StackAlloc"; DevCPE.OutRefName(name); + END + END InstallStackAlloc; + + PROCEDURE Trap* (n: INTEGER); + BEGIN + DevCPL486.GenAssert(ccNever, n) + END Trap; + + PROCEDURE Jump* (VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(ccAlways, L, FALSE) + END Jump; + + PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(x.offset, L, FALSE); + END JumpT; + + PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label); + BEGIN + DevCPL486.GenJump(Inverted(x.offset), L, FALSE); + END JumpF; + + PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label); + VAR c: DevCPL486.Item; n: INTEGER; + BEGIN + n := high - low + 1; + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE); + DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccAE, else, FALSE); + DevCPL486.GenCaseJump(x) + END CaseTableJump; + + PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN); + VAR c: DevCPL486.Item; + BEGIN + IF high = low THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END; + DevCPL486.GenJump(ccE, this, FALSE) + ELSIF first THEN + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccL, else, FALSE); + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccLE, this, FALSE); + ELSE + DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccG, else, FALSE); + DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x); + DevCPL486.GenJump(ccGE, this, FALSE); + END + END CaseJump; + +BEGIN + imLevel[0] := 0 +END Dev0CPC486. diff --git a/Trurl-based/Dev0/Mod/CPE.odc b/Trurl-based/Dev0/Mod/CPE.odc new file mode 100644 index 0000000000000000000000000000000000000000..3d1952b6aab2d4fc9a4d71aebc0c8c436c12007d GIT binary patch literal 40043 zcmeHw-EUk;b|0lx?4{STW7wMy8%S<6i=C!K_3%p^&d^$$qNouOiWEp{G-F`~X*Qc; zkNOMUO?`}K28;1a9`fJ>dGOjW{NTqt1d9NHAA%q+1_C61K#+$ZK!CuHSpfn35McBB z{m!Ynb#LFMG~-z(0U|)`y7h7D)Twh$ojP@H-Oby3{TclG@+Y_Z&9iQ+Hy+gw#>e5| zc5Bp}Ns5a3oBiIn(eAZ|qx$>p)-$WjRPy{k4#xdqi$L+C8tjh$ejfk-;*XU4y`+nK z{o_{0Kqc^#TqQ^KB*(kh>a@CQ`0|pV&djU={4COS>xRQTY&{z=QzlTK5aPnpwda^VR*9M4*AKD0@a4Uc^v9kGrkLae*aXe#@a9`0o$&i=g(oWgNr_@q#=z;`8SKPLll#{Kr3=*c{Hm_(jK9 zRx=(8Lhehp4gbE4#F0PPjC%cPGa4Fdk~AphEd2O)RPf%9F3kK1B$EaFe{trAOBZMU z-KT$(=@-htpa1gY!pwjFw$pv5-Fq^s^RKZ^p!yyv^4}f%xj^cJN}Ju|QGIXF>K*p` zo!jk3r~kP2=D~~6xYd1Ye>7~qwQltqMJ{+eMkbH#s2zwqy(M#-ni`v1r)eS@Ri3Ww4qHtJw$bVI zn^KDA>QH6nW=YJr#bw$3$eXY1)sKE^>(yc`uM$GlYBL7ntJUEcG9eyr@#r z>(cA7Dna}kjZ7`y!{bH4{bOWak~DC^zNFIM0Irv`ptIg3)q9F(D_vqKDKYaYOQqBP zB~!{*J5n;*#u^ zzmLC{#2Jf7T~Hn$e|m54_Jf_R>~`zv!sh+0^~<%ZS1(_@I1AbS1VTT1GrJP>?Ul>3 z{o&(Aul;Fb-0t^S^z7NQIt9Pqt2a+k-h`nmv#dWHv3yTuS-0IB_D5PWNAqP>fo4x( zkT}GP6D#XQ!5zF9wjZAgpXw?dTOio$#nPfd2*cJ%YuM^FTf*yPJb3r5xA3>#?w!_m}GT8-v!cJ{S=#DAdOW@gh5Ek49(t zz4s!b8q+H@bc^|TDM_&m{RXz3oy!RH~UANt4xn`0E>F>H-_2GY;iq9;=a;L>lySm zGMCr09j+5duC8Yvc=Bx&d-9$2Y}=EI3+vfoNH4Eno;4IkpZ9P;z+*$yM|+%QZ+(K#S?s6_l*4 zX9uk@5{@b(B4fUq!F1Pbq+wU5zgiPUg%aIx%ZBiS!Z48Hv7i_(r-G0%- z6VgCyzlBAXP*-xG>7*Kg?{ut6W+MR2xP>5KjTGpBJHP}m@Uy4wQTwRfX^&rI{gcdK z`8Noi2vJ9) zM%Q^_a0DdVCv8{`>SgdWc}7>mR=59Dg_xsu4@zZ(uCV1sbxoD^-w0d4?4;9p3^`y% zy>UE*(Ioz?#~Sn5025yaq^FHeebgG`XHIg`Ydzz}1CTlGjiXU`!mM}N-SC8YZ*>RZ z3H%2_`P0%uK4;z5xB-ko(UV5A1g1}vqQw+N6QidUS@3dQ* zY7MsQB81uL1{q?@$ggY+26c&IGKdt@xlDCaq0&Q;s%{i3wlGeIRCPCcFTk0^nVsY5 zzEO(ZLr?pY1VQMJC4+1k8Cnfz>k4uiwhXXu+_ox z`qZA$L9;&~H5M0u=eThM(dGjX)kCW%`CkCnj83^tU|}L7Pe9yO#|1HcCa(r zIqD=3i8HohJ9IzfP58J2_2#6Yo@$Lo{b2#QqxR#i-f_FpdpEnax3{ykvCHbL3;nT; zk|EarLRtIx`PzJjzuXz(XBnG2{H(6bXFbfqbNuvA$O`k>DP-;dqbu|%Z3PJWB@879 zMG3+ojbW~UIP=*(C_en{AJ1!vwN5y!`3xpX(^8O}$Hx`4!c1fC=efif8z}i8!bl#oF+&%`u zjyg~9Tj++3_nzJc^dq6Ap>S2-7;jT)_15 z?EU?{&8^!H_P4V4TH~F5@9{&J5TmPEt=R{gcpFXDdbaoAFgtC}XPy4Di2oc1EVDA( zg$S)Iy|ePp>f1~2tk$80falW3SUSv>+}O{Ca77G3nfob^8v>esD9pxA8&E1#d39mMzv7vctPuyWSFYuG3O7$oP9L zV@F#%2L|9bvwPdSdHZ5ZKucO)x0buNInvWM@scK}ZS5XzZ|&EHr*k4g(iQU1{b?Ik zbdGf=`_0U8G${Cc4vrlTa@WQb>z{)e$E7w?2_qt-4hEEM*>EtEljG^k&0+smJy^0u zJxs~9WXk3+LFwc>P0F*FHW7(Hp|lxk%#mb2C{D0V5TOmxENyY_P%skm9!6VWZ}d{) zd>S?6{OOFJi>ziF>OX^a6(^LrIVWjCt-1B=xeBy_tG~ao6W9+Tk>eN;At9#V_*JEo zD_yn$;j~3K^_Q}&q?7T3U_bEDGI|MmB+t5I-uoWg9d$J`eQEDmjUzrt-}ZV zyBX?Xyf5am?`Jh6-^j9s`dqfRpVb!YU{n?=@d6AY?lABrzQ8i#Udn2=;I0)&e0aEp z4Kk>RZA(;{zJ@Cwn~9>nWaVb8YT7lY{`T(Xj^xaC81vd4o1WbO8QCkQ5d863*uTDu zhgtMa`U)C08cjYR&$lb2=j_9~+i=p<0G=3ajVZV^(*CYx%Ye82ezrml zF=tE?N4&T?F=TGM{+}2#5%odSA}Wn~(MF9mGadCd_fr!?UWL8>jSjhbmR;;s7*qh~ znjAH&{%yYb?CZ+Jl&4dRsm~v=TaMho@i=8@8Ls8CPPMSSG(iCFy8h|}_`-xgUD}}U z!YcQ5*qV6xKxpeG?8|}t%x3bNAIS6>;a>M=G#>?tpicVc^-gJm7FPqSIscY57Wq{w zt*BEI{Yr&~TDHI~;XFgzH_swA zX7q2~-G@QJ;-wp_!FuqnO6CJ{59m!f4+GFU?#i_|lF$xLcndjp1+TLWsMg?i2SbAC z!VL|*7==Aa&G2_&MT+RF$&OY4Q^b)beN1h@7iL@a1%{XT+v8Pf_+a|LbC$>z;Y4iuZ(@I zmg8E53J|Q!UaHPst{83F#WmQc6-1f>t-9|C>QwO6d##?cRkaSogu>qhmlFL2xfYAc zgcB~86Wk9hcApiuYg8PwyIT)y=CFdCiXW}|M_Qxg$ueWcvQf#qgGyW=grI_G^L@b{ z;L0*P-#3U*_qCR{O^_O^2D|{GW{Clj8^mWSktfx(!@_dFeTwPmn3r--o{4imLm+9Csuq-12?(-X zKE5`3QInNXhzf8Lv!v?l4<~7qt59h9(#Rt|rQugdz{4TVM9DgsHM-q1xFA27&z`_N z9JR%Ic2xAY27RYJF_`L!F&7}%CioMG0~pPAF+CRI>3a4F&Rm=gkN7Krc=8c@CV%(f zmm(&9E+LWLgEz{FF0H_Z}0%#e`j^*gPn z)Q9G8rRCY{kF$8bEc1AFlirkwygVv!FdWj#c0i;FPo$#fg0-1R)(9sO>oLV#)No$~ zVevFJLgTLBW_Eqilp`xz{d!LzEC-KMn|C$6Nedl7#rix} zA?tpImc4n4$C$TZjd=^-&>l|qv^&QmL7<~Cfnl9+ih$Jhcy!4!S@p-qqJg3dBave@ zv_X7{(VRjQi1_s>8<(6eNACRjUgroWM~|*+0O9}>TXxyStQ`#-2s4o9%Vxk$7)~w- zz=04`=aTGX*zaaIMRCNPMD8|s7KkIE__}jVbD8_s_*mzxBIM)^O_tnbfr(VygZnJ3 zg+NwiIn#0exJWY_nn5ibAo&NNJ(DHA^VF&Atf~sQGa55cJEBeMF%Mn1)^eIyCi1d9 zp}vDkrOhdrqqTSRN%g*TQfWwWqvOevps7(ve8^$8{UlM1T@n!_HN2+JJ5Eo5M-8Mw ze!bIboDhr-pq0}#ZGb$Z3TsvEPpvWqjLpBoR+M-;-2mI{45vGz~{J9u~rrcpW;DJJX&UJL(P%(p@n^8g{vluTkfd z4B?P5JzA#5rjG6i8jGAe3WWc|TJtnt^d8{! zY=@OGFCQ4u9Jfh~m*CHj1cK88qI$&GFzmuw4B*PTXE=dSgz;$5M=-;zmYS8pw!^|@n#RYH)S06nAlkuG0HM-U0MURnKw-ZGdN3rb zG<_@ohlvp_w^t3wElXSRQ>OjK=(_{Ic+LDE3C$2EQX&~*04!{Cx`i}P#gp(DCUm-0 zl-od5l++iwnxu&WR~Xc$q$ud~eBA-$S_2r346WCG>6&B3DFGf=;x?!)9kui9}&t5`~3sscGT>D0s##W;XCl)$CxO22gC$ONh&wMHtx3 zsisPL5aAwnpQy#w%Jb=_NoP|B(ra!@9Bf;qv;%YB=S(!K%_#U_{ahvyy5ua>1S7P~ zzE#^rD|72K>_$aI@FF&x;x^&H*fh*doC#)@xY3WbOro69f#QMiLB#|(K%hb&lht55 zzRC&-OLng59@ZA_Y<^H&OLxz@bnzfU$*dclM*v9~unG%fcU8**V=17pOIB&Fx%_xP zSNI@uUl4sa8ssi87BGNf9ciQ5X`SGRhO{OFC`(5jHyKW!@00U9gqOk@>D$~882tv~ zB^AjWODMdIs(6D(F$uHC@Wp5-KVr4W7qt^8gV+>C_r?*j zz@;e2jDnVv!IGu~pHt7czQ`%JKY%7@@JTWI4zq&}36Rif(1?fiM(+jU8kr?6mNw5V zKM!U$`;V$eO2-FXfb|-HAp5TZ1eN?6NF6Aqx&(`_RCuiSc>}U46>Y^6=h8woN-ZZy z;qIDq0r6=0Rd5(W{EE4;2<#FdlA&xrn0y9StyuQX#TLW1IQ`gDkqt_w#uP>>&6ze6 z1)g18pw2VxVzzAU(01TKlIG^K1*mHe1P>Bvt6}6#C<1zsy7H!_qFS4fRfYh)QtnfM zESUIT6JL{{6F5yl*R}Hqe*zO1rz&A7D$95-q$hc$vc$V~G23L?QlZzj3!*#^l~HiIiF0kE8!83WiZ{AZY+eTpK2~f z1<=|T9heplcAhOgJ84MbX;Z>6t5H&zY!T&`4;VUlf274VXqMZ`8o-#Zdq}r+ZDUr8 z{-{LgNK%>zC34^2fnAx&`xdPPW+~d9=4|Bz7y)ULnt|YibH6w9<3^8DQ#FLNQe_2W zO;zJ|v*osiIt5`=K<{5^uo}>WEwnRzlWN zchd4hfWZ+$ts-6b!ix`~I|ZUrgpArcl7YXLarZhT_Ok9 zIyZyi^qlI81GGG_Ws~pnl%0t3R#Sg~cS6rsod5>R#wPw=tf;td}R$03+YvDQ*VVkyF3 ziY=Gk2`DbdzLsP6%Y^IfPd=Z}IXIJo+m_2@Ndt%xEo^-Sf@pE;E5(;!vJJkfXhmzq zA`GKSyQn+7*pWuQGa+E~Lc1E@>BZ^Q)QEvM4!FCbY#SJ7lZn4jKZ z`6}9qDuc?3zZA>~T~(!oz-e&H=>=x&?v6qjci4)i_L!X$94TTON;ig7O5$gAP*9V@ z(2ZAv3udnb9FEBMx8(76X~7Fb55^~Jwa^R5)dqh+RW89vo0-F(q4#zUQ_-u1`BwL- zka3g6qZpfu*;*mF?5%jcRI!1`VYryU15#yHqqw~pUb0N(>om~_R+3ATD9t{Q>u#?YmbZ=Xm`V^-U!JSMrg1$1_79cV;CW=rA{$ahR%&=(OwzJa!>cpC*-!x=y@cXRMV+vrnTJO=qnJ&>YPYNsv< zL&rT3m@K-WIA;nu0Z4Odg^&|nc`>i+F6M(qpZD7+@XL!RLOx!6Nyvz}4!+iJo;xgC z>NbMs{+OM9roD8%4zFLSiWi&H$IJXifV?GMS1`a`NtG8cvITgl2z$|zO9D7lxFbFb zt``NJ(9k5VQynfwM0D!@6^_N_o9%*6(VPTU+1)6i<`xluUF>M87`f;li6|D2i{KNf z^`kQsDA=C)tMx-)h43{CI&^IP>o5MWhKU_yD%~}3C&6IJD!VD}MX6}yTTgR>Wa{)n zi!i2u77KS+*xtA#GFm^bj-dt)7J{2Z)KxQNLaVX0Yc{h|0!VB$02SLPoS5*ap_e#G z^vs4h=HlkV*Dy5=Mi2qp#xJDU9jXumkVx88gK=z_;rSkr(KF4q3rL_@iISvnxEla& z5=K)w3HCg8ZrB=&$vxZWLoY&?T`wXxxsQCIniDEbd`Kt~J)quP0N2R2FJ1earp zEKoB<<`vc=Qt7k_DC6!3!qIFR^~2F(BswB$S!H0xrPD|J$4J8n2>q1-kj`L$K?v`| zu?26y&~{8yZ+B;~nmO(Ub=(*OMzI@Tl6tyUW3pb~F4#ya0xxvoHMg?R3;R{3&$`g} zS*^jD86vT}#z!c&xvCB9Fp=RvR+P{J06~qo_C;POu?g?EGlr;?xnxp7D>?miCcy(2 z-H;Rm?sOdz&Q-oI=Um{tk?2X^!!riDW|-7Q7v39ejVxx4g9()dp7No$ZES30e%o`n zZ9)|t2bN=B8WzBYQ4wFfW;(!L0tZ8MCgo~_Iy!Q75CC);^9+cHON|2t$Q$SUt_iaq zR8`Mulmtf+n8z=35nC`1+{?vBSG;g+vIX)6@NuaKH+S#`fY1U4wQhkqr$w0tdTGV zjf#AgV2lEE4dd59EnUP?;Db2bB{m2*IA%2lw8mMrnU1rH1NK<7=gKh&)yQzCgDbur zFsFO#VxF^2&JCaxd$U8to8jUr&R#ADxY-GZ`-vQ=#Yk_a$u0j%^*QURk>LU4ApxN9 zaB4%mCd*zYcA{{>4b1??9FWy;-tMgFwm^BQ^WIsXowILO!WIWaE$nsvdN3pgT3l=< zYsM`)J|dEe2w*}Sg@jDLi1VvrF2qOS)Yi?!YDviF`h1-isbbf_gp*-^VzgsG4x-W+ z@wzY>B^fR%P3|pi3=!PhYj)0X=c%dIz=lOrQd|>697T_V#lK~1Z753kF+m}~RIt(; z@v1m!Chfb_tP~McbMLZ_WSDkgvMo+UuI*&3z-Z0oCLZb2f{h3JpWFP+;wT6{BEN*n zxt7;gmBIVACvWw|QEqG(4+W3HJnKj?KR=q)T_bxjb~v6@9&uYB$XcL^%hYYCgpzi` zSq?PhX;vHd``EpdjjJ@;tXvAN;CckrI$08|FluZBnv_M0(F$xEWFQ5=>Y|1pGOIj$^@EGujdN`X$4}*HE9i=9|fJ^UdS5q zlPO0zj)J*Y5ewik;3QbGRj$*+Eyt(uOGCukI40%Ms17yg#2E*y)ZB3)RA!A*D!NLuMPzv2(Sm1z=_b5pbX+*yJ zlyjnJlwd|DLkUb^gY{LUU_!A%2h{M0iwxJlLGNztez?E2nc<4V)4pqAfh=v+0njFN zKD)kxT@h~q0gECYOtG8A}i!FG3n;Y3HwsKh*97zc(<<5h9 zyp=4aism+G`@k;?B0n6 z;eyFRgQasC1nwv_SoQ{6l4JH6-oVUdAY90ZFizryD@w3+7d}9muUwVvW9Uh3%!1^Y z~uJB?s!X97jQqHS!t9 z&Yy3%)W#LAEN@@KN&&?IT2=Xh#*v3pzDc{6FjsV)uzyw4>B6$Ogc+$47SlvDP1|Al zRaPP~Wx|xVrAADa1e}tSBxAb0 zF)T=?>x9bn8i(eMF;0&Lc?C4?{i}c#-e(sVzqSJ59FiR=CAc$_mpUrR{2Q%pF`vcH{PEl-?i9?rXDxdd$;_NZcP;qHCe}PT! z>o^I_!p`k%pmAGfcIr|_CYCqmXSHAjLUa!_lRcPj2oA&L$K#=Xu@lxWmUa9_XOEbH z7B}7!3n3`Fod!lAZz``JwqXNi^dsnzf7iA82CEQgtRN&znuE+>OS5tr3gWkMLg=}E zsg6jKC;pZCr{wMrQ1Fsdij{(LzYJ zpJDT@ir$#7u%Sm59wTCz+^NTL{S<+Dp%CjryNCOD^XCyR=k5^$;ie}1L`SH==nBh3 zD!^nIhBDKH6^c+SEG0OaP9OJq7lsnaie=OgfR+lE%hK+xSc5j@6bzLTUK9D@al;53 zxVqcm1!oj{0){TH!q46a#_LeT4eW*IbmolVVkx*REoE50W=M)N&<>`WDFGHK8Ogc= zU%5Ef+ToJ`;l^DcvmZ~YY;@`3YTeL(7JA8RgKH40Hc|VSSNcxYHW{6$4ZM70Ab#oA zUC|$OE83j&o>X+pw$vXvVx=Ng=(*mqIjp2f?rx~0L*9In3d)f${k&5g)tdgA zPL*?*!=KHMWC)>Pj+c;{3=7XIfJ~(|{Cr~Ad2r$}1AtdCib0%0pX!mTa(U=``x-bt zEfM)k@7T+=#w^%*zFESSh(t+WHIg~yuPr1##)4_Nhm9KBk$HlTEobDabGV$JX|fL> zUpU?jx1cA5vu^(q&7RB>^Bh@E@N?NIxQh9ro+t7R0q}uf@9ET}rh_3nybI@T0Dvfu z?H%R%0CdSg-9h8W$j3$233)C=q96f`P`$lHIQSNWwZ!9kA1xVi0vjYLB5R9nyqUxb zbx;6sV&zHb*hp7HM?nNo9~_;ePfwF4qm0HNJ0qEqD5Qv7LL3ZL#pi*B$v9BTTjV+9 zKz6LpMe;z~u!}@HCG0;biGXh9lY+Rp1M3wpP@}u(0o~L56SY?fowb&v6y6{t@^QFR zIhvZ*LiAam{0h^ZNiakne}PI#H}D;$RWg2oN@b zrnUbnL#F&(Gl*dgrYQOl)TxHoYaeW>;z!0ud+Pc75;?=;ShH z8$Uo@3~;Uy_Dip34(mM9Ym!pZs}eVb-@&!O$p=CO&4_Ph93#Ho)Pi1bmy(@0L{hYZ zy;vWv1O+%~XKOiIGfc$piIi#hXt?h7*h`aa2D{21I-q7v(;#d{GO_F5R2hQihKj zX-EaSZQR1P3w9`)@MQ#hU06f3SnKMS;?H;%)I z$W^R;$*5Djv<^-~tjrY&sWfqu3uK~=D%TJzpIjgxjO-pt>Lj|1U;v@B3Eh}@l5)*x zhbi`X6SlWqS~v%@Qv?8`Xm|ZBFk)}jSYX>BKW<1DnVjQNN~Gj7W;0@x#3-%ivv2i0 zVvR;735u^E6|W&n6_yIa>!KdsQ>o2@ky6x@dqJ2|{9l9VZE0|#5lPv(L_hSCvXkCK z)-3Q^wd7SdyRAYuPQ+sc!{o3IFVB16SDY#ktal}-hjqWX4Yx(H%;^*^Y)j6`L8%Fb zE2>YR7WH>L>##B4FU39Qyma%l+3$34S>kO3zEVL#g1KR*gyYd_Z)20d;K(~bjUV0Q^9Gs#k{4&uC>M2=wO2o`P0Tv+R)`8R7 z_?2v@#f$>fKeo)k#Jms>`S?+cmkMpJYbl15dsomZ zz>7q|9>F8c3p(kWCVj5j5)@oBP9v2$i1C4n_4sB086)Sccq=5-9yu7x!Gsgbz1z7& z1#k7ZKR7^4O)E^aVgrCmjEOfvo7e)=&zno1u4BgO#(~ZYTYfwky!)6*9T#$-N)SsX zFnRpc^O`b|SX>RM<)x5XT~P|mCu2<;YdGH|g~o5}>^^l$_3&$y*Hqrzlw?c^!sr zg2kWTZH8P6Z=UdH7Gh6eQ;-}4$riMBgTdn28q*{$E^)wla^LYfSXj&oNHnc`aF>N0 zYTqxyD?$;fb|;*a^U^$=rUsLkw8oJM!=T|TX<<4>%^_;wE9=I+5+IHheo=C;q0U$X z8B>9ZCOb=>8AG=UcP6^jlmEb{Z)imzahPovD2q%zMt7?ux z0f1W7^p|3c`ci&V8o0YV*5cKmycdDSNV)8K>>U0fd{#}AF7~L!1i++aU)iPAs_xRt z)TQCCJ_&zfn9ICK0-Z{szp_)SRo$tTsZ;A;of1Aeg;?y}=66-RBYi>6_CuzfNHdxv zp+@*R*CfWPD>->fJO%|9+G83(X4aK5yJuDqdEG=SWepMDma-`nz(fIpB*nEEE;9%V zYhcR!9l;QjldMVex#|sX5<(4_u;dLL+xs+twZz!bvLwrw=jj--mFiDhOKkE>fhiEM z#uy<~*l%ThT*z#Gkao}BkkHAtx(5lYB^r!S370q99qf3nR$H!#O@pBC3XKb(MfEd9 zt)dT_Ha2NZq^7N|$=4V{hq$N87?$BQ3HvdqO=dq-9V`3~_czJj2yJN%5ds~n&x zSEPRzTDp_VPnwSy!H|z}0zenBms*qp>FnfZlc!y4R+T~1rj3fzPc@X(UR+J8n=qeS ze|agXAM`-rxFG)t{MD7Deh}eueG!1MAy!vlFv?>{Q$EVVbepnwnaUBSG*`2Mp%hl0 z{Adg!M^t^uZMYs zFU}+lHFCck`P#M}1^LLui6*D5YkA&7ZRiX9R4$xg5=}w5RuKBaJe4akC=K&a&i0rz zlz`^c*0>cbOFmeiAJN>a>!V03OOeQE;oy3Gejo4q+&t{T^h_J=w;sbhY7Lp6?$S5| z#XZ_~ug&kyao+RIlASf;Tjs*vKH5!bx|uEGS|n_a@cnLF0n_PN`UcJ{hs^=@7dJC} zv(&CEL3$Ad17mzX;kxzcSz>?ks8D?PKr-cbogmYp;Ghu)T!4c*sSL51gZ3%_07~ow zJCqTz&=k3T(JTra>7_L%|3ZD>|e z554nxMF4Ud<(*(5KsH=A_6aIJaDrf+J|3Tfj`lS!tAf$dO7jLt;>sl}K^k99kLlGF zPa9t$Uw(E+iDf)6yqf*)LcP9t?v2L!4Vpi0mG3P#b z)AUu$%Gail1^Ap1ZA`-0xn31B+#MY&nBO^p5!4Q9@P&dQ9V9H)Hiln+(c45&y85-V zbrg#+59^q~T_91r@(1fvo^)Xrwk zyhCPI_o!{38bX&$He_Z+!(&GJQ_Gi|FlVAZ84UHsXN4{-XQDoI6RP8H5xO!aDpPHt zwzO9PxaCaLr%oeun%#x^6X0QTP~$9Y-ruTU{_-b>c$ol%LR=6|42C0oBII~;JnV3z zH8W9|SG00IH?X%uyQ-o9vsCu-(v1E4HUFLUU;nxA<;!38WCOoHkN+Rq^Y6X<6))h= zxAFhC{Q1k5zv`**^F1amgs1FJe@Dspesp2xPx@963cq}LIaKrCUk}f!a&_jv{u8VF z`=N=-fAKG8X83>pj~>l@=Pze|`^%r)?l;f6*zQh{z~Gc+8oWS{l=fp W{P2JMg8u)-$?43W{k=b!nfc#hk#a=< literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev0/Mod/CPE.txt b/Trurl-based/Dev0/Mod/CPE.txt new file mode 100644 index 0000000..798b19e --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPE.txt @@ -0,0 +1,1120 @@ +MODULE Dev0CPE; + + (* THIS IS TEXT COPY OF CPE.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems, Robert Campbell" + version = "System/Rsrc/About" + copyright = "System/Rsrc/About" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT SYSTEM, (* Dates, *) DevCPM := Dev0CPM, DevCPT := Dev0CPT; + + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* object modes *) + Fld = 4; Typ = 5; Head = 12; + + (* module visibility of objects *) + internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4; + + (* history of imported objects *) + inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5; + + (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*) + newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20; + + (* meta interface consts *) + mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; + mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6; + mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13; + mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3; + mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4; + mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13; + mInterface = 32; mGuid = 33; mResult = 34; + + (* sysflag *) + untagged = 1; noAlign = 3; union = 7; interface = 10; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* kernel flags *) + iptrs = 30; + + expAllFields = TRUE; + + (* implementation restrictions *) + CodeBlocks = 512; + CodeLength = 16384; + MaxNameTab = 800000H; + + useAllRef = FALSE; + outSignatures = TRUE; + + TYPE + CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR; + + VAR + pc*: INTEGER; + dsize*: INTEGER; (* global data size *) + KNewRec*, KNewArr*: DevCPT.Object; + closeLbl*: INTEGER; + CaseLinks*: DevCPT.LinkList; + + processor: INTEGER; + bigEndian: BOOLEAN; + procVarIndirect: BOOLEAN; + idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER; + Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object; + outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN; + codePos, srcPos: INTEGER; + options: SET; + code: ARRAY CodeBlocks OF CodeBlock; + actual: CodeBlock; + actIdx, blkIdx: INTEGER; + CodeOvF: BOOLEAN; + zero: ARRAY 16 OF SHORTCHAR; (* all 0X *) + imports: INTEGER; + dllList, dllLast: DevCPT.Object; + + + PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + CONST N = 4294967296.0; (* 2^32 *) + VAR rh, rl: REAL; + BEGIN + rl := con.intval; rh := con.realval / N; + IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N + ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N + END; + hi := SHORT(ENTIER(rh)); + rl := rl + (rh - hi) * N; + IF rl < 0 THEN hi := hi - 1; rl := rl + N + ELSIF rl >= N THEN hi := hi + 1; rl := rl - N + END; + IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END; + low := SHORT(ENTIER(rl)) +(* + hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0)); + r := con.realval + con.intval - hi * 4294967296.0; + IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END; + low := SHORT(ENTIER(r)) +*) + END GetLongWords; + + PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER); + VAR r: SHORTREAL; + BEGIN + r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r) + END GetRealWord; + + PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER); + TYPE A = ARRAY 2 OF INTEGER; + VAR a: A; + BEGIN + a := SYSTEM.VAL(A, con.realval); + IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END + END GetRealWords; + + PROCEDURE IsSame (x, y: REAL): BOOLEAN; + BEGIN + RETURN (x = y) & ((x # 0.) OR (1. / x = 1. / y)) + END IsSame; + + PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER); + VAR c: DevCPT.Const; + BEGIN + INCL(con.setval, form); + CASE form OF + | String8: + obj := Const8; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END + | String16: + obj := Const16; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END + | Int64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO + c := c.link + END; + IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END + | Real32: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 4) END + | Real64: + obj := Const64; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END; + IF c = NIL THEN adr := idx64; INC(idx64, 8) END + | Guid: + obj := Const32; c := obj.conval; + WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END; + IF c = NIL THEN adr := idx32; INC(idx32, 16) END + END; + IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END; + con.intval := adr + END AllocConst; + + + PROCEDURE AllocTypDesc* (typ: DevCPT.Struct); (* typ.comp = Record *) + VAR obj: DevCPT.Object; name: DevCPT.Name; + BEGIN + IF typ.strobj = NIL THEN + name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null; (* avoid err 1 *) + obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END + END AllocTypDesc; + + + PROCEDURE PutByte* (a, x: INTEGER); + BEGIN + code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256)) + END PutByte; + + PROCEDURE PutShort* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 256); PutByte(a + 1, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256) + END + END PutShort; + + PROCEDURE PutWord* (a, x: INTEGER); + BEGIN + IF bigEndian THEN + PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H); + PutByte(a + 2, x DIV 256); PutByte(a + 3, x) + ELSE + PutByte(a, x); PutByte(a + 1, x DIV 256); + PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H) + END + END PutWord; + + PROCEDURE ThisByte* (a: INTEGER): INTEGER; + BEGIN + RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength]) + END ThisByte; + + PROCEDURE ThisShort* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ThisByte(a) * 256 + ThisByte(a+1) + ELSE + RETURN ThisByte(a+1) * 256 + ThisByte(a) + END + END ThisShort; + + PROCEDURE ThisWord* (a: INTEGER): INTEGER; + BEGIN + IF bigEndian THEN + RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3) + ELSE + RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a) + END + END ThisWord; + + PROCEDURE GenByte* (x: INTEGER); + BEGIN + IF actIdx >= CodeLength THEN + IF blkIdx < CodeBlocks THEN + NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0 + ELSE + IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END; + actIdx := 0; pc := 0 + END + END; + actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc) + END GenByte; + + PROCEDURE GenShort* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256) + END + END GenShort; + + PROCEDURE GenWord* (x: INTEGER); + BEGIN + IF bigEndian THEN + GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x) + ELSE + GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H) + END + END GenWord; + + PROCEDURE WriteCode; + VAR i, j, k, n: INTEGER; b: CodeBlock; + BEGIN + j := 0; k := 0; + WHILE j < pc DO + n := pc - j; i := 0; b := code[k]; + IF n > CodeLength THEN n := CodeLength END; + WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END; + INC(j, n); INC(k) + END + END WriteCode; + + + PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList; + VAR link: DevCPT.LinkList; m: DevCPT.Object; + BEGIN + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ)); + ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp)); + IF obj.mnolev >= 0 THEN (* not imported *) + CASE obj.mode OF + | Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END + | TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END + | Var: offs := offs + dsize; obj := Data + | Con, IProc, XProc, LProc: + END + ELSIF obj.mode = Typ THEN + IF obj.typ.untagged THEN (* add desc for imported untagged types *) + IF obj.links = NIL THEN obj.link := descList; descList := obj END + ELSE + m := DevCPT.GlbMod[-obj.mnolev]; + IF m.library # NIL THEN RETURN NIL END (* type import from dll *) + END + END; + link := obj.links; + WHILE (link # NIL) & (link.offset # offs) DO link := link.next END; + IF link = NIL THEN + NEW(link); link.offset := offs; link.linkadr := 0; + link.next := obj.links; obj.links := link + END; + RETURN link + END OffsetLink; + + + PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + obj := typ.strobj; + IF obj = NIL THEN + obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0; + obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj + END; + RETURN obj + END TypeObj; + + + PROCEDURE Align (n: INTEGER); + VAR p: INTEGER; + BEGIN + p := DevCPM.ObjLen(); + DevCPM.ObjWBytes(zero, (-p) MOD n) + END Align; + + PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR); + VAR ch: SHORTCHAR; i: SHORTINT; + BEGIN i := 0; + REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X + END OutName; + + PROCEDURE Out2 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256))) + END + END Out2; + + PROCEDURE Out4 (x: INTEGER); (* byte ordering must correspond to target machine *) + BEGIN + IF bigEndian THEN + DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H))); + DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x))) + ELSE + DevCPM.ObjWLInt(x) + END + END Out4; + + PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER); + VAR link: DevCPT.LinkList; + BEGIN + link := OffsetLink(obj, offs); + IF link # NIL THEN + Out4(typ * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := -(DevCPM.ObjLen() - headSize - 4) + ELSE Out4(0) + END + END OutReference; + + PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER); + VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER; + BEGIN + IF typ.form = Pointer THEN + IF ip & (typ.sysflag = interface) + OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END + ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN + btyp := typ.BaseTyp; + IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ; + fld := typ.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface) + OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num) + ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num) + END; + fld := fld.link + END + ELSIF typ.comp = Array THEN + btyp := typ.BaseTyp; n := typ.n; + WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ; + IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN + i := num; FindPtrs(btyp, adr, ip, num); + IF num # i THEN i := 1; + WHILE i < n DO + INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i) + END + END + END + END + END FindPtrs; + + + PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR); + BEGIN + DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name) + END OutRefName; + + PROCEDURE OutRefs* (obj: DevCPT.Object); + VAR f: BYTE; + BEGIN + IF outRef & (obj # NIL) THEN + OutRefs(obj.left); + IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN + f := obj.typ.form; + IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64}) + OR outURef & (obj.typ.comp # DynArr) + OR outAllRef & ~obj.typ.untagged + OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN + IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END; + IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr))) + ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec))) + ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16))) + ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64))) + ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid))) + ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult))) + ELSIF f = Pointer THEN + IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface))) + ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr))) + ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + END + ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN + DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute) + ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1))) + ELSE DevCPM.ObjW(SHORT(CHR(f))) + END; + IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END; + OutName(obj.name^) + END + END ; + OutRefs(obj.right) + END + END OutRefs; + + PROCEDURE OutSourceRef* (pos: INTEGER); + BEGIN + IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN + WHILE pc > codePos + 250 DO + DevCPM.ObjW(SHORT(CHR(250))); + INC(codePos, 250); + DevCPM.ObjWNum(0) + END; + DevCPM.ObjW(SHORT(CHR(pc - codePos))); + codePos := pc; + DevCPM.ObjWNum(pos - srcPos); + srcPos := pos + END + END OutSourceRef; + + + PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER); + BEGIN + WHILE link # NIL DO + ASSERT(link.linkadr # 0); + DevCPM.ObjWNum(link.linkadr); + DevCPM.ObjWNum(adr + link.offset); + link := link.next + END + END OutPLink; + + PROCEDURE OutLink (link: DevCPT.LinkList); + BEGIN + OutPLink(link, 0); DevCPM.ObjW(0X) + END OutLink; + + PROCEDURE OutNames; + VAR a, b, c: DevCPT.Object; + BEGIN + a := nameList; b := NIL; + WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END; + DevCPM.ObjW(0X); (* names[0] = 0X *) + WHILE b # NIL DO + OutName(b.name^); + b := b.nlink + END; + END OutNames; + + PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR); + + PROCEDURE Copy (n: INTEGER); + VAR x, y: INTEGER; + BEGIN + x := ORD(str[n]); y := ORD(str[n + 1]); + IF x >= ORD("a") THEN DEC(x, ORD("a") - 10) + ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10) + ELSE DEC(x, ORD("0")) + END; + IF y >= ORD("a") THEN DEC(y, ORD("a") - 10) + ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10) + ELSE DEC(y, ORD("0")) + END; + DevCPM.ObjW(SHORT(CHR(x * 16 + y))) + END Copy; + + BEGIN + IF bigEndian THEN + Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17) + ELSE + Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15) + END; + Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35) + END OutGuid; + + PROCEDURE OutConst (obj: DevCPT.Object); + TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR; + VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER; + BEGIN + a := obj.conval; b := NIL; + WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END; + WHILE b # NIL DO + IF String8 IN b.setval THEN + DevCPM.ObjWBytes(b.ext^, b.intval2); + Align(4) + ELSIF String16 IN b.setval THEN + i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0; + Align(4) + ELSIF Real32 IN b.setval THEN + r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r); + IF DevCPM.LEHost = bigEndian THEN + ch := a4[0]; a4[0] := a4[3]; a4[3] := ch; + ch := a4[1]; a4[1] := a4[2]; a4[2] := ch + END; + DevCPM.ObjWBytes(a4, 4) + ELSIF Real64 IN b.setval THEN + a8 := SYSTEM.VAL(A8, b.realval); + IF DevCPM.LEHost = bigEndian THEN + ch := a8[0]; a8[0] := a8[7]; a8[7] := ch; + ch := a8[1]; a8[1] := a8[6]; a8[6] := ch; + ch := a8[2]; a8[2] := a8[5]; a8[5] := ch; + ch := a8[3]; a8[3] := a8[4]; a8[4] := ch + END; + DevCPM.ObjWBytes(a8, 8) + ELSIF Int64 IN b.setval THEN + (* intval moved to intval2 by AllocConst *) + x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x; + IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END + ELSIF Guid IN b.setval THEN + OutGuid(b.ext^) + END; + b := b.link + END + END OutConst; + + PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN); + BEGIN + IF typ = NIL THEN Out4(0) + ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr) + ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec) + ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr) + ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid) + ELSIF typ = DevCPT.restyp THEN Out4(mResult) + ELSE + CASE typ.form OF + | Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0) + | Bool, Char8: Out4(typ.form - 1) + | Int8..Set: Out4(typ.form) + | Char16: Out4(mChar16) + | Int64: Out4(mInt64) + | ProcTyp: OutReference(TypeObj(typ), 0, absolute) + | Pointer: + IF typ.sysflag = interface THEN Out4(mInterface) + ELSIF typ.untagged THEN Out4(mSysPtr) + ELSE OutReference(TypeObj(typ), 0, absolute) + END + | Comp: + IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute) + ELSE Out4(0) + END + END + END + END OutStruct; + + PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER; + VAR n: INTEGER; + BEGIN + n := 0; + IF obj.name # DevCPT.null THEN + IF obj.num = 0 THEN + obj.num := namex; + WHILE obj.name[n] # 0X DO INC(n) END; + INC(namex, n + 1); + obj.nlink := nameList; nameList := obj + END; + n := obj.num; + END; + RETURN n + END NameIdx; + + PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER); + VAR p: DevCPT.Object; n, m: INTEGER; + BEGIN + pos := DevCPM.ObjLen() - headSize; + OutStruct(retTyp, TRUE); + p := par; n := 0; + WHILE p # NIL DO INC(n); p := p.link END; + Out4(n); p := par; + WHILE p # NIL DO + IF p.mode # VarPar THEN m := mValue + ELSIF p.vis = inPar THEN m := mInPar + ELSIF p.vis = outPar THEN m := mOutPar + ELSE m := mVarPar + END; + Out4(NameIdx(p) * 256 + m); + OutStruct(p.typ, TRUE); + p := p.link + END + END OutSignature; + + PROCEDURE PrepObject (obj: DevCPT.Object); + BEGIN + IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN (* write param list *) + OutSignature(obj.link, obj.typ, obj.conval.intval) + END + END PrepObject; + + PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object); + VAR vis: INTEGER; + BEGIN + Out4(fprint); + Out4(offs); + IF obj.vis = internal THEN vis := mInternal + ELSIF obj.vis = externalR THEN vis := mReadonly + ELSIF obj.vis = external THEN vis := mExported + END; + Out4(mode + vis * 16 + NameIdx(obj) * 256); + IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute) (* ref to par list *) + ELSE OutStruct(typ, mode = mField) + END + END OutObject; + + PROCEDURE PrepDesc (desc: DevCPT.Struct); + VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct; + BEGIN + IF desc.comp = Record THEN (* write field list *) + desc.strobj.adr := DevCPM.ObjLen() - headSize; + n := 0; fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN INC(n) END; + fld := fld.link + END; + Out4(n); fld := desc.link; + WHILE (fld # NIL) & (fld.mode = Fld) DO + IF expAllFields OR (fld.vis # internal) THEN + OutObject(mField, 0, fld.adr, fld.typ, fld) + END; + fld := fld.link + END + ELSIF (desc.form = ProcTyp) & outSignatures THEN (* write param list *) + OutSignature(desc.link, desc.BaseTyp, desc.n) + END; + (* assert name and base type are included *) + IF desc.untagged THEN n := NameIdx(untgd) + ELSE n := NameIdx(desc.strobj) + END; + IF desc.form # ProcTyp THEN b := desc.BaseTyp; + IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp, ProcTyp}) + & (b.sysflag # interface) & (b # DevCPT.guidtyp) + & (~b.untagged OR outURef & (b.form = Comp)) THEN + l := OffsetLink(TypeObj(b), 0) + END + END + END PrepDesc; + + PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object; + VAR obj: DevCPT.Object; + BEGIN + IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END; + obj := NumMeth(root.left, num); + IF obj = NIL THEN obj := NumMeth(root.right, num) END; + RETURN obj + END NumMeth; + + PROCEDURE OutDesc (desc: DevCPT.Struct); + VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE; + name: DevCPT.Name; + BEGIN + ASSERT(~desc.untagged); + IF desc.comp = Record THEN + xb := desc; flddir := desc.strobj.adr; + REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged; + Out4(-1); i := desc.n; + WHILE i > 0 DO DEC(i); t := desc; + REPEAT + m := NumMeth(t.link, i); t := t.BaseTyp + UNTIL (m # NIL) OR (t = xb); + IF m # NIL THEN + IF absAttr IN m.conval.setval THEN Out4(0) + ELSE OutReference(m, 0, absolute) + END + ELSIF (xb = NIL) OR xb.untagged THEN Out4(0) (* unimplemented ANYREC method *) + ELSE OutReference(xb.strobj, -4 - 4 * i, copy) + END + END; + desc.strobj.adr := DevCPM.ObjLen() - headSize; (* desc adr *) + Out4(desc.size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + IF desc.attribute = extAttr THEN attr := 1 + ELSIF desc.attribute = limAttr THEN attr := 2 + ELSIF desc.attribute = absAttr THEN attr := 3 + ELSE attr := 0 + END; + Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0; + WHILE i <= desc.extlev DO + t := desc; + WHILE t.extlev > i DO t := t.BaseTyp END; + IF t.sysflag = interface THEN Out4(0) + ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute) + ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute) + ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute) + ELSE OutReference(xb.strobj, 12 + 4 * i, copy) + END; + INC(i) + END; + WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END; + OutReference(Meta, flddir, absolute); (* ref to field list *) + nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr); + Out4(-(4 * nofptr + 4)); + nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr); + Out4(-1) + ELSE + desc.strobj.adr := DevCPM.ObjLen() - headSize; + lev := 0; size := 0; + IF desc.comp = Array THEN + size := desc.n; form := mArray + ELSIF desc.comp = DynArr THEN + form := mArray; lev := SHORT(SHORT(desc.n + 1)) + ELSIF desc.form = Pointer THEN + form := mPointer + ELSE ASSERT(desc.form = ProcTyp); + DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp; + END; + Out4(size); + OutReference(Mod, 0, absolute); + IF desc.untagged THEN m := untgd ELSE m := desc.strobj END; + Out4(form + lev * 16 + NameIdx(m) * 256); + IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE) + ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute) (* ref to par list *) + END + END + END OutDesc; + + PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER); + VAR i: INTEGER; (* t: Dates.Time; d: Dates.Date; *) + BEGIN + Out4(0); (* link *) + Out4(ORD(options)); (* opts *) + Out4(0); (* refcnt *) + (* Dates.GetDate(d); Dates.GetTime(t); (* compile time *) + Out2(d.year); Out2(d.month); Out2(d.day); + Out2(t.hour); Out2(t.minute); Out2(t.second); *) + Out2(2007); Out2(5); Out2(25); + Out2(0); Out2(0); Out2(0); + Out4(0); Out4(0); Out4(0); (* load time *) + Out4(0); (* ext *) + IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute); (* terminator *) + ELSE Out4(0) + END; + Out4(imports); (* nofimps *) + Out4(nofptr); (* nofptrs *) + Out4(pc); (* csize *) + Out4(dsize); (* dsize *) + Out4(refSize); (* rsize *) + OutReference(Code, 0, absolute); (* code *) + OutReference(Data, 0, absolute); (* data *) + OutReference(Meta, 0, absolute); (* refs *) + IF procVarIndirect THEN + OutReference(Proc, 0, absolute); (* procBase *) + ELSE + OutReference(Code, 0, absolute); (* procBase *) + END; + OutReference(Data, 0, absolute); (* varBase *) + OutReference(Meta, namePos, absolute); (* names *) + OutReference(Meta, ptrPos, absolute); (* ptrs *) + OutReference(Meta, impPos, absolute); (* imports *) + OutReference(Meta, expPos, absolute); (* export *) + i := 0; (* name *) + WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END; + DevCPM.ObjW(0X); + Align(4) + END OutModDesc; + + PROCEDURE OutProcTable (obj: DevCPT.Object); (* 68000 *) + BEGIN + IF obj # NIL THEN + OutProcTable(obj.left); + IF obj.mode IN {XProc, IProc} THEN + Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0); + END; + OutProcTable(obj.right); + END; + END OutProcTable; + + PROCEDURE PrepExport (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + PrepExport(obj.left); + IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN + PrepObject(obj) + END; + PrepExport(obj.right) + END + END PrepExport; + + PROCEDURE OutExport (obj: DevCPT.Object); + VAR num: INTEGER; + BEGIN + IF obj # NIL THEN + OutExport(obj.left); + IF (obj.history # removed) & ((obj.vis # internal) OR + (obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN + DevCPT.FPrintObj(obj); + IF obj.mode IN {LProc, XProc, IProc} THEN + IF procVarIndirect THEN + ASSERT(obj.nlink = NIL); + num := obj.num; obj.num := 0; + OutObject(mProc, obj.fprint, num, NIL, obj); + obj.num := num + ELSE + OutObject(mProc, obj.fprint, obj.adr, NIL, obj) + END + ELSIF obj.mode = Var THEN + OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj) + ELSIF obj.mode = Typ THEN + OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj) + ELSE ASSERT(obj.mode IN {Con, CProc}); + OutObject(mConst, obj.fprint, 0, NIL, obj) + END + END; + OutExport(obj.right) + END + END OutExport; + + PROCEDURE OutCLinks (obj: DevCPT.Object); + BEGIN + IF obj # NIL THEN + OutCLinks(obj.left); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END; + OutCLinks(obj.right) + END + END OutCLinks; + + PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER); + BEGIN + IF obj # NIL THEN + OutCPLinks(obj.left, base); + IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END; + OutCPLinks(obj.right, base) + END + END OutCPLinks; + + PROCEDURE OutImport (obj: DevCPT.Object); + VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER; + BEGIN + IF obj # NIL THEN + OutImport(obj.left); + IF obj.mode = Typ THEN typ := obj.typ; + IF obj.used OR + (typ.form IN {Pointer, Comp}) & (typ.strobj = obj) & + ((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN + DevCPT.FPrintStr(typ); + DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^); + IF obj.used THEN opt := 2 ELSE opt := 0 END; + IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN + DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1))); + IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END + ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt))) + END; + OutLink(obj.links) + END + ELSIF obj.used THEN + DevCPT.FPrintObj(obj); + IF obj.mode = Var THEN + DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSIF obj.mode IN {XProc, IProc} THEN + DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^); + DevCPM.ObjWNum(obj.fprint); OutLink(obj.links) + ELSE ASSERT(obj.mode IN {Con, CProc}); + DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint) + END + END; + OutImport(obj.right) + END + END OutImport; + + PROCEDURE OutUseBlock; + VAR m, obj: DevCPT.Object; i: INTEGER; + BEGIN + m := dllList; + WHILE m # NIL DO + obj := m.nlink; + WHILE obj # NIL DO + IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar))) + ELSE DevCPM.ObjW(SHORT(CHR(mProc))) + END; + IF obj.entry # NIL THEN OutName(obj.entry^) + ELSE OutName(obj.name^); + END; + DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links); + obj := obj.nlink + END; + DevCPM.ObjW(0X); m := m.link + END; + i := 1; + WHILE i < DevCPT.nofGmod DO + obj := DevCPT.GlbMod[i]; + IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END; + INC(i) + END; + END OutUseBlock; + + PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String); + VAR name: DevCPT.String; dll: DevCPT.Object; + BEGIN + IF obj # NIL THEN + CollectDll(obj.left, mod); + IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN + IF obj.library # NIL THEN name := obj.library + ELSE name := mod + END; + dll := dllList; + WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END; + IF dll = NIL THEN + NEW(dll); dll.library := name; INC(imports); + IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END; + dllLast := dll; dll.left := dll; + END; + dll.left.nlink := obj; dll.left := obj + END; + CollectDll(obj.right, mod) + END + END CollectDll; + + PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER); + BEGIN + IF obj # NIL THEN + EnumXProc(obj.left, num); + IF obj.mode IN {XProc, IProc} THEN + obj.num := num; INC(num, 8); + END; + EnumXProc(obj.right, num) + END; + END EnumXProc; + + PROCEDURE OutHeader*; + VAR i: INTEGER; m: DevCPT.Object; + BEGIN + DevCPM.ObjWLInt(processor); (* processor type *) + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); + DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); (* sizes *) + imports := 0; i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library # NIL THEN (* dll import *) + CollectDll(m.right, m.library); + ELSE INC(imports) (* module import *) + END; + INC(i) + END; + DevCPM.ObjWNum(imports); (* num of import *) + OutName(DevCPT.SelfName); + m := dllList; + WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END; + i := 1; + WHILE i < DevCPT.nofGmod DO + m := DevCPT.GlbMod[i]; + IF m.library = NIL THEN OutName(m.name^) END; + INC(i) + END; + Align(16); headSize := DevCPM.ObjLen(); + IF procVarIndirect THEN + i := 0; EnumXProc(DevCPT.topScope.right, i) + END + END OutHeader; + + PROCEDURE OutCode*; + VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos, + con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER; + m, obj, dlist: DevCPT.Object; + BEGIN + (* Ref *) + DevCPM.ObjW(0X); (* end mark *) + refSize := DevCPM.ObjLen() - headSize; + (* Export *) + Align(4); + IF outSignatures THEN PrepExport(DevCPT.topScope.right) END; (* procedure signatures *) + Align(8); expPos := DevCPM.ObjLen(); + Out4(0); + OutExport(DevCPT.topScope.right); (* export objects *) + i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i); + (* Pointers *) + ptrPos := DevCPM.ObjLen(); + obj := DevCPT.topScope.scope; nofptrs := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END; + obj := DevCPT.topScope.scope; i := 0; + WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END; + IF i > 0 THEN Out4(-1); INCL(options, iptrs) END; + (* Prepare Type Descriptors *) + dlist := NIL; + WHILE descList # NIL DO + obj := descList; descList := descList.link; + PrepDesc(obj.typ); + obj.link := dlist; dlist := obj + END; + (* Import List *) + impPos := DevCPM.ObjLen(); i := 0; + WHILE i < imports DO Out4(0); INC(i) END; + (* Names *) + namePos := DevCPM.ObjLen(); OutNames; + (* Const *) + Align(4); con8Pos := DevCPM.ObjLen(); + OutConst(Const8); con16Pos := DevCPM.ObjLen(); + ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8); + OutConst(Const16); con32Pos := DevCPM.ObjLen(); + ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16); + OutConst(Const32); con64Pos := DevCPM.ObjLen(); + ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32); + IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END; + OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64); + (* Module Descriptor *) + Align(16); modPos := DevCPM.ObjLen(); + OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize); + (* Procedure Table *) + procPos := DevCPM.ObjLen(); + OutProcTable(DevCPT.topScope.right); + Out4(0); Out4(0); (* at least one entry in ProcTable *) + Out4(0); (* sentinel *) + (* Type Descriptors *) + obj := dlist; + WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END; + (* Code *) + codePos := DevCPM.ObjLen(); WriteCode; + WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END; + (* Fixups *) + OutLink(KNewRec.links); OutLink(KNewArr.links); + (* metalink *) + OutPLink(Const8.links, con8Pos - headSize); + OutPLink(Const16.links, con16Pos - headSize); + OutPLink(Const32.links, con32Pos - headSize); + OutPLink(Const64.links, con64Pos - headSize); + OutLink(Meta.links); + (* desclink *) + obj := dlist; i := modPos - headSize; + WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END; + IF procVarIndirect THEN + OutPLink(Proc.links, procPos - modPos); + OutCPLinks(DevCPT.topScope.right, procPos - modPos) + END; + OutLink(Mod.links); + (* codelink *) + IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END; + OutPLink(CaseLinks, 0); OutLink(Code.links); + (* datalink *) + OutLink(Data.links); + (* Use *) + OutUseBlock; + (* Header Fixups *) + DevCPM.ObjSet(8); + DevCPM.ObjWLInt(headSize); + DevCPM.ObjWLInt(modPos - headSize); + DevCPM.ObjWLInt(codePos - modPos); + DevCPM.ObjWLInt(pc); + DevCPM.ObjWLInt(dsize); + IF namex > MaxNameTab THEN DevCPM.err(242) END; + IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END + END OutCode; + + PROCEDURE Init* (proc: INTEGER; opt: SET); + CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14; + BEGIN + processor := proc; + bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt; + outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt; + outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options); + outSrc := srcpos IN opt; + pc := 0; actIdx := CodeLength; blkIdx := 0; + idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1; + options := opt * {0..15}; CodeOvF := FALSE; + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + codePos := 0; srcPos := 0; + NEW(untgd); untgd.name := DevCPT.NewName("!"); + closeLbl := 0 + END Init; + + PROCEDURE Close*; + BEGIN + KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL; + Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL; + Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL; + Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL; + nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL; + WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END; + actual := NIL; untgd := NIL; + END Close; + +BEGIN + NEW(KNewRec); KNewRec.mnolev := -128; + NEW(KNewArr); KNewArr.mnolev := -128; + NEW(Const8); Const8.mode := Con; Const8.mnolev := 0; + NEW(Const16); Const16.mode := Con; Const16.mnolev := 0; + NEW(Const32); Const32.mode := Con; Const32.mnolev := 0; + NEW(Const64); Const64.mode := Con; Const64.mnolev := 0; + NEW(Code); Code.mode := Con; Code.mnolev := 0; + NEW(Data); Data.mode := Con; Data.mnolev := 0; + NEW(Mod); Mod.mode := Con; Mod.mnolev := 0; + NEW(Proc); Proc.mode := Con; Proc.mnolev := 0; + NEW(Meta); Meta.mode := Con; Mod.mnolev := 0; +END Dev0CPE. diff --git a/Trurl-based/Dev0/Mod/CPH.odc b/Trurl-based/Dev0/Mod/CPH.odc new file mode 100644 index 0000000000000000000000000000000000000000..4dcb3836956215d62a4e8af4900da3e72e62858c GIT binary patch literal 12920 zcmc&*OK&7s74C6Dh)K*t5I{siB`0Lsj;B3-%p|cj5I=e{mh5ih?wKecBFf#>-8EBP z)v2oXBQq04$p#@7u;U@YB1=};AQlMNL_#e20SF0!SQ1M}Ss;b)JNMpt^uu;uqNVnI zpYxq_&pG$ht@g%dH7MZo#=DzAqu+J>I4afRrfFNN>t}HxxP^cCP z8z4W4`l@0>G3(AztRO0AD5-$O`)MtfJg=isSLq8c}SKO3Z3~v z;d7{eAEo*{K(Y#xUbYs;p}XIYohUEKMZMx{x-48^Wwvnd_fjeRSPGK6@W#oMo;0UR zv*>+k4=xgAeF{Sp>B^;nm05P=q}Xw#QqpYyvD!~2APV$x!?Bw=lQ?-mQ>*Fnn^I!s zQ-xK0TWJ2^Hzf2_p{e_Nx^EUGWlWihpb6LdpB~Z*-0OSf3II}57Q_wF18Hx9=N%BI z%6^S6K5AoAI<@%NQzk1ro(!1Y6RtI%hf&$r4Yi|s{y0RI2tIza9kMrfYjayLhp79K}v|elH3e^K1J-KVDzIIA>jysP5ut$KDPin{n&#)1_%gP<#0Jr8B}j{I@-3-xA85DP&y#GN8BI88f+4@a^%vv> z5RdyZ`+kn^gb@BSD5=^X*!MU`x3QTIp3eX{{dXdx`1W5A4jz=+JK(Ljb};<@PIdF< zcG=o=4lZx(-dLR~&dyFvOicE|;I`9;^uE4i67Y!M+m) zeyP#Hcmqj^9HBuNal9&HR@ZHWK_uZV!mIeja~IuHPy-apzS)p6~Vd=cAw%AKIZauh8n^*7Cg2tnMzB zcI}=MmU_hA=-7T+QJf$XH;Vdcb7E?Cc4lg7a%*R|x>u)CH+JjR$~CRt`s&o=)Z|9B zQmao*P8Mgan~}3&dtPJ(J*qUauzGUR3;gy@(3`ccS(jHWwl-C3LA8*Y9dK|_HLJ}g zTT37gnQc!meRkDiOD}y+wan6m%be}{@lGG-k5F4!U{@;$8xE)~TwS#~Zd0ny2yEi@ zksn4@!?U9ZrGTv**r5W-T2C6lS!ubB*Hj=YNJ*TQK(s2Z-*k>pU&fqv-wrwF3hIt& zTqTSOEGddH^bCgL;~sH9pbE^gfhwe_^m}oDDkQNg-Jr)R`8HJ*x~VjvT6T+Oz}Ssr za$6v4mv|P)xM4?*7a5tQ*%ZQLjhx(}cnf3>sol2E)^mc&QGzSv4j!zMc|+)25#CUEakka>8#F@8?|0$0vbl-G zVBkB4EfIdza{Y#?f@agv^<_$d5l;<4wa$@gK%z#_J60nQgZ2}~(p*~Py0)WQ)Jw0g z>mY&tP^M8S7|;!91>wXXf-AJpD0VAMpA(8V6buV_|JFlQhyYwPq0Un;} z!*;Y|u_y3ot3ItaE`h+VtN;&%X#p&{(H#zgiRYx&2L~Zm+Md17MYOzzG8C{0nnX>L z^8@brk~o3gBy%dcK{r|i!+m9g;OHqWfMY02Xm3y*=ZRd9nuM^pYtw_5uo|wZv@Tv7 zcibq{_OQ%RwCzys*|N-tI%1*#9d*PisT*Ad>LXDnOcgPd@g|DHegkgdScpqqy>&Mc zLFm08vVI(kU0Os{@a!Q%N()l6esvim zkh><1f-qCVdFHoCMFNfM)sK@<6X?2F@NR%;s$vB=?;=j=QE=Z-PK*78Si~n-7-AK9 z)dU1!69m|7%)Dhr~ zCe>AI^Vmm=B&dW&ATb$ci3RxX?o~I+n>Y8$Jgw^3QJz><(O=QWTd9IW0njU!Z+D#) zYi)0D?Io*v-KyQd8Mtv{ZEr?|S=*ymA^Ggiv0|s|v5X$Ke|yftpQOLK&kO`k8TcT( zUafAI*D4^jUVdS#0&H8?fuaNpEYUasUv1!wRo&x&=d|KcqxBo*iugB<qLIO#1QD&g`TzDXdWMaWpa&#kfm7@NB!($JO-AAfq zbdhx%tjanRvoV~5u-3%rl{0}t(t{v?7%1Rw!H00@B|~a*xMJ;<*S0}B;~7So)TN|S zv@Gtm2AxF>*S!m~T3Vb_0qFjW^^{cv2AGLfl#9F`u7bW9We=g!EKecZD{+iR#nVuh z?!pT6P))QQMweu0?CiuKv8@A?v1cK-B1fGVE+Ljl6kr4R*wVWP6DRweRVH3;J;B*b zwzu&f&|V_m@Sl1~Voz1E%DOzYsAyXu7h*Ib<_&3h0LIoTiN9(tx!# zl?87oI~}lI{qS-<2<3bmFyiqBo7(AENudUerQoFoyy#0L(85p??AMr6dtF*Y7e_P4 zRuMDjtZCw%&bYf#5J{yB1~x$X5qCjN(Wc0?=}c%Uii?`GKpnPN31zu4;}9T~85}E- z4k|o{wenBd8DxnAJA>q~7e^~rtz1twsWoS{S8#^c%P*AoB&|z=jEX2arlQUiRZUx6w)&^J#3P%6|)YZp`Ks=L{|?0 z^t^kJBq~Wv!RY}#XOopQ+~b1jjF@6V#l~8VcB4+E>UB`OryibHxQTG@B7L6pbWD)U zLj+YxeHs`;<%6&5yC?w5;9_bF- zG>lrPtPJe{ZdcU?-&40t!!vOCYGwe!spEK*8y?>Yu*ZaT&*J^m@PsuQftn!KR>L!D z{e3e7mrlduYf;CHgTnCmj_W7m_R)xO`^b#rmaJ65y_ZZ%VokSK^aY}}zw~SvG(+q^ z%y3*(I&g-~5J%QvCUa)`lcqY7+@!{!(;LuK*$&hSi*DgjqMaly#>BH{nMAc>KBUv6 zbLWw0AT{+->y3HK4TnDdt}f4H!d-HlsRNfjD+zF->%7B{*YpnVQ^$M!nz{);J+U;0 z05oEbfNQ+@Nfq{2z73Tt;Ca&K85&j zq}!wMs%%c4qL>?yy9i+0xz?e4Jgwo==z>dUZP>TWdr;*Bl5!t)haYqQE-Poun2 z?wr-?Wk8B$_&QnVT?&TT!X)0MfWnAVKwyp*BAOkBe{QTgq^c)yNfQvx_(&_~l@Wyx z+DhYcUP;oN*bhQTdX8~*^PHsEKk(krbEN|``perBwU|h8D zS*0is85Y3vJ~C-Bgj8|j0eSVSw^`?6glAag9>Y*0rx^^<7@;w~?wZ4%<8>GczGFin zZy?#rw~r|01>+F4j74en%R4{JSFiV^fKXONvG8CH&r zdMfZD1e_lJ44YFFpz)b-s7@tD8r(ag_~_yB92kZ-L50h4%KYTQC+u6y!#qeT@6Y7h zLxDp)SY1lKR+Qh;Y=zEK+pOjOwCYM*b-#&OpcCca^62$-L98 zhcmAoIuo(@LHZ3{0^%^%HEkMjQs7`C<4*9P0lp;P1k- zgK1rU9s4fZw))S8QA392z*zEs2j-{E{F!LxgP-P`pLp8n{#btEX}vZ22jgUW_OCSm z_9OLMQS~Ej1NG7O@Do~m=YH|s!Xxh$p3nYs$e_qyHH&m9zwcySWbZVh!n2RRRe1fs RpONpsTAjjgzy8xg;eTT8ee?hT literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev0/Mod/CPH.txt b/Trurl-based/Dev0/Mod/CPH.txt new file mode 100644 index 0000000..3d57237 --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPH.txt @@ -0,0 +1,304 @@ +MODULE Dev0CPH; + + (* THIS IS TEXT COPY OF CPH.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT DevCPT := Dev0CPT; + + CONST + (* UseCalls options *) + longMop* = 0; longDop* = 1; longConv* = 2; longOdd* = 3; + realMop* = 8; realDop* = 9; realConv* = 10; + intMulDiv* = 11; + force = 16; hide = 17; + + (* nodes classes *) + Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6; + Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13; + Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19; + Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25; + Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30; + Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55; + + (*function number*) + assign = 0; newfn = 1; incfn = 13; decfn = 14; + inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32; + getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31; + + (* symbol values and ops *) + times = 1; slash = 2; div = 3; mod = 4; + and = 5; plus = 6; minus = 7; or = 8; eql = 9; + neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14; + in = 15; is = 16; ash = 17; msk = 18; len = 19; + conv = 20; abs = 21; cap = 22; odd = 23; not = 33; + adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29; + min = 34; max = 35; typfn = 36; + thisrecfn = 45; thisarrfn = 46; + shl = 50; shr = 51; lshr = 52; xor = 53; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; + VString16to8 = 29; VString8 = 30; VString16 = 31; + realSet = {Real32, Real64}; + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + + + PROCEDURE UseThisCall (n: DevCPT.Node; IN name: ARRAY OF SHORTCHAR); + VAR mod, nm, moda: DevCPT.Name; mobj, obj: DevCPT.Object; done: BOOLEAN; + BEGIN + IF (n.typ.form = Real64) OR (n.left.typ.form = Real64) THEN mod := "Real" + ELSIF (n.typ.form = Real32) OR (n.left.typ.form = Real32) THEN mod := "SReal" + ELSIF (n.typ.form = Int64) OR (n.left.typ.form = Int64) THEN mod := "Long" + ELSE mod := "Int" + END; + moda := mod + "%"; + DevCPT.Find(moda, mobj); + IF mobj = NIL THEN + DevCPT.Import(moda, mod, done); + IF done THEN DevCPT.Find(moda, mobj) END + END; + nm := name$; DevCPT.FindImport(nm, mobj, obj); + n.class := Ncall; n.subcl := 0; n.obj := obj.link; + n.left.link := n.right; n.right := n.left; + n.left := DevCPT.NewNode(Nproc); + n.left.obj := obj; n.left.typ := obj.typ; + ASSERT(n.typ.form = obj.typ.form) + END UseThisCall; + + PROCEDURE Convert (n: DevCPT.Node; typ: DevCPT.Struct); + VAR new: DevCPT.Node; r: REAL; + BEGIN + IF n.class = Nconst THEN + ASSERT((n.typ.form IN {Int32, Int64}) & (typ = DevCPT.intrealtyp)); + r := n.conval.realval + n.conval.intval; + IF r = n.conval.realval + n.conval.intval THEN + n.conval.realval := r; n.conval.intval := -1; n.typ := typ; n.obj := NIL + END + END; + IF (n.typ # typ) + & ((n.class # Nmop) OR (n.subcl # conv) + OR ~DevCPT.Includes(n.typ.form, n.left.typ.form) & ~DevCPT.Includes(n.typ.form, typ.form)) THEN + new := DevCPT.NewNode(0); new^ := n^; + n.class := Nmop; n.subcl := conv; n.left := new; n.right := NIL; n.obj := NIL + END; + n.typ := typ + END Convert; + + PROCEDURE UseCallForComp (n: DevCPT.Node); + VAR new: DevCPT.Node; + BEGIN + new := DevCPT.NewNode(0); + new.left := n.left; new.right := n.right; + new.typ := DevCPT.int32typ; + UseThisCall(new, "Comp"); + n.left := new; + n.right := DevCPT.NewNode(Nconst); n.right.conval := DevCPT.NewConst(); + n.right.conval.intval := 0; n.right.conval.realval := 0; n.right.typ := DevCPT.int32typ; + END UseCallForComp; + + PROCEDURE UseCallForConv (n: DevCPT.Node; opts: SET); + VAR f, g: INTEGER; typ: DevCPT.Struct; + BEGIN + typ := n.typ; f := typ.form; g := n.left.typ.form; + IF realConv IN opts THEN + IF f IN realSet THEN + IF g = Real32 THEN UseThisCall(n, "Long") + ELSIF g = Real64 THEN UseThisCall(n, "Short") + ELSIF g = Int64 THEN UseThisCall(n, "LFloat") + ELSIF g = Int32 THEN UseThisCall(n, "Float") + ELSE Convert(n.left, DevCPT.int32typ); UseThisCall(n, "Float") + END + ELSIF g IN realSet THEN + IF f = Int64 THEN UseThisCall(n, "LFloor") + ELSIF f = Int32 THEN UseThisCall(n, "Floor") + ELSE n.typ := DevCPT.int32typ; UseThisCall(n, "Floor"); Convert(n, typ) + END + END + END; + IF longConv IN opts THEN + IF f = Int64 THEN + IF g = Int32 THEN UseThisCall(n, "Long") + ELSIF ~(g IN realSet) THEN Convert(n.left, DevCPT.int32typ); UseThisCall(n, "IntToLong") + END + ELSIF g = Int64 THEN + IF f = Int32 THEN UseThisCall(n, "Short") + ELSIF ~(f IN realSet) THEN n.typ := DevCPT.int32typ; UseThisCall(n, "LongToInt"); Convert(n, typ) + END + END + END + END UseCallForConv; + + PROCEDURE UseCallForMop (n: DevCPT.Node; opts: SET); + BEGIN + CASE n.subcl OF + | minus: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Neg") + END + | abs: + IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN + UseThisCall(n, "Abs") + END + | odd: + IF (longOdd IN opts) & (n.left.typ.form = Int64) THEN UseThisCall(n, "Odd") END + | conv: + UseCallForConv(n, opts) + ELSE + END + END UseCallForMop; + + PROCEDURE UseCallForDop (n: DevCPT.Node; opts: SET); + BEGIN + IF (realDop IN opts) & (n.left.typ.form IN realSet) + OR (longDop IN opts) & (n.left.typ.form = Int64) + OR (intMulDiv IN opts) & (n.subcl IN {times, div, mod}) & (n.typ.form = Int32) THEN + CASE n.subcl OF + | times: UseThisCall(n, "Mul") + | slash: UseThisCall(n, "Div") + | div: UseThisCall(n, "Div") + | mod: UseThisCall(n, "Mod") + | plus: UseThisCall(n, "Add") + | minus: UseThisCall(n, "Sub") + | ash: UseThisCall(n, "Ash") + | min: UseThisCall(n, "Min") + | max: UseThisCall(n, "Max") + | eql..geq: UseCallForComp(n) + ELSE + END + END + END UseCallForDop; + + PROCEDURE UseCallForMove (n: DevCPT.Node; typ: DevCPT.Struct; opts: SET); + VAR f, g: INTEGER; + BEGIN + f := n.typ.form; g := typ.form; + IF f # g THEN + IF (realConv IN opts) & ((f IN realSet) OR (g IN realSet)) + OR (longConv IN opts) & ((f = Int64) OR (g = Int64)) THEN + Convert(n, typ); + UseCallForConv(n, opts) + END + END + END UseCallForMove; + + PROCEDURE UseCallForAssign (n: DevCPT.Node; opts: SET); + BEGIN + IF n.subcl = assign THEN UseCallForMove(n.right, n.left.typ, opts) END + END UseCallForAssign; + + PROCEDURE UseCallForReturn (n: DevCPT.Node; opts: SET); + BEGIN + IF (n.left # NIL) & (n.obj # NIL) THEN UseCallForMove(n.left, n.obj.typ, opts) END + END UseCallForReturn; + + PROCEDURE UseCallForParam (n: DevCPT.Node; fp: DevCPT.Object; opts: SET); + BEGIN + WHILE n # NIL DO + UseCallForMove(n, fp.typ, opts); + n := n.link; fp := fp.link + END + END UseCallForParam; + + PROCEDURE UseCalls* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + UseCalls(n.left, opts); UseCallForMop(n, opts) + | Ndop: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForDop(n, opts) + | Ncase: + UseCalls(n.left, opts); UseCalls(n.right.left, opts); UseCalls(n.right.right, opts) + | Nassign: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForAssign(n, opts) + | Ncall: + UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForParam(n.right, n.obj, opts) + | Nreturn: + UseCalls(n.left, opts); UseCallForReturn(n, opts) + | Ncasedo: + UseCalls(n.right, opts) + | Ngoto, Ndrop, Nloop, Nfield, Nderef, Nguard: + UseCalls(n.left, opts) + | Nenter, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseCalls(n.left, opts); UseCalls(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END UseCalls; + + + PROCEDURE UseReals* (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Nmop: + IF (longMop IN opts) & (n.typ.form = Int64) & ((n.subcl = abs) OR (n.subcl = minus)) THEN + UseReals(n.left, opts - {hide} + {force}); n.typ := DevCPT.intrealtyp + ELSIF n.subcl = conv THEN UseReals(n.left, opts - {force} + {hide}) + ELSE UseReals(n.left, opts - {force, hide}) + END + | Ndop: + IF (longDop IN opts) & (n.left.typ.form = Int64) THEN + UseReals(n.left, opts - {hide} + {force}); UseReals(n.right, opts - {hide} + {force}); + IF n.typ.form = Int64 THEN n.typ := DevCPT.intrealtyp END + ELSE UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + END + | Ncase: + UseReals(n.left, opts - {force, hide}); UseReals(n.right.left, opts - {force, hide}); + UseReals(n.right.right, opts - {force, hide}) + | Ncasedo: + UseReals(n.right, opts - {force, hide}) + | Ngoto, Ndrop, Nloop, Nreturn, Nfield, Nderef, Nguard: + UseReals(n.left, opts - {force, hide}) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex: + UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide}) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + IF force IN opts THEN Convert(n, DevCPT.intrealtyp) + ELSIF ~(hide IN opts) & (n.typ = DevCPT.intrealtyp) THEN Convert(n, DevCPT.int64typ) + END; + n := n.link + END + END UseReals; + +END Dev0CPH. + + + + + PROCEDURE Traverse (n: DevCPT.Node; opts: SET); + BEGIN + WHILE n # NIL DO + CASE n.class OF + | Ncase: + Traverse(n.left, opts); Traverse(n.right.left, opts); Traverse(n.right.right, opts) + | Ncasedo: + Traverse(n.right, opts) + | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard: + Traverse(n.left, opts) + | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex: + Traverse(n.left, opts); Traverse(n.right, opts) + | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar: + END; + n := n.link + END + END Traverse; + diff --git a/Trurl-based/Dev0/Mod/CPL486.odc b/Trurl-based/Dev0/Mod/CPL486.odc new file mode 100644 index 0000000000000000000000000000000000000000..b96a99c8d324498938e51cc5d8f8b74b53a24f68 GIT binary patch literal 37044 zcmd^o&2J=0b|1U7BW>ABOM)awumK~zE$@(=BD?s}Y<6>cWU^SCZktWgBxj~ai!o5F zN;Ye{SVdPAo9yvwy_mfihCkNuL0Un;>S(|xU3@YGUkv!_e?Sl*Kxb_q3?B@vf4}!$ zeB?*5$yv_MN-BWN%*cor?>pX$jEt;r?DQw_`~1fn{npt@+8Yh$_D5}Zv5^j26Va_~ zdA;8oH9Ng@Fr53alb&m3o<-MxwLj_)QUb+6YOp*0ehGi`KakV!M_oMax6`hIir`13 zayp!gO00`UH$9PtufHZxCno;&f1H@8;QSm%`F;N5gY;sgD1yv@btv{_uWwr;9*FEe zQYhaS7={IaM2HYd0lnA1XmI}c-%m{ZGS2@1NByM)t2kM+wb5wMIXoMs!z?9lTZ_MM z$BA1!nVI;`pUTO^59B~_w?2P8X_cyWbd7!@*ZD@mtgqwN?a*>D*D~&oJ!yArsZ5$V z`;GnobQ`3AACJ>!JEIb>f5D*b+wna)qUEaKiSI4kp7Ir2zl_ z?8U8#zx=xKeXG-ZF`VOnRUOCme~ya$J=Vjme}W^pR6l7C=XOrh-a)_L-RLyC{pV9} z@4p(3(v!P;!$Irr+F}1}w7&j!HF;Z3ll5-1^-k7OoZl9 ze*Nnx;_sV!m>>t;@3zp%t73h}J)pf-k{PmGAV9&fGU81s95&_5rhgQ>Ua zOz*C*&u(>EX>XX4(T>H5D+8}x^T z!YUL=Cpc-_wDu78*g`n|c(48ZLY&w5(`oxU1$o*xSW<0^I4L9nCSIj2DwgY+mJ zq`g)us2q(>AKtx-|8t$*(Ofz@{tPJJJv}?TJM15g&YOeuu3~G450~x=%$?nZx!vYz zI+!~p?yciy@3}&}%}zSQ;aRx6JvlQoJvmu<@^p7+?|^)*?>2OsY?CM%UE7i1Yo`}D4$|lNKWsI-De67hK4`q(*jr7eW|C%m0MObXc}E*0Gg>tPA%He| zb&5tp$N_?g!C7mhy&QfT%6AT_E2!Ss-bi>GT9gp;;X^PZA)=ML&mTP8NYLCWzOGwx4WG z;u7`oKOhs;$ek)O1pJ7UP2qZ4@qqALznwNX5&Z}QJ)wW7PI5X(+vyRql{OTm*&Tu% z%gNU6px*)pZ~mdj$>e_W?0O9zB=zewP~<1)Ysr)AG@G1XOb)EU$>_M(S2(r1^VAIY z0|k|-8W`AvA%T;3p;eEP;TcRmfz5QMC+C-vC%raB2mu$=Y!5o8uqvu&C>Wy)^Y@aq z!{K;+B^Z^AC~S$YCe#muQHG2XrfT6}L|ReQPJsrPLEE}1wGY3V9>RYGOQnIIAC8*6 zQ8I+P?>!$T&7N1E`Q>DP^a4aiDkrB3$e7gF-vwjuQ%BqI4fXou{7NFMly*}%U6@t~ zES{WykZe#0SCqlG#|hyRx@U2n05wQk{Xsh!HPzOegF*9E(nfB7HCF^#sNVqhGQI$8 zUiu`-mVJWSAb?CjZK5|Tm5jZH@CvJ`{iE6%Od1Y&4qOKBfw>GW^_}hg131}J*l0Q& z_6Hmv=4;~7DV)yY%CdTIgdSUmUEZ#(f@~X7wwi~j6vjhA?O}4(YYvB<=kNs8jsV2LXl@HhUfLS+vi5|k3)bDZRu|WjX z4KapHRvaA|D>@h}lEdaOm9b)&Og#d<7*h1opo7;Wbk#BaQL?Zqyn2)@uA0kwlq|2B zGkTQV$89nHN6CX#a~;Yl^$Iv&l(DwrP~b>4Ogs~(PR@oS_=Qo@N6gY~o(4pvX0`Gj zKp1)yE+8(g(mr{1Z~XfTDjLnx2ObMZ8YAr4ASDtfLuKm+7|4%M z4k6XGl+RMiv}52P-%Q6Q1-&JOd6mgCRajfCNq#7jTN;u2R{9kC!V!q}g3w z!X2QppN?<>Herm1MH32DYP-`tcy-DPbh+KP^94fM?RR=3_(9jC&9-o7 zUfR9S+T=y6g_s(rU_`6+KF=TpG|e_-6{)e!Gt_9c_HhD6v|8IdgD_gH9h^W8DB{^X zsQ@365aH29Myv+GD+6=Mncec*Om69`6T6A9XIyP7}Hb>$rJ1>~}GVhidaR zATUU~NF`qCHA(58zLI-DX4E|F>J4Bd7pYoM4VVp&`vdChd`&b=l|>VbWHf-C_Rda_ zdRVvTozd|DOO0XhGwu={9i8=B?vh=-I(1i~GZ-V>HAo#ad+rJZcX}7@3Tz?v?s7%A z;QZl!=d<)-vbMLk_HhE^+u8I{IF+1tzm0C^X!4&Vj~*rO+?^#Jb3@!wJ!{TaljZ`V zcQ{J;&dJK|-cG%-@xfjrdD?uD!lle4Q*ge?h1Fry9|ijat^Rl#n5{S7f3gjxt?lnO z_70||P&auGDlwgWE0K$Lla*;!tX#~|(J?nc7puv|9IN6A2VM~@FL|7l=-;qG+dPiq z_w!gHbbTY10SAC!ua>Z&Uo_97Ar%m#<1Rue;K7`PSov`$ux_o}?YBztYV~`$0ZV8M zEaXU+3?3pcTiY^ye3I$)QR892*JgmZ==y@}QUqxmGoK?1H? zU#p{b%qknBs(v)7%HR=rc7Y@x$*dhIXLVe^Q=!sY!L=o{n?!Ws*A#XD|2OypAJM+;^gTcxk9Chg7;|LH&7 z3<+#lET{f>Z4Vlf^O{>Uz1sAuz@Vnh(%V!%di(^VKj9{KkV0+jP}|V~Ye?zFlMgxi z@%K11mRp#P3%A$~O3$W9M`gfsE}=qP3D9)*w1wzgAk0cEq;6d*y^G*v#SGtS@8a1vgLQD+8GeKuN`L`O=)#w}39h*q%cZEx3+s~8T^Mm9 zx~>WR9bwjtXJMfaaXmD5i7&UJo=#hoU31=>Frt&@Lby@`cG`rxH)p`_r#x7X#tD;lvqR6O|Y8m6z|`TU=JyPqyn* z=y3@Qq7Vtr36ui=o43z}S+J)hh&P`g}@xTeBVjU1&h|nnx*vHCq{KqMX z*i|YArF(xrpdoH&iJ&FsFz_`ZZovrn?JbAsrfu*bqnXEP>jlGfnKHFN8uJhsK+e4y z5{rm&5*skCLy9}UT$L<+epy2lr!&rimX~Qb=TzQ#pcO?sh|19(IfL-t;`JExB9sbl zscM;eHLNCV^jRmdINMc?{y?IztqLr2l#F2;UP(?ipiXvQ(Q-7XrzHk%z(?dBBFmIOk?>t zV*)Y~Y~+w>l)9?O)W`9)aWP5|`?sSJMoisOYwtZZU_{Jcm8na6#O4(zatEfXmLO=d z_q+;KJcT0 zSt3I4B2~#!B%wFc>$k-`>x@Tzt6;5$HquDUW{SjQrWTO*cVThXdQ}2w0dzSO5G+uD zj-;Z3CLCWDv}JG}{z?Hkb>|M1^#~P07T;#RWJ-AD_$V#zU~Uy+#thP}k zonhHh?Xk9MI5q%HmgoQuZYw*P2#|3^ET`@4{T-Qz#DP(HI+{467 zq2iJQSc4b=ip@o%j3`9}(|V1mg2;yjOO;&4Zv^vj{Qe5=Z4XF(xzu z{ZqmkYM*#oau7ZWB$z;R9WE^4hN**>i`QwVjdT{5IYag$ohbiMn^6!IBlte8L%x*x zHD5P&LGU#YYaDA3vUnhwVA6yX*?H{C%}ES2JrPS5QKM-cO{WGjO9zcXYhVZ3#TB}~ zZfN2Gy*G+Pn!wt>$Q*sagX{Dox)kO18EAL zbCwvs+~1;&pb=*(A0?RU7RzHBv7RXxR!bw%AOU2Pig=DbZxf8sJsG!o;}Fl+F}QiG z(F2M(PDb-?c*@c^_+U@W-JF4T-<+p^WaE5x3Ea$S@Og8L!D#j@E zurN+_aHC9h77D5pX^tp_bUsdRWJI`JUvko~t$Fc7GUo88J5c~AP)#bLRw9Kvd;&0? zkPT8u^Sa~Ye7WsW+CgzmrU-sYWeV#G9Xyg@I@2eLo=wN1&s%i{a1c$=s?|Y2D{vA} zk(f7FwFrxMs)0h=J?R$sr$BiLVqrOhfh#3PWautci*#BjaVWUBvaxOd9X|28-^(uo}jWa=t zg#_*yhoXiMGo$EWV~tj^tUVL4!}H|)3`+7|hOEsaxwa4?X|_b>G+ioXXf4p|kNV^f zg(h;!!CF~~Kymyx@<_7Ocg%B`2a6NS3N$#?%+f%sLW#C!=u3SL1>Xj){WD%@((tin-s3)@MB+ugdJbBCrga);^^4MHR zuHNFj^gG1zA_82Tx9+1j-B?xR;a0!d#wx9A@X#x#%k9pnR-HSLzpoJ%v1<%+CQ{fsg`Au~0;^40tIIC_?)VXE>se!3JYw!%?9UBV}V0 zV`ano6u;cQRz z5~{0$M7_iQJ&WChRjzwX#>x=GVv6Qn%xx$_xz6uNJZjZUrZPfaPF4;|ZByK-H}x7! z9WVu6WX5EB(S~>XrzVT`a1>+_aUSK4^JTR2cEox|JBu%;T^MiGlsgc!Yvyy;H#&MB zRphy{lHm#>D8QbUa4lv^|Fp;xsKL%@g7GU1!7>L5rV5n6CQb9f?ocymZJg;-#^e%K zIBB9!LZv`R50Rs*=#t(N6*dn^2)VH*=AH~aTqfsI#iBpMNY6)wKERFC->0fBX3KF` z=gfvtTaGe)t|S1L#~M?_d0}#q_ZywTwRr!fG2WChaM)XYjupbig}@1M)ZjueLJND# z+Qq4bQ?IRV>#%>b8#YY%_Wia<%y=r+j0ybi5n3J4o}PaPAQc zM^MIYgz8gKo#~ca61$Jl;>e>c;w=#lj(N|mQ?RD;GF{W@wJaF2&^?$Hs}ZJ{RUT4p z6R~cv0&23k3&m5Sde9Qa0#DBD4bqcwh>XnJ>5b8Y6aXxsW|0n>A&>GrG7?WbRWG5Z z7%7<%>!vZ+M+zRG^A!wQ%Uf#Ct{$q1Zs$7)p@*q*sr+m8hR$uniDXqNnyoSQfL1c! z6*U^4C}%PU*jLdzp|C#2>W(@C+Wc7Ki${|$G)BOZqz|P6UWZc~33-WRkr(rbCIagy zR&!pEg*NhXp`(sPDp0&Q3U_@d_|?jzUKGgw+2I&@j1|NiXXVMcOUCM-GcWkndksGL z7yVN20{%?V?83+?p@{RqTqq#f-_NaAAL9iVm_o-!a}7UOY&*si7AgjV{t9gmR#u2V zQ1)}>3cA(>y02;Vy@b%v5+WY=rKlSV0C343VEv}E4$(GF4x%%w_^ zi}bv0$L22MtayVfMqqqucKK5|8^|Tj!)t!wshk_SG~keVE+81foiT=1s3`UDPv-$n zO47o$UU|e#_FjXT;G8T&3UdU0YG`)eoT4A77c7}qdNe?hjF)I?@RY3rt_QUbe)wiW zqFzZzwBzRg9M?m3d^1e3{MF`Xc21`$&NwRPxJ#$G?Zq{IB z$x>CLZZ3Rf%19a^Z^ZzgFbX zJZ%{L%Gd>&eTC5v_)x-}zSC#VoXdyVpMn*%?uZpP?A5pXC9;2dhL_|^oY-Xw02fr{ zdvSOyg>~6S_we`NlIgiXhA!e_Xd$bj7+;LZznnHm3=*>25SGZQdu01=Ak|5VTqG!y zOYzEH+LF!Ig3tD#7;iVRJZFDYRkK`Ll#ADG@*avx>;q;#F9Khfqw}r~_X3>GNQyGy z6zj?}p>HMMjrCr<(vdu*#v3|E_hbeDClB;QZtJTZ-`&~R;07zxc)LTkUP0G{D(}kR z#dAEJJ;Jn_MGEeP5Z2(U1rIoDT+)*J2(aaYu`Tb7X^EGIrRBY-C1~ecoPs5Uf!#`M zk*GrlbYUk3dq1Tp33)OmG#7;Ags980u&}henl1VYwI76<4WU!pc{bULGvNG}iF|njn0=g zotw3Y!x!w%elvn};c%MTbI*z?TrC<0i<@rD419&yS;$1p-=Iwsfh zf-76UQCo8l+(NeiB%aYH;;}o+D_MR*_qv?*;S2^Za5=Z|W~1{mjA$;JfupV_cv-mQ zSqZle!%IKK*X*Kavr*1Vu|gXh=lm>Jsb+Dt2PgRB)gEzUd!?tet-dam6Nm?R-VV!0 z^877txnigsp8J&_q-BgU--Ps-hL2TL>_t*hlvc6`2Mcm&!>45H)3eGsBCsm@OU7&vmU-}oXl9R`M zSt*h$T$okKO1TG7EAY1Lnj|VN*qBI4JX6Oe9;H~oRlXUEC1}Me z>|XYv;bW+@NuiKb42C$k?Bt594(qNtv%$crNY@3J44SUV|WYY*;W>ZN3I8)E~Sx5Ip<-ml01MTH z+j%TD;-&a`%1jL@2G98$c^Y6E3XF1*_IhWG;$mO2oZ`AC1bK?+Ra8gO#%W7Di)#$y zUBBq4oH^@jbZsu|7%Luuq}v;zW2Z$%@XQ-YTM$nTes5>od;ASxDzK8M?Lk%NaeB+aWKbCPKP;Fj$QYuoPS z9awFnEG4KldrGDZHvBakEzeFw@<-r6b8w_6_#*GyUH8Kp`KKIQrx3+<0c?Fs|0jQ2p75w^o zDTb2KOIxN^P)tx-LjTh|{nR06;RPC`H;B}2E`_>z!^2%pmUHVV-h~cGm{YsYS3IRb$lJoX*GU#gpH zr)%TxYG@~~ENpQaMI5}b1RDrp?N_O1R zaEGeLDzjT9Zd)V)G1)v(10YS*NTn zQ>!;J4(QT|>Gds%!E_`ZvVke~?ig-yN?7;o1+R@jBc(_q-u^Ng$HrGVJ(-K``=PO|H0Y(+ z>Il7<6v#u08k?8qOIV9d*wn1Vz2yvSqD|V+v*51}VS|@>SGMKDqu89p5fi(4MN=my zNq&l^lFO^yy?pe#$_<~fx983_Ha0%co!LaPRw5`-2}whV7Np%FUKH*&nF2T_+t_QW$^wv(OZK2pww|Wyk0BrkvmcHowYfCOP0#&FQdI zlPTp`hoz=>Z%*e{@%4o=eRNw^QoTYbqPmoi_OYp9nYV#+7yQMibHi7aV>ivACVoA> zA5&=lI~yk$JGP(_XlE1qR(RPkr2U1rI5E$|S;SRoRFc@K%PJ0L@fOYK-;9ffJ`Y59$dd!WW zaUx|3a)k_vu~|{hYeRgVk4wHRN;R9cJYWgVx z?C4<+MB3|*U8lf>JSEJ)r#V10`!d>zMg*n|i_+C0H6}E(Xo^S#z|hszn{Hx+^8+e0 zP&Su!kP6YFGP%h7y%b*s>4EuJuHjt>EhFMQS8_N8=f~MveNm$7GB(xf^7H_>$v%o) zjs)_qt}cpO4rfj>VV`zHOY-ppn`+Bp%zHq&e1kcC*5#)Mr7l)Ul`ns(t<}dox2&yU z{{ZR%t*+Z|>+BS-4aFSdGJEhd#T?VKrRrN-L!Rg`ACB;_-{r^-$2{uTs=tUizq2tm zCBBXX0H!qitZhPnqGbthl9ar(SYocSe8$t;YDV-bVL5WSW_SAxUpx63=@|A=FPfED zH#7^6?y>IEjX`B*R`Rf&Pfq~UnqO4i5(8+b#vhKv9OZN)81Y`%K04>*IO5k7AFc3) z#>o|a%L^Xip`3JjNdupJk@1GXO6gmGaFEu>53MhogN}q#B3JCY;y(I-y3#Ycux%xE z3u7vCbkD3??-e*0o@h%2yv}Je9{EUM6ArAI^ z1LNIti5$>D7UnrOwGS}492b3;zw$^i=9(Y!OIJd>H-=d2#~6e-MvRhwn=QhxjxdYx zBZtnh|FyCR41nSuX%Rxl%~^ziF0%;VPo%xHKKO)dS%eMVg1^ALo<$UzUt$saBYezd zj7iu#kvC`&HaTWI(U$~l-0-PZ-T~!3X0Z0)FV)ln^l{{Kw9I?HvWMfMD5UYto zFyh=08C&Ez;xBw)$Oh*0qJ?PPW&yCnzmC)Gvf-K^1e(N`6AJ^jjO!R;XXkYoKjYT` z`Mp+yhesL$FqwUipNYb!;6`{7qJcF={{E?*<5Lyb9mFp1-803l-S554&n#k4uRWWr z_~4-1=d&dwVD`lv5E^9~B6^oq=XrW{QNtBEB~scjJ>WwW=mDOGTY@0-t{QB-n~d2F zWl^?!%VWa`%MVOkV2O2{Rlk;#WO7*5FJ*!$SY8+|G4{JpzD%(ue39i0I>5+)8R@G{ zGvrWMk`h_UgU;4Ph6L~@ zpl}KLz#iPMCW<^Zn}%QioN~e42RUVH;_7`a|5QgeI4>ra%;Po2soWwOa+q}e3O6)wNUo`wHO!BE_ z=^&Py(bZd9@{PP}2Ge6lE3pJOgycNrc+Xv;4a!&gO}9%)A=|n72;_unBeQp$SLUBG zsnj;bQ-OUP!!i~*{)KNSjEs1WGSEsTk}}Eqn9Zv*cj>g;!;mFMNkiF4GjQLIuZ_j+ zF#H$V@jEn{A!s5lmt%7A41)azZv-|#SV99CAxa@g+ z-g7l+io6P|kn8xs0E8GVL5}AzbEw&}tSj_Ku;?o`yeGZRXa*hO8RUNBprjX8n37LA z@~hw6AQ>yWASU_THp7-0ulQ6LAKZpS@E^~U<)fjzJ3oh~3M}i$=P+3$=s%s4SL*N* zw0xivFu-?gP}IRo(J_AYEll5-LTUOqUXV8CgrPJTqG&-^b1tVMX0ap=5qpiuiGB zfh1crNfDo#N|AmbRmx^Fh0FNfJMfz2M_QyNJaV?F`c&=JqpzRW&Q_GKY)g@^X5aM6 z*0b+>Wee%fvu$q%ctPyV61 zmMUwQC+$xB`M=ZpKXA>Y&Nu$=#Dx6){^`Uw{_*O2pZ|EH-#X(*R|_n8{aX&I9f`mE ig#N$!gO?M3{MipDzW4wBj{Kee(Tj=XyZ>Qg;{O9%qMBs@ literal 0 HcmV?d00001 diff --git a/Trurl-based/Dev0/Mod/CPL486.txt b/Trurl-based/Dev0/Mod/CPL486.txt new file mode 100644 index 0000000..0c2987a --- /dev/null +++ b/Trurl-based/Dev0/Mod/CPL486.txt @@ -0,0 +1,1070 @@ +MODULE Dev0CPL486; + + (* THIS IS TEXT COPY OF CPL486.odc *) + (* DO NOT EDIT *) + +(** + project = "BlackBox" + organization = "www.oberon.ch" + contributors = "Oberon microsystems" + version = "System/Rsrc/AboutBB" + copyright = "System/Rsrc/AboutBB" + license = "Docu/BB-License" + references = "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps" + changes = "" + issues = "" + +**) + + IMPORT DevCPM := Dev0CPM, DevCPT := Dev0CPT, DevCPE := Dev0CPE; + + TYPE + Item* = RECORD + mode*, tmode*, form*: BYTE; + offset*, index*, reg*, scale*: INTEGER; (* adr = offset + index * scale *) + typ*: DevCPT.Struct; + obj*: DevCPT.Object + END ; + +(* Items: + + mode | offset index scale reg obj +------------------------------------------------ + 1 Var | adr xreg scale obj (ea = FP + adr + xreg * scale) + 2 VarPar| off xreg scale obj (ea = [FP + obj.adr] + off + xreg * scale) + 3 Con | val (val2) NIL + Con | off obj (val = adr(obj) + off) + Con | id NIL (for predefined reals) + 6 LProc | obj + 7 XProc | obj + 9 CProc | obj +10 IProc | obj +13 TProc | mthno 0/1 obj (0 = normal / 1 = super call) +14 Ind | off xreg scale Reg (ea = Reg + off + xreg * scale) +15 Abs | adr xreg scale NIL (ea = adr + xreg * scale) + Abs | off xreg scale obj (ea = adr(obj) + off + xreg * scale) + Abs | off len 0 obj (for constant strings and reals) +16 Stk | (ea = ESP) +17 Cond | CC +18 Reg | (Reg2) Reg +19 DInd | off xreg scale Reg (ea = [Reg + off + xreg * scale]) + + tmode | record tag array desc +------------------------------------- + VarPar | [FP + obj.adr + 4] [FP + obj.adr] + Ind | [Reg - 4] [Reg + 8] + Con | Adr(typ.strobj) + +*) + + CONST + processor* = 10; (* for i386 *) + NewLbl* = 0; + + TYPE + Label* = INTEGER; (* 0: unassigned, > 0: address, < 0: - (linkadr + linktype * 2^24) *) + + VAR + level*: BYTE; + one*: DevCPT.Const; + + CONST + (* item base modes (=object modes) *) + Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13; + + (* item modes for i386 (must not overlap item basemodes, > 13) *) + Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19; + + (* structure forms *) + Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6; + Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12; + Pointer = 13; ProcTyp = 14; Comp = 15; + Char16 = 16; String16 = 17; Int64 = 18; Guid = 23; + + (* composite structure forms *) + Basic = 1; Array = 2; DynArr = 3; Record = 4; + + (* condition codes *) + ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *) + ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *) + ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1; + ccAlways = -1; ccNever = -2; ccCall = -3; + + (* registers *) + AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7; + + (* fixup types *) + absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105; + + (* system trap numbers *) + withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4; + recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8; + + + VAR + Size: ARRAY 32 OF INTEGER; (* Size[typ.form] == +/- typ.size *) + a1, a2: Item; + + + PROCEDURE MakeReg* (VAR x: Item; reg: INTEGER; form: BYTE); + BEGIN + ASSERT((reg >= 0) & (reg < 8)); + x.mode := Reg; x.reg := reg; x.form := form + END MakeReg; + + PROCEDURE MakeConst* (VAR x: Item; val: INTEGER; form: BYTE); + BEGIN + x.mode := Con; x.offset := val; x.form := form; x.obj := NIL; + END MakeConst; + + PROCEDURE AllocConst* (VAR x: Item; con: DevCPT.Const; form: BYTE); + VAR r: REAL; short: SHORTREAL; c: DevCPT.Const; i: INTEGER; + BEGIN + IF form IN {Real32, Real64} THEN + r := con.realval; + IF ABS(r) <= MAX(SHORTREAL) THEN + short := SHORT(r); + IF short = r THEN form := Real32 (* a shortreal can represent the exact value *) + ELSE form := Real64 (* use a real *) + END + ELSE form := Real64 (* use a real *) + END + ELSIF form IN {String8, String16, Guid} THEN + x.index := con.intval2 (* string length *) + END; + DevCPE.AllocConst(con, form, x.obj, x.offset); + x.form := form; x.mode := Abs; x.scale := 0 + END AllocConst; + + (*******************************************************) + + PROCEDURE BegStat*; (* general-purpose procedure which is called before each statement *) + BEGIN + END BegStat; + + PROCEDURE EndStat*; (* general-purpose procedure which is called after each statement *) + BEGIN + END EndStat; + + (*******************************************************) + + PROCEDURE SetLabel* (VAR L: Label); + VAR link, typ, disp, x: INTEGER; c: SHORTCHAR; + BEGIN + ASSERT(L <= 0); link := -L; + WHILE link # 0 DO + typ := link DIV 1000000H; link := link MOD 1000000H; + IF typ = short THEN + disp := DevCPE.pc - link - 1; ASSERT(disp < 128); + DevCPE.PutByte(link, disp); link := 0 + ELSIF typ = relative THEN + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc - link - 4); link := x + ELSE + x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc + typ * 1000000H); link := x + END + END; + L := DevCPE.pc; + a1.mode := 0; a2.mode := 0 + END SetLabel; + + + (*******************************************************) + + PROCEDURE GenWord (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256) + END GenWord; + + PROCEDURE GenDbl (x: INTEGER); + BEGIN + DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256); DevCPE.GenByte(x DIV 10000H); DevCPE.GenByte(x DIV 1000000H) + END GenDbl; + + PROCEDURE CaseEntry* (tab, from, to: INTEGER); + VAR a, e: INTEGER; + BEGIN + a := tab + 4 * from; e := tab + 4 * to; + WHILE a <= e DO + DevCPE.PutByte(a, DevCPE.pc); + DevCPE.PutByte(a + 1, DevCPE.pc DIV 256); + DevCPE.PutByte(a + 2, DevCPE.pc DIV 65536); + INC(a, 4) + END; + a1.mode := 0; a2.mode := 0 + END CaseEntry; + + PROCEDURE GenLinked (VAR x: Item; type: BYTE); + VAR link: DevCPT.LinkList; + BEGIN + IF x.obj = NIL THEN GenDbl(x.offset) + ELSE + link := DevCPE.OffsetLink(x.obj, x.offset); + IF link # NIL THEN + GenDbl(type * 1000000H + link.linkadr MOD 1000000H); + link.linkadr := DevCPE.pc - 4 + ELSE GenDbl(0) + END + END + END GenLinked; + + PROCEDURE CheckSize (form: BYTE; VAR w: INTEGER); + BEGIN + IF form IN {Int16, Char16} THEN DevCPE.GenByte(66H); w := 1 + ELSIF form >= Int32 THEN ASSERT(form IN {Int32, Set, NilTyp, Pointer, ProcTyp}); w := 1 + ELSE w := 0 + END + END CheckSize; + + PROCEDURE CheckForm (form: BYTE; VAR mf: INTEGER); + BEGIN + IF form = Real32 THEN mf := 0 + ELSIF form = Real64 THEN mf := 4 + ELSIF form = Int32 THEN mf := 2 + ELSE ASSERT(form = Int16); mf := 6 + END + END CheckForm; + + PROCEDURE CheckConst (VAR x: Item; VAR s: INTEGER); + BEGIN + IF (x.form > Int8) & (x.offset >= -128) & (x.offset < 128) & (x.obj = NIL) THEN s := 2 + ELSE s := 0 + END + END CheckConst; + + PROCEDURE GenConst (VAR x: Item; short: BOOLEAN); + BEGIN + IF x.obj # NIL THEN GenLinked(x, absolute) + ELSIF x.form <= Int8 THEN DevCPE.GenByte(x.offset) + ELSIF short & (x.offset >= -128) & (x.offset < 128) THEN DevCPE.GenByte(x.offset) + ELSIF x.form IN {Int16, Char16} THEN GenWord(x.offset) + ELSE GenDbl(x.offset) + END + END GenConst; + + PROCEDURE GenCExt (code: INTEGER; VAR x: Item); + VAR disp, mod, base, scale: INTEGER; + BEGIN + ASSERT(x.mode IN {Reg, Ind, Abs, Stk}); + ASSERT((code MOD 8 = 0) & (code < 64)); + disp := x.offset; base := x.reg; scale := x.scale; + IF x.mode = Reg THEN mod := 0C0H; scale := 0 + ELSIF x.mode = Stk THEN base := SP; mod := 0; disp := 0; scale := 0 + ELSIF x.mode = Abs THEN + IF scale = 1 THEN base := x.index; mod := 80H; scale := 0 + ELSE base := BP; mod := 0 + END + ELSIF (disp = 0) & (base # BP) THEN mod := 0 + ELSIF (disp >= -128) & (disp < 128) THEN mod := 40H + ELSE mod := 80H + END; + IF scale # 0 THEN + DevCPE.GenByte(mod + code + 4); base := base + x.index * 8; + IF scale = 8 THEN DevCPE.GenByte(0C0H + base); + ELSIF scale = 4 THEN DevCPE.GenByte(80H + base); + ELSIF scale = 2 THEN DevCPE.GenByte(40H + base); + ELSE ASSERT(scale = 1); DevCPE.GenByte(base); + END; + ELSE + DevCPE.GenByte(mod + code + base); + IF (base = SP) & (mod <= 80H) THEN DevCPE.GenByte(24H) END + END; + IF x.mode = Abs THEN GenLinked(x, absolute) + ELSIF mod = 80H THEN GenDbl(disp) + ELSIF mod = 40H THEN DevCPE.GenByte(disp) + END + END GenCExt; + + PROCEDURE GenDExt (VAR r, x: Item); + BEGIN + ASSERT(r.mode = Reg); + GenCExt(r.reg * 8, x) + END GenDExt; + + (*******************************************************) + + PROCEDURE GenMove* (VAR from, to: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[from.form] = Size[to.form]); + IF to.mode = Reg THEN + IF from.mode = Con THEN + IF to.reg = AX THEN + + IF (a1.mode = Con) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0 + END; + CheckSize(from.form, w); + IF (from.offset = 0) & (from.obj = NIL) THEN + DevCPE.GenByte(30H + w); DevCPE.GenByte(0C0H + 9 * to.reg) (* XOR r,r *) + ELSE + DevCPE.GenByte(0B0H + w * 8 + to.reg); GenConst(from, FALSE) + END; + ELSIF (to.reg = AX) & (from.mode = Abs) & (from.scale = 0) THEN + + IF (a1.mode = Abs) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) + OR (a2.mode = Abs) & (from.offset = a2.offset) & (from.obj = a2.obj) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from; a2.mode := 0; + CheckSize(from.form, w); + DevCPE.GenByte(0A0H + w); GenLinked(from, absolute); + ELSIF (from.mode # Reg) OR (from.reg # to.reg) THEN + IF to.reg = AX THEN + IF (from.mode = Ind) & (from.scale = 0) & ((from.reg = BP) OR (from.reg = BX)) THEN + + IF (a1.mode = Ind) & (from.offset = a1.offset) & (from.reg = a1.reg) & (from.form = a1.form) + OR (a2.mode = Ind) & (from.offset = a2.offset) & (from.reg = a2.reg) & (from.form = a2.form) THEN + RETURN + END; + + a1 := from + ELSE a1.mode := 0 + END; + a2.mode := 0 + END; + CheckSize(from.form, w); + DevCPE.GenByte(8AH + w); GenDExt(to, from) + END + ELSE + CheckSize(from.form, w); + IF from.mode = Con THEN + DevCPE.GenByte(0C6H + w); GenCExt(0, to); GenConst(from, FALSE); + a1.mode := 0; a2.mode := 0 + ELSIF (from.reg = AX) & (to.mode = Abs) & (to.scale = 0) THEN + DevCPE.GenByte(0A2H + w); GenLinked(to, absolute); + a2 := to + ELSE + DevCPE.GenByte(88H + w); GenDExt(from, to); + IF from.reg = AX THEN + IF (to.mode = Ind) & (to.scale = 0) & ((to.reg = BP) OR (to.reg = BX)) THEN a2 := to END + ELSE a1.mode := 0; a2.mode := 0 + END + END + END + END GenMove; + + PROCEDURE GenExtMove* (VAR from, to: Item); + VAR w, op: INTEGER; + BEGIN + ASSERT(from.mode # Con); + IF from.form IN {Byte, Char8, Char16} THEN op := 0B6H (* MOVZX *) + ELSE op := 0BEH (* MOVSX *) + END; + IF from.form IN {Int16, Char16} THEN INC(op) END; + DevCPE.GenByte(0FH); DevCPE.GenByte(op); GenDExt(to, from); + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenExtMove; + + PROCEDURE GenSignExt* (VAR from, to: Item); + BEGIN + ASSERT(to.mode = Reg); + IF (from.mode = Reg) & (from.reg = AX) & (to.reg = DX) THEN + DevCPE.GenByte(99H) (* cdq *) + ELSE + GenMove(from, to); (* mov to, from *) + DevCPE.GenByte(0C1H); GenCExt(38H, to); DevCPE.GenByte(31) (* sar to, 31 *) + END + END GenSignExt; + + PROCEDURE GenLoadAdr* (VAR from, to: Item); + BEGIN + ASSERT(to.form IN {Int32, Pointer, ProcTyp}); + IF (from.mode = Abs) & (from.scale = 0) THEN + DevCPE.GenByte(0B8H + to.reg); GenLinked(from, absolute) + ELSIF from.mode = Stk THEN + DevCPE.GenByte(89H); GenCExt(SP * 8, to) + ELSIF (from.mode # Ind) OR (from.offset # 0) OR (from.scale # 0) THEN + DevCPE.GenByte(8DH); GenDExt(to, from) + ELSIF from.reg # to.reg THEN + DevCPE.GenByte(89H); GenCExt(from.reg * 8, to) + ELSE RETURN + END; + IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenLoadAdr; + + PROCEDURE GenPush* (VAR src: Item); + VAR s: INTEGER; + BEGIN + IF src.mode = Con THEN + ASSERT(src.form >= Int32); + CheckConst(src, s); DevCPE.GenByte(68H + s); GenConst(src, TRUE) + ELSIF src.mode = Reg THEN + ASSERT((src.form >= Int16) OR (src.reg < 4)); + DevCPE.GenByte(50H + src.reg) + ELSE + ASSERT(src.form >= Int32); + DevCPE.GenByte(0FFH); GenCExt(30H, src) + END + END GenPush; + + PROCEDURE GenPop* (VAR dst: Item); + BEGIN + IF dst.mode = Reg THEN + ASSERT((dst.form >= Int16) OR (dst.reg < 4)); + DevCPE.GenByte(58H + dst.reg); + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + ELSE + DevCPE.GenByte(08FH); GenCExt(0, dst) + END + END GenPop; + + PROCEDURE GenConOp (op: INTEGER; VAR src, dst: Item); + VAR w, s: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + CheckConst(src, s); + IF (dst.mode = Reg) & (dst.reg = AX) & (s = 0) THEN + DevCPE.GenByte(op + 4 + w); GenConst(src, FALSE) + ELSE + DevCPE.GenByte(80H + s + w); GenCExt(op, dst); GenConst(src, TRUE) + END + END GenConOp; + + PROCEDURE GenDirOp (op: INTEGER; VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + CheckSize(src.form, w); + IF dst.mode = Reg THEN + DevCPE.GenByte(op + 2 + w); GenDExt(dst, src) + ELSE + DevCPE.GenByte(op + w); GenDExt(src, dst) + END + END GenDirOp; + + PROCEDURE GenAdd* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(0, src, dst) + ELSE RETURN + END + ELSE + GenConOp(0, src, dst) + END + ELSE + GenDirOp(0, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAdd; + + PROCEDURE GenAddC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 0 ELSE op := 10H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAddC; + + PROCEDURE GenSub* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF src.mode = Con THEN + IF src.obj = NIL THEN + IF src.offset = 1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst) + END + ELSIF src.offset = -1 THEN + IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *) + ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst) + END + ELSIF src.offset # 0 THEN + GenConOp(28H, src, dst) + ELSE RETURN + END + ELSE + GenConOp(28H, src, dst) + END + ELSE + GenDirOp(28H, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSub; + + PROCEDURE GenSubC* (VAR src, dst: Item; first, ovflchk: BOOLEAN); + VAR op: INTEGER; + BEGIN + ASSERT(Size[src.form] = Size[dst.form]); + IF first THEN op := 28H ELSE op := 18H END; + IF src.mode = Con THEN GenConOp(op, src, dst) + ELSE GenDirOp(op, src, dst) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSubC; + + PROCEDURE GenComp* (VAR src, dst: Item); + VAR w: INTEGER; + BEGIN + IF src.mode = Con THEN + IF (src.offset = 0) & (src.obj = NIL) & (dst.mode = Reg) THEN + CheckSize(dst.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * dst.reg) (* or r,r *) + ELSE GenConOp(38H, src, dst) + END + ELSE + GenDirOp(38H, src, dst) + END + END GenComp; + + PROCEDURE GenAnd* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # -1) THEN GenConOp(20H, src, dst) END + ELSE GenDirOp(20H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenAnd; + + PROCEDURE GenOr* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(8H, src, dst) END + ELSE GenDirOp(8H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenOr; + + PROCEDURE GenXor* (VAR src, dst: Item); + BEGIN + IF src.mode = Con THEN + IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(30H, src, dst) END + ELSE GenDirOp(30H, src, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenXor; + + PROCEDURE GenTest* (VAR x, y: Item); + VAR w: INTEGER; + BEGIN + ASSERT(Size[x.form] = Size[y.form]); + CheckSize(x.form, w); + IF x.mode = Con THEN + IF (x.mode = Reg) & (x.reg = AX) THEN + DevCPE.GenByte(0A8H + w); GenConst(x, FALSE) + ELSE + DevCPE.GenByte(0F6H + w); GenCExt(0, y); GenConst(x, FALSE) + END + ELSE + DevCPE.GenByte(84H + w); + IF y.mode = Reg THEN GenDExt(y, x) ELSE GenDExt(x, y) END + END + END GenTest; + + PROCEDURE GenNeg* (VAR dst: Item; ovflchk: BOOLEAN); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(18H, dst); + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNeg; + + PROCEDURE GenNot* (VAR dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(10H, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenNot; + + PROCEDURE GenMul* (VAR src, dst: Item; ovflchk: BOOLEAN); + VAR w, s, val, f2, f5, f9: INTEGER; + BEGIN + ASSERT((dst.mode = Reg) & (Size[src.form] = Size[dst.form])); + IF (src.mode = Con) & (src.offset = 1) THEN RETURN END; + IF src.form <= Int8 THEN + ASSERT(dst.reg = 0); + DevCPE.GenByte(0F6H); GenCExt(28H, src) + ELSIF src.mode = Con THEN + val := src.offset; + IF (src.obj = NIL) & (val # 0) & ~ovflchk THEN + f2 := 0; f5 := 0; f9 := 0; + WHILE ~ODD(val) DO val := val DIV 2; INC(f2) END; + WHILE val MOD 9 = 0 DO val := val DIV 9; INC(f9) END; + WHILE val MOD 5 = 0 DO val := val DIV 5; INC(f5) END; + IF ABS(val) <= 3 THEN + WHILE f9 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(0C0H + dst.reg * 9); + DEC(f9) + END; + WHILE f5 > 0 DO + DevCPE.GenByte(8DH); + DevCPE.GenByte(dst.reg * 8 + 4); + DevCPE.GenByte(80H + dst.reg * 9); + DEC(f5) + END; + IF ABS(val) = 3 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(dst.reg * 8 + 4); DevCPE.GenByte(40H + dst.reg * 9) + END; + IF f2 > 1 THEN DevCPE.GenByte(0C1H); DevCPE.GenByte(0E0H + dst.reg); DevCPE.GenByte(f2) + ELSIF f2 = 1 THEN DevCPE.GenByte(1); DevCPE.GenByte(0C0H + dst.reg * 9) + END; + IF val < 0 THEN DevCPE.GenByte(0F7H); GenCExt(18H, dst) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END; + RETURN + END + END; + CheckSize(src.form, w); CheckConst(src, s); + DevCPE.GenByte(69H + s); GenDExt(dst, dst); GenConst(src, TRUE) + ELSE + CheckSize(src.form, w); + DevCPE.GenByte(0FH); DevCPE.GenByte(0AFH); GenDExt(dst, src) + END; + IF ovflchk THEN DevCPE.GenByte(0CEH) END; + IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END + END GenMul; + + PROCEDURE GenDiv* (VAR src: Item; mod, pos: BOOLEAN); + VAR w, rem: INTEGER; + BEGIN + ASSERT(src.mode = Reg); + IF src.form >= Int32 THEN DevCPE.GenByte(99H) (* cdq *) + ELSIF src.form = Int16 THEN DevCPE.GenByte(66H); DevCPE.GenByte(99H) (* cwd *) + ELSE DevCPE.GenByte(66H); DevCPE.GenByte(98H) (* cbw *) + END; + CheckSize(src.form, w); DevCPE.GenByte(0F6H + w); GenCExt(38H, src); (* idiv src *) + IF src.form > Int8 THEN rem := 2 (* edx *) ELSE rem := 4 (* ah *) END; + IF pos THEN (* src > 0 *) + CheckSize(src.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + IF mod THEN + DevCPE.GenByte(79H); DevCPE.GenByte(2); (* jns end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); DevCPE.GenByte(1); (* jns end *) + DevCPE.GenByte(48H); (* dec eax *) + END + ELSE + CheckSize(src.form, w); DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + IF mod THEN + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(9); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(8) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(4); (* je end *) + DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(79H); (* jns end *) + IF src.form = Int16 THEN DevCPE.GenByte(6); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(5) END; + DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *) + DevCPE.GenByte(74H); DevCPE.GenByte(1); (* je end *) + DevCPE.GenByte(48H); (* dec eax *) + END +(* + CheckSize(src.form, w); DevCPE.GenByte(3AH + w); GenCExt(8 * rem, src); (* cmp rem,src *) + IF mod THEN + DevCPE.GenByte(72H); DevCPE.GenByte(4); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(2); (* jg end *) + DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *) + ELSE + DevCPE.GenByte(72H); DevCPE.GenByte(3); (* jb end *) + DevCPE.GenByte(7FH); DevCPE.GenByte(1); (* jg end *) + DevCPE.GenByte(48H); (* dec eax *) + END +*) + END; + a1.mode := 0; a2.mode := 0 + END GenDiv; + + PROCEDURE GenShiftOp* (op: INTEGER; VAR cnt, dst: Item); + VAR w: INTEGER; + BEGIN + CheckSize(dst.form, w); + IF cnt.mode = Con THEN + ASSERT(cnt.offset >= 0); ASSERT(cnt.obj = NIL); + IF cnt.offset = 1 THEN + IF (op = 10H) & (dst.mode = Reg) THEN (* shl r *) + DevCPE.GenByte(w); GenDExt(dst, dst) (* add r, r *) + ELSE + DevCPE.GenByte(0D0H + w); GenCExt(op, dst) + END + ELSIF cnt.offset > 1 THEN + DevCPE.GenByte(0C0H + w); GenCExt(op, dst); DevCPE.GenByte(cnt.offset) + END + ELSE + ASSERT((cnt.mode = Reg) & (cnt.reg = CX)); + DevCPE.GenByte(0D2H + w); GenCExt(op, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenShiftOp; + + PROCEDURE GenBitOp* (op: INTEGER; VAR num, dst: Item); + BEGIN + DevCPE.GenByte(0FH); + IF num.mode = Con THEN + ASSERT(num.obj = NIL); + DevCPE.GenByte(0BAH); GenCExt(op, dst); DevCPE.GenByte(num.offset) + ELSE + ASSERT((num.mode = Reg) & (num.form = Int32)); + DevCPE.GenByte(83H + op); GenDExt(num, dst) + END; + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenBitOp; + + PROCEDURE GenSetCC* (cc: INTEGER; VAR dst: Item); + BEGIN + ASSERT((dst.form = Bool) & (cc >= 0)); + DevCPE.GenByte(0FH); DevCPE.GenByte(90H + cc); GenCExt(0, dst); + IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END + END GenSetCC; + + PROCEDURE GenFLoad* (VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Con THEN (* predefined constants *) + DevCPE.GenByte(0D9H); DevCPE.GenByte(0E8H + src.offset) + ELSIF src.form = Int64 THEN + DevCPE.GenByte(0DFH); GenCExt(28H, src) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D9H + mf); GenCExt(0, src) + END + END GenFLoad; + + PROCEDURE GenFStore* (VAR dst: Item; pop: BOOLEAN); + VAR mf: INTEGER; + BEGIN + IF dst.form = Int64 THEN ASSERT(pop); + DevCPE.GenByte(0DFH); GenCExt(38H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE + CheckForm(dst.form, mf); DevCPE.GenByte(0D9H + mf); + IF pop THEN GenCExt(18H, dst); DevCPE.GenByte(9BH) (* wait *) + ELSE GenCExt(10H, dst) + END + END; + a1.mode := 0; a2.mode := 0 + END GenFStore; + + PROCEDURE GenFDOp* (op: INTEGER; VAR src: Item); + VAR mf: INTEGER; + BEGIN + IF src.mode = Reg THEN + DevCPE.GenByte(0DEH); DevCPE.GenByte(0C1H + op) + ELSE + CheckForm(src.form, mf); + DevCPE.GenByte(0D8H + mf); GenCExt(op, src) + END + END GenFDOp; + + PROCEDURE GenFMOp* (op: INTEGER); + BEGIN + DevCPE.GenByte(0D8H + op DIV 256); + DevCPE.GenByte(op MOD 256); + IF op = 07E0H THEN a1.mode := 0; a2.mode := 0 END (* FSTSW AX *) + END GenFMOp; + + PROCEDURE GenJump* (cc: INTEGER; VAR L: Label; shortjmp: BOOLEAN); + BEGIN + IF cc # ccNever THEN + IF shortjmp OR (L > 0) & (DevCPE.pc + 2 - L <= 128) & (cc # ccCall) THEN + IF cc = ccAlways THEN DevCPE.GenByte(0EBH) + ELSE DevCPE.GenByte(70H + cc) + END; + IF L > 0 THEN DevCPE.GenByte(L - DevCPE.pc - 1) + ELSE ASSERT(L = 0); L := -(DevCPE.pc + short * 1000000H); DevCPE.GenByte(0) + END + ELSE + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSIF cc = ccCall THEN DevCPE.GenByte(0E8H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + IF L > 0 THEN GenDbl(L - DevCPE.pc - 4) + ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + relative * 1000000H) + END + END + END + END GenJump; + + PROCEDURE GenExtJump* (cc: INTEGER; VAR dst: Item); + BEGIN + IF cc = ccAlways THEN DevCPE.GenByte(0E9H) + ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc) + END; + dst.offset := 0; GenLinked(dst, relative) + END GenExtJump; + + PROCEDURE GenIndJump* (VAR dst: Item); + BEGIN + DevCPE.GenByte(0FFH); GenCExt(20H, dst) + END GenIndJump; + + PROCEDURE GenCaseJump* (VAR src: Item); + VAR link: DevCPT.LinkList; tab: INTEGER; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := DevCPE.CaseLinks; DevCPE.CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + END GenCaseJump; +(* + PROCEDURE GenCaseJump* (VAR src: Item; num: LONGINT; VAR tab: LONGINT); + VAR link: DevCPT.LinkList; else, last: LONGINT; + BEGIN + ASSERT((src.form = Int32) & (src.mode = Reg)); + DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg); + tab := (DevCPE.pc + 7) DIV 4 * 4; + else := tab + num * 4; last := else - 4; + NEW(link); link.offset := tab; link.linkadr := DevCPE.pc; + link.next := CaseLinks; CaseLinks := link; + GenDbl(absolute * 1000000H + tab); + WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END; + WHILE DevCPE.pc < last DO GenDbl(table * 1000000H + else) END; + GenDbl(tableend * 1000000H + else) + END GenCaseJump; +*) + PROCEDURE GenCaseEntry* (VAR L: Label; last: BOOLEAN); + VAR typ: INTEGER; + BEGIN + IF last THEN typ := tableend * 1000000H ELSE typ := table * 1000000H END; + IF L > 0 THEN GenDbl(L + typ) ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + typ) END + END GenCaseEntry; + + PROCEDURE GenCall* (VAR dst: Item); + BEGIN + IF dst.mode IN {LProc, XProc, IProc} THEN + DevCPE.GenByte(0E8H); + IF dst.obj.mnolev >= 0 THEN (* local *) + IF dst.obj.adr > 0 THEN GenDbl(dst.obj.adr - DevCPE.pc - 4) + ELSE GenDbl(-dst.obj.adr); dst.obj.adr := -(DevCPE.pc - 4 + relative * 1000000H) + END + ELSE (* imported *) + dst.offset := 0; GenLinked(dst, relative) + END + ELSE DevCPE.GenByte(0FFH); GenCExt(10H, dst) + END; + a1.mode := 0; a2.mode := 0 + END GenCall; + + PROCEDURE GenAssert* (cc, no: INTEGER); + BEGIN + IF cc # ccAlways THEN + IF cc >= 0 THEN + DevCPE.GenByte(70H + cc); (* jcc end *) + IF no < 0 THEN DevCPE.GenByte(2) ELSE DevCPE.GenByte(3) END + END; + IF no < 0 THEN + DevCPE.GenByte(8DH); DevCPE.GenByte(0E0H - no) + ELSE + DevCPE.GenByte(8DH); DevCPE.GenByte(0F0H); DevCPE.GenByte(no) + END + END + END GenAssert; + + PROCEDURE GenReturn* (val: INTEGER); + BEGIN + IF val = 0 THEN DevCPE.GenByte(0C3H) + ELSE DevCPE.GenByte(0C2H); GenWord(val) + END; + a1.mode := 0; a2.mode := 0 + END GenReturn; + + PROCEDURE LoadStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0ACH) ELSE DevCPE.GenByte(0ADH) END (* lods *) + END LoadStr; + + PROCEDURE StoreStr (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(0AAH) ELSE DevCPE.GenByte(0ABH) END (* stos *) + END StoreStr; + + PROCEDURE ScanStr (size: INTEGER; rep: BOOLEAN); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF rep THEN DevCPE.GenByte(0F2H) END; + IF size <= 1 THEN DevCPE.GenByte(0AEH) ELSE DevCPE.GenByte(0AFH) END (* scas *) + END ScanStr; + + PROCEDURE TestNull (size: INTEGER); + BEGIN + IF size = 2 THEN DevCPE.GenByte(66H) END; + IF size <= 1 THEN DevCPE.GenByte(8); DevCPE.GenByte(0C0H); (* or al,al *) + ELSE DevCPE.GenByte(9); DevCPE.GenByte(0C0H); (* or ax,ax *) + END + END TestNull; + + PROCEDURE GenBlockMove* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A4H + w); (* rep:movs *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A5H); (* rep:movs long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0A5H); DEC(len, 4) END; (* movs long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0A5H) END; (* movs word *); + IF ODD(len) THEN DevCPE.GenByte(0A4H) END; (* movs byte *) + END + END GenBlockMove; + + PROCEDURE GenBlockStore* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + IF len = 0 THEN (* variable size move *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + ELSE (* fixed size move *) + len := len * wsize; + IF len >= 16 THEN + DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *) + DevCPE.GenByte(0F3H); DevCPE.GenByte(0ABH); (* rep:stos long*) + len := len MOD 4 + END; + WHILE len >= 4 DO DevCPE.GenByte(0ABH); DEC(len, 4) END; (* stos long *); + IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0ABH) END; (* stos word *); + IF ODD(len) THEN DevCPE.GenByte(0ABH) END; (* stos byte *) + END + END GenBlockStore; + + PROCEDURE GenBlockComp* (wsize, len: INTEGER); (* len = 0: len in ECX *) + VAR w: INTEGER; + BEGIN + ASSERT(len >= 0); + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0A6H + w) (* repe:cmps *) + END GenBlockComp; + + PROCEDURE GenStringMove* (excl: BOOLEAN; wsize, dsize, len: INTEGER); + (* + len = 0: len in ECX, len = -1: len undefined; wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; excl: don't move 0X + *) + VAR loop, end: Label; + BEGIN + IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + (* len >= 0: len IN ECX *) + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H) END; (* xor eax,eax *) + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + IF len < 0 THEN (* no limit *) + StoreStr(dsize); TestNull(wsize); GenJump(ccNE, loop, TRUE); + IF excl THEN (* dec edi *) + DevCPE.GenByte(4FH); + IF dsize # 1 THEN DevCPE.GenByte(4FH) END + END; + ELSE (* cx limit *) + IF excl THEN TestNull(wsize); GenJump(ccE, end, TRUE); StoreStr(dsize) + ELSE StoreStr(dsize); TestNull(wsize); GenJump(ccE, end, TRUE) + END; + DevCPE.GenByte(49H); (* dec ecx *) + GenJump(ccNE, loop, TRUE); + GenAssert(ccNever, copyTrap); (* trap *) + SetLabel(end) + END; + a1.mode := 0; a2.mode := 0 + END GenStringMove; + + PROCEDURE GenStringComp* (wsize, dsize: INTEGER); + (* wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; *) + VAR loop, end: Label; + BEGIN + IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) END; + loop := NewLbl; end := NewLbl; + SetLabel(loop); LoadStr(wsize); + IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *) + ScanStr(dsize, FALSE); GenJump(ccNE, end, TRUE); + IF dsize = 0 THEN DevCPE.GenByte(47H) END; (* inc edi *) + TestNull(wsize); GenJump(ccNE, loop, TRUE); + SetLabel(end); + a1.mode := 0; a2.mode := 0 + END GenStringComp; + + PROCEDURE GenStringLength* (wsize, len: INTEGER); (* len = 0: len in ECX, len = -1: len undefined *) + BEGIN + DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) + IF len # 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *) + ScanStr(wsize, TRUE); + a1.mode := 0; a2.mode := 0 + END GenStringLength; + + PROCEDURE GenStrStore* (size: INTEGER); + VAR w: INTEGER; + BEGIN + IF size # 0 THEN + IF size MOD 4 = 0 THEN w := 1; size := size DIV 4 + ELSIF size MOD 2 = 0 THEN w := 2; size := size DIV 2 + ELSE w := 0 + END; + DevCPE.GenByte(0B9H); GenDbl(size); (* ld ecx,size *) + IF w = 2 THEN DevCPE.GenByte(66H); w := 1 END + ELSE w := 0 + END; + DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *) + a1.mode := 0; a2.mode := 0 + END GenStrStore; + + PROCEDURE GenCode* (op: INTEGER); + BEGIN + DevCPE.GenByte(op); + a1.mode := 0; a2.mode := 0 + END GenCode; + + + PROCEDURE Init*(opt: SET); + BEGIN + DevCPE.Init(processor, opt); + level := 0; + NEW(one); one.realval := 1.0; one.intval := DevCPM.ConstNotAlloc; + END Init; + + PROCEDURE Close*; + BEGIN + a1.obj := NIL; a1.typ := NIL; a2.obj := NIL; a2.typ := NIL; one := NIL; + DevCPE.Close + END Close; + +BEGIN + Size[Undef] := 0; + Size[Byte] := 1; + Size[Bool] := 1; + Size[Char8] := 1; + Size[Int8] := 1; + Size[Int16] := 2; + Size[Int32] := 4; + Size[Real32] := -4; + Size[Real64] := -8; + Size[Set] := 4; + Size[String8] := 0; + Size[NilTyp] := 4; + Size[NoTyp] := 0; + Size[Pointer] := 4; + Size[ProcTyp] := 4; + Size[Comp] := 0; + Size[Char16] := 2; + Size[Int64] := 8; + Size[String16] := 0 +END Dev0CPL486. diff --git a/Trurl-based/Dev0/Mod/CPM.odc b/Trurl-based/Dev0/Mod/CPM.odc new file mode 100644 index 0000000000000000000000000000000000000000..0049d014759cc6129430da419c30ae3309656f8c GIT binary patch literal 28285 zcmeHQ-EU;cRqyFcmN>+Oj|2#TPQrfcShPA_62NB$Nk~2l51n7bIT!2O=a8QVsxVYvVj zj}c<&WADK;(k+(@k8`FMc{BPAuro+_k?(@*aHejY=C zJl2C+BV!T|K4h`&+TT~?7d@ZLE#dC~m%sjPB6=>@uyt))H-TS{F(oPkO{nhu{WDg8 z)zc=af&nS11yLckA+1gL`8yz|$i9g`d{nV1p55+wQ%zPho;0}H2kh%UA3QCY(9gHI?oxiR}o`MFPCM#-yw z_+Pa^PjNJl%H5BFg(0JP({i_>zgL#<>&yCP9Nq5(ap8Fe((5;GPHu+vpw$T|W+!0d z>L6%_iy@>23a;+pzx7X^WvoR_=$hYI%lINJ>tpC~D=|Mf!Gj+~jr)-Pc+xu0>Qwg* z$c2}|LE^gr`@!hQq$y8LElf?9XNqS3sAz5l-Az+#G=hdH+-Ze%M19jaZMUPiJKhg{ zyLPtQjZf=c6SnGcQ0oMZejwZ397M5c$5B0KoW_Cap0|PdymQd39d?pV7cs-=!m(j$Ihxl`!eid!Frrcwxh*PAfs8lLF<`Brf z3?YZ9K!WlE+73TW{4r9#&I=lt6@pyR?LQ|aTGmh5lKXjFAG zNt*`@GEjp5m2fQ6Gv}bI5`)NUUZNA@*H!TbsiQ8hQdBwi$bTk#`Dr$g-c`Z(QI-Us zxbSth{v!VJ*OC&aHm##|o_}t-^t{ zatLBc`Lr*Y6q)52(mZ@J-k)}L`2|`-a&!oSCcxCAGuQg#MF1# zO4(nP9?~js5{VmZm9eowc)lu}%B--Kv`QTjsE$O=CAJD?kqbfcv#b+NCs~qKk%o+8 zoOL487E3}`c#$aoD@h$2ax%7`WQoI1?L|veymCs+SH<{xN(tRml4>tvQbI#GrMgvM zqC9C3RH9HJ#4qtHB`$DMC#94)FV!)mbq`m0i4szh07XsbrSwIVlp!%BgG*1GWJ9@< zk_?8T^Xh~e#iRoiEVOJDtZ*QGMTjEKml6bW`PnQmwQyAk2`XVSB~EGNe}+9ot1@V@ zgOsH7C5R47N+LwTCy{}Dukh=`Y3MlSH9jtM_<0TMHFR*aSA?fOWJv;B$Wjqs5+<%t zleu;LT_xK&j{6GD^222I%6IUUlQD{CeS>wUYwtRCDy5TA^f(Odf#*;nem zi@K{4KYop^zl1Ld|9SDiKgzb2*!nL1@?&Wz-k#DWlh25(C`YAx zD=Dq9By_h~5)Ex8b&D(s_rF2?(PVO0SYl|%i7knSgqqk5-LRL2Sdh@5Wjvsp2#!P`?SJGYlc3lkHg`TPhn z-M4~zcjRR==2j46qa#s#SZjsv)Vg8RV$=Qm_e;@!5J#<2{Rr)KY~9F4Llk$|zAbI$ zB&^2~l4UFcJAir{D{6}%-?uc(3!3(M93CDC`N1GfUEz>OzGu}#3~_J}#6hbb2pb38 z_KVlA0Dw=eg$ChhtknRw^u^Al}siWJq_!xC&VtfgtR<^fx_eMuXcCakj4c`eS%*$qW zX#_-es@p4-)jQRSE>yr6pdzeBg1858dt+;_QuV-Amt%ohCbmVv);MpOS{&ETO#?f3 zaoEPL8(08N2YfRn-2o%$xoloAH_ZeQms$h{G}l`}m!LD#OM1Q0Y6NGjSy&E24^E@>uZ@9l^|p zVXB>F#S$qYaf%-m43^(iHx|xe z_uSVF4F?vD6?*fu1L2#Pt7#J*04T1V1kfQbI^9~UQHvYi8hw3vb5G3_+Fh?TyIV0W zZOWQnS~Fc+l>F1Knh0K~YHQ#jauU>f0pMDDIRh@%t8^PFVEMqd{@AR^j|y35UGR43KR zM40!F5a^+2Vm(A7rpJvhou*4`aS)9Aq7ifIl?^IW&PaTibg&f+e@WPTB(3c205Rpiw!FD( zwIX#X>28L$bFS2j6J2+@*aM^|y_ndr?h6wC^gLpePD<8BUoy9sUn_9lyj7`=o7IiG zrVPh4(LPfqbHZCqiYV(zDdjk*M+jB8jeu=hxRyt_a@Oq#**T%v2oMorKl|r8MSBx) zvv!WHbf1tjKCyAr3~C1wtgPj~U5mroJ~kTLu>OuU{!Y+kNrYH5K+rNzCdglN(}XVVNI>qo->EQ+{M83uASw*-wsVg#CBG7z-ASV$RYVj?=N zaV}~zK3YbS2(6^SYdtz)S;(F&Gu>3uXzFMaXrq)gA##q4XkM-Karsv5?HVr@mJEvt zEM~5ekyf+_IlYY3O#mP#A!b)tm6d51VOby1Uj0W1t$_JwHJd7#Z1i6=YayU}Oml zacSim;wJjdug$K_&CJegj^J&I8@7uXZhN4!38?i&?w_Zi2mzHi#@d9KMJ%IxukTbw zN0^+WZpS9Wd)ua3S=p|xVs1F=z9_l-k~z=d5#%`#!b7C>F4hvKx0`Xa+HNW1oXafq3P-S7`0+lnTOwEdl^ zGwFCwT^?g__N_gdm{^sBLzog|+tw*K$#$v7^_gwr<9;wj$tVm1LtyEJnq<@3CDyoB&~~ z1W^>mm&gf>g>~A>`BCgAtum8ldRibE9|0-LB(4r%*u0j=&DnvL&I*a`qzLR$3~OcO z81_XF8f9>3^WtAFdK2oMf;g=!*s?L4xfAkn*F?cw*z|KnaQ5Y_xFF z*;q5421MazZ@seR*FruJ-A&wyFN~MAg8S-`1=t3xIPG1+HWE#H%GSbFDcUI)&oZRc z3Ct^;dU^?7hUnh<1~x}M!lXJ5Wf0fuHdXC4lG_!`o6whP9DG2iU~Kg@rA+Oz0~j7B zvp^t;#K=gsvUjJdvOuG1U{hqhG%AxqYMqGmjzKfE5z9d@LZcJx-c1ck{)A)kE00bsA!EFM$x-O>Wln zvjGUp<-8zCc|nkA5|Ig?SrHaCD_aF%eRkYjGc$|hX1j{Xup7TI^(HFD-o;w+Ijxvk zkec^UBk{tTpDZ|?$A`3T*;H1S4dJ6R3)V$#U<2;(O-g128Z3nH%Nt6S#c7y4Igqkf zUq(HtvK#vW7r2`o8_Wu!oF;_|z_IY10_#MMt5?j}4ISFb@(u$9+m~&-s{+s$hK*K8 zsD?)vPSkobDraV(T2HiyVf)%e*ysMquG=sygpEPkUE-dnuTLtNW|P)2Ab5^}ojQm| zrDG+HD&z&sB&^VYQ?zA;1)*9HtXubS954%p<5D8i1gwQ6)N%c&2W++%tX>DYEUL-r zsa_~7;A5N?%fc=8Lbaj;ZZ&72rsw;>MFUsTAZD=gi9d>ds`+yb~r|>-~)_ zmrDvN?QD%7jf4AUnG>dx{SS{XMF#N;YKc3T6fIwJ3GY?ySf&Ob#x_bHN`wsri6IE7 z#)0TOA@*UMp1%mC=-lE=)WQ9j_mDq3o|%aY5~>5^nwjzS0X;(_!?{Ku<-5YPy-+UC zVFqzBqWwzRV6#BaiTgeLZY|!a#ZSq{CAK4DPd(preALsU$)(3D03-%Fxu^wumWwSv zcRK?aaH?JxZ)u%sI@Y2!PPD?N4UQlnB;Ma%T`ho#9*dHBi1nB}fkE>vXA%~3*@k@y zQekUMb)%ba8J}=WaY#h@68uaj0jC_F9MBFV=VlophtDhVJ3NE>B0HKqm33+22!Up$)u{%4I7p`Xg+~#iPe$oiIy%BsA8P|C^Wio;gs=;ey6F* z*8B(WGz0A3-AwX~|Dh%bPrc%1m^e~jLm;9x_lM(YD`Ok&lph<(tT{!<5f9-qNrKeR z&IR87aBR#BVk6^4!bJIUE(XV%q2r$&M0n1(XCXZM)CtcGBAjs~A-wq13C|BAyx@=c zw1xW|m($gZqSx$PXc;Q;g+cV0Gk77y%@<$-wMlx5{55NZy%A<8(P`N<&>1(KZziWR zGtOJEot|NH($B=Op%j2?(7-0AGtTrDmOf8FVxXIpGqQuz_YgqM!wsRF2uar&5Y$6N z+Ds_zkF+>vR6GCwK#MFwC$mhTot(}jCU4>3Q;+f<#Q@8LN&HX@@KG$pH-UZwaR=6( z&LZ^*64=L`i=TM%8)zCC!@#3Ojb_ke8XA8e(zOSf#_*u)@a{W`zZw|Z;Pa0S01t)PNz2AudvIHG(Cqd2QRCsiDX@vteqcr(U^{`XXIE>wre=% zh+AVkqmmAPADi-PnXR8CbLnhmq?;8&)l#uI^ns_TEq-k_5r+SAkddM&0QZ3|WqyF5+Hu zH!zZS;Y5la-?8UCECIoPEuoxUfOv~yVM$jly8V*yat(KQ{EY!#32SZ{!z6`0xsVyG zrVDh5Lu4PMF6|j495w1!CQlW)b8?p`cDh%i5Lzm;YX-3~BeDwwpU55S_$lcnMwc?0 ztQUCfDZRLiLvM@G+Jr?vWIIQ7YOTm)ifLow3Mp4I?Wf#;wVs+Rf7ftREF%$ydzcCC z`NNmFX#+YmEHTCm`I({Qk*eb06~!X7?d78r=FaFqi%yMom_;LVNP%#R!g20xPhB3J zTqg#nL4!@K5~pbnaVtd5zkQ&VinMSLqoM|+h&Z+Bl%iLUt`lyz|1UCzjGo09_b@)9xL#Uwq?giRX%wdwx2Vg^l#isefN%d3U!`-76H(!(i6ZD9sB@ zA9Hgv^W*MTs@CB+xhRQV1|Hu4+BfNGx<9zGUL_**L4tY0TyFCT=&^z1G=pfb=SYKhV-Y&essPD}-27Xd(tH0D5A_Q} zz{x`1`BRBIxT(reK%ULHQ5F#mrAY3Hn?Dn(U`vL*%l2M~s5i?6nxV=kL;hsFDF>%S ztFG*60zUNwZ*CQN>>}}5-$S_^X(hh-exWd610NeS0y4d*DML%P@NZ1n`(xBka<o%w2#;vw92H5W zht@cCOBX%g_J)E;G-=6Ut(~ajR|1`YyGdT|5Njuz8|5tIK#eDWy(OYVEW<};3OHya z8|;L1n-Y}O!Z3#;CeW%3NXtR5xh*AstXOfPuOvIBf$k6tm{X zxS$OotM^{T!K4K5+t_${m_~ zBf)t_e1g3^hnt~d&PiiE+bBG9qSR^9#fgmGe1)#<@TDtu?&ld+cQ`XM-^+weA=gs? zCtjX+!--gq&mP>VZtoQm{tns+g9xPKHddFrJsf>F45ML45gQU1Sq5Cm7SinPM&O)qf!~G!$EbdNh*8EY-Ldt4seizYyx21 z2CW3qApAI7h=*JH3B;(ks~#R(8%W36G0&V@cPPpuFNSFEo6ycOwQ_X4i(@YRl7RIk#K$GF;`lJ$ zqIAF$#O@Hj#8($b;gcPl>oIs7O35K!OVp2Ai09(AJ@)iuPMEPM9j1;3Bh=Xnd#Y_b zFvVS`6FkaH7X0WYN8UF#@Z@CSzB@8*kHLF0MPdU`i{eMRsV|qpgdz@qza-t{fU>Sj z^gDDeJ5K$`v=NH0!;7iq|Fh^+8;N|gCI<&-sMKNcJdoaz8$fI<3$`kiqphe;ljLm|N-(0#hP6v-2y5mT|e zNYVj*B&Qm{h059qH7jb-z!v@cVGNuZ8;>tocfq5B`XUGQT}^dxr1K>+Iq%L4-~{G8 z_MKO^O&@1!{9L}vk_no**iBN%9%o^LO|^#;c?drQ9{8bWnh;D@Toj^6>yZr;4_%)p z;nK5B`|yW3*Obv@Z4O3=Z1MfL6hPLpvDi1j{bcc=^52)#67psicV0BhyX!Di*?+(h z5K4{>U}pivEVX_WrO3tLh)a-By-YS#CG$wXvEX{aoMT{|wyl_O)fY`6JxtvL%nhFF z&)XQev(3VNox0C@bpu2L)guH3YA7Wl6KEPqJdIf93$X-mjTVwUht@PKKp%DC7mdv! zqvNw)nVi9mk+F`09F#X?2Tkn#LsptY2kg_mc-X>-KW>jBnXt${#geMIpCb+G!{u#V{pXhxZDdS87zIbz!O&0l_Q&LW=`<;O>gOxCQoimS7HNY?bD^50HlF(z5Ai z;66%$aX67{rz5wPkQq8+`Rv&((k)(T4$e52vyZ+fd654mOest8MpZm+ae|O1o`5+)cU#f)rDpWE>;< z&ZpAt+HpYUJwV&iIX}S-_yDF!G8m;WEO{k{SK2!YI|UTbZrkvqwdje*FO>`uAD9U# zWV=HTc%}(^N6H)lI;9StOA8v>5fb5{PuE!<#gmOa(4>sU((Sw<%pnY4&R>skl@D|) zUBn;-B0GU@{|L-_yk6sTqRHKr*=mC+eBp{l5 z8rsvehbSFcnQj@%l|(wt+m8L%G=BHTZik7%+adF!_q{>U``$xDZ^0|!+hO%Wtsv;< z(GTC472MpP8MKD)K{##r?wz=T4rVS-blTND-8!2pp-RXsQ+Ui40=+zJi?(H#XK+*= z5|8mXw!ACgl0fRfY%q0~Li8~MWM@!t#Ar1*YB;KOkRZTi;eHN08zNMaWZt$jz=+;s zeJq&)ORgo3IGst&C2F$Q*?(Zzpm)YZuLbLr22d zfa7qYeU_*nVXh*ylYwK>&VSiy&A#lg1le+%u_FR@U2VvsWSkfrvVr1Q#e2EBK`IRA zCj*C>=*UJ&r_$aq=_7?RcyTh)cQ_qzQte5LA-8+*lA%!&st3qrfsk0T{>K_bIiS8g z3<5R{gSKNoHUw2cCK)Geh6-?U8^Wb#>6zU>sOS=4dGi(S6S!qC8IsJ}4^OP5YYZKq z?WJ!+z-Emc5lD|!^fr^IJ$0d}s3XuX2kvg-Wm>XR%maLw7zSmd+1rXEd?k?CK_0Y| zz79ycz2Oc7y=iZ;tnDnH+vaO0M2U1gx5D^l4qIeUApq`4%ZnoH zTPgtFj1bSJ<>h(y{bEEicrz`1ORL!TZTFtC;XM)%yxCRzxc8Y|(8qx!ecT&(*(ce@ zvZ(bPwngJ#uKT2LqAky?qi=_dd2@A;(CY8x19SQc^x_{