summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLars-Dominik Braun <lars@6xq.net>2016-09-30 16:57:23 +0200
committerLars-Dominik Braun <lars@6xq.net>2016-09-30 16:59:06 +0200
commit724cc003460ec67eda269911da85c9f9e40aa6cf (patch)
tree14e27b45e04279516e4be546b15dcf6fafe17268
downloadeumel-src-724cc003460ec67eda269911da85c9f9e40aa6cf.tar.gz
eumel-src-724cc003460ec67eda269911da85c9f9e40aa6cf.tar.bz2
eumel-src-724cc003460ec67eda269911da85c9f9e40aa6cf.zip
Add extracted sources from floppy disk images
Some files have no textual representation (yet) and were added as raw dataspaces.
-rw-r--r--at/AT Generator135
-rw-r--r--at/AT Utilities1057
-rw-r--r--at/AT install93
-rw-r--r--basic/BASIC.Administration1886
-rw-r--r--basic/BASIC.Compiler2305
-rw-r--r--basic/BASIC.Runtime1571
-rw-r--r--basic/eumel coder 1.8.13086
-rw-r--r--basic/eumel0 codesbin0 -> 512 bytes
-rw-r--r--basic/gen.BASIC80
-rw-r--r--datatype/complex115
-rw-r--r--datatype/longint423
-rw-r--r--datatype/matrix482
-rw-r--r--datatype/vector213
-rw-r--r--dialog/ls-DIALOG 160
-rw-r--r--dialog/ls-DIALOG 277
-rw-r--r--dialog/ls-DIALOG 348
-rw-r--r--dialog/ls-DIALOG 471
-rw-r--r--dialog/ls-DIALOG 5118
-rw-r--r--dialog/ls-DIALOG 6102
-rw-r--r--dialog/ls-DIALOG 754
-rw-r--r--dialog/ls-DIALOG MENUKARTEN MANAGER28
-rw-r--r--dialog/ls-DIALOG MM-gen27
-rw-r--r--dialog/ls-DIALOG decompress150
-rw-r--r--dialog/ls-DIALOG-gen34
-rw-r--r--dialog/ls-MENUKARTE:Archivbin0 -> 40960 bytes
-rw-r--r--doc/basic/basic handbuch.11075
-rw-r--r--doc/basic/basic handbuch.22441
-rw-r--r--doc/basic/basic handbuch.3698
-rw-r--r--doc/basic/basic handbuch.index232
-rw-r--r--doc/dialog/gs-dialog handbuch.impressum89
-rw-r--r--doc/dialog/gs-dialog-1107
-rw-r--r--doc/dialog/gs-dialog-2215
-rw-r--r--doc/dialog/gs-dialog-3683
-rw-r--r--doc/dialog/gs-dialog-4672
-rw-r--r--doc/dialog/gs-dialog-5176
-rw-r--r--doc/dialog/gs-dialog-Inhaltsverzeichnis45
-rw-r--r--doc/dynamo/dynamo handbuch1826
-rw-r--r--doc/dynamo/dynamo handbuch.index69
-rw-r--r--doc/dynamo/dynamo handbuch.inhalt131
-rw-r--r--doc/eudas/abb.1-194
-rw-r--r--doc/eudas/abb.4-143
-rw-r--r--doc/eudas/abb.4-246
-rw-r--r--doc/eudas/abb.6-175
-rw-r--r--doc/eudas/abb.6-277
-rw-r--r--doc/eudas/abb.7-146
-rw-r--r--doc/eudas/abb.9-141
-rw-r--r--doc/eudas/abb.9-296
-rw-r--r--doc/eudas/abb.9-3113
-rw-r--r--doc/eudas/abb.9-498
-rw-r--r--doc/eudas/abb.9-551
-rw-r--r--doc/eudas/bildergenerator25
-rw-r--r--doc/eudas/eudas.hdb.1267
-rw-r--r--doc/eudas/eudas.hdb.10510
-rw-r--r--doc/eudas/eudas.hdb.11674
-rw-r--r--doc/eudas/eudas.hdb.12446
-rw-r--r--doc/eudas/eudas.hdb.13757
-rw-r--r--doc/eudas/eudas.hdb.14724
-rw-r--r--doc/eudas/eudas.hdb.15286
-rw-r--r--doc/eudas/eudas.hdb.16350
-rw-r--r--doc/eudas/eudas.hdb.2178
-rw-r--r--doc/eudas/eudas.hdb.3515
-rw-r--r--doc/eudas/eudas.hdb.5386
-rw-r--r--doc/eudas/eudas.hdb.6394
-rw-r--r--doc/eudas/eudas.hdb.7687
-rw-r--r--doc/eudas/eudas.hdb.8211
-rw-r--r--doc/eudas/eudas.hdb.9556
-rw-r--r--doc/eudas/eudas.hdb.inhalt133
-rw-r--r--doc/eudas/eudas.hdb.macros80
-rw-r--r--doc/eudas/eudas.hdb.titel99
-rw-r--r--doc/eudas/eudas.hdb.vorwort89
-rw-r--r--doc/eudas/eudas.ref.1326
-rw-r--r--doc/eudas/eudas.ref.10406
-rw-r--r--doc/eudas/eudas.ref.11347
-rw-r--r--doc/eudas/eudas.ref.2830
-rw-r--r--doc/eudas/eudas.ref.3270
-rw-r--r--doc/eudas/eudas.ref.4441
-rw-r--r--doc/eudas/eudas.ref.5432
-rw-r--r--doc/eudas/eudas.ref.6399
-rw-r--r--doc/eudas/eudas.ref.7447
-rw-r--r--doc/eudas/eudas.ref.8454
-rw-r--r--doc/eudas/eudas.ref.9194
-rw-r--r--doc/eudas/eudas.ref.fehler139
-rw-r--r--doc/eudas/eudas.ref.inhalt120
-rw-r--r--doc/eudas/eudas.ref.macros73
-rw-r--r--doc/eudas/eudas.ref.proz205
-rw-r--r--doc/eudas/eudas.ref.reg436
-rw-r--r--doc/eudas/eudas.ref.titel91
-rw-r--r--doc/eudas/eudas.ref.vorwort81
-rw-r--r--doc/eudas/ref.abb.1-142
-rw-r--r--doc/eudas/register490
-rw-r--r--doc/eudas/uedas.hdb.4686
-rw-r--r--doc/graphic/Altes Handbuch - Teil 10 - Graphik831
-rw-r--r--doc/graphic/GRAPHIK.book897
-rw-r--r--doc/graphic/graphik beschreibung661
-rw-r--r--doc/hamster/A5 - Doku: gs-Herbert und Robbi - Inhaltsverzeichnis45
-rw-r--r--doc/hamster/A5 - Doku: gs-Herbert und Robbi - Kapitel 193
-rw-r--r--doc/hamster/A5 - Doku: gs-Herbert und Robbi - Kapitel 2389
-rw-r--r--doc/hamster/A5 - Doku: gs-Herbert und Robbi - Kapitel 3199
-rw-r--r--doc/hamster/A5 - Doku: gs-Herbert und Robbi - Kapitel 41312
-rw-r--r--doc/hamster/A5 - Doku: gs-Herbert und Robbi - Kapitel 5167
-rw-r--r--doc/hamster/A5 - Doku: gs-Herbert und Robbi - Kapitel 673
-rw-r--r--doc/hamster/gs-Herbert und Robbi handbuch.impressum87
-rw-r--r--doc/lisp/lisp handbuch2260
-rw-r--r--doc/menugenerator/menu-generator handbuch.1100
-rw-r--r--doc/menugenerator/menu-generator handbuch.287
-rw-r--r--doc/menugenerator/menu-generator handbuch.3155
-rw-r--r--doc/menugenerator/menu-generator handbuch.4424
-rw-r--r--doc/menugenerator/menu-generator handbuch.5975
-rw-r--r--doc/menugenerator/menu-generator handbuch.6235
-rw-r--r--doc/menugenerator/menu-generator handbuch.7367
-rw-r--r--doc/menugenerator/menu-generator handbuch.81676
-rw-r--r--doc/menugenerator/menu-generator handbuch.impressum88
-rw-r--r--doc/menugenerator/menu-generator handbuch.index258
-rw-r--r--doc/menugenerator/menu-generator handbuch.inhalt72
-rw-r--r--doc/mp-bap/A5 - Doku: gs-MP BAP - Inhaltsverzeichnis50
-rw-r--r--doc/mp-bap/A5 - Doku: gs-MP BAP - Kapitel 1119
-rw-r--r--doc/mp-bap/A5 - Doku: gs-MP BAP - Kapitel 2302
-rw-r--r--doc/mp-bap/A5 - Doku: gs-MP BAP - Kapitel 3237
-rw-r--r--doc/mp-bap/A5 - Doku: gs-MP BAP - Kapitel 4638
-rw-r--r--doc/mp-bap/A5 - Doku: gs-MP BAP - Kapitel 5699
-rw-r--r--doc/mp-bap/A5 - Doku: gs-MP BAP - Kapitel 653
-rw-r--r--doc/mp-bap/gs-MP BAP handbuch.impressum104
-rw-r--r--doc/programming/programmierhandbuch.1650
-rw-r--r--doc/programming/programmierhandbuch.2a1845
-rw-r--r--doc/programming/programmierhandbuch.2b1395
-rw-r--r--doc/programming/programmierhandbuch.3728
-rw-r--r--doc/programming/programmierhandbuch.41692
-rw-r--r--doc/programming/programmierhandbuch.51329
-rw-r--r--doc/programming/programmierhandbuch.5b1481
-rw-r--r--doc/programming/programmierhandbuch.61441
-rw-r--r--doc/programming/programmierhandbuch.index449
-rw-r--r--doc/programming/programmierhandbuch.inhalt249
-rw-r--r--doc/programming/programmierhandbuch.titel52
-rw-r--r--doc/prolog/prolog handbuch581
-rw-r--r--doc/prozess/Anhang Prozess92
-rw-r--r--doc/prozess/Inhalt Prozess84
-rw-r--r--doc/prozess/gs-Prozess handbuch.impressum104
-rw-r--r--doc/prozess/gs-Prozess-2255
-rw-r--r--doc/prozess/gs-Prozess-3346
-rw-r--r--doc/prozess/gs-Prozess-4173
-rw-r--r--doc/prozess/gs-prozess-199
-rw-r--r--doc/prozess/gs-prozess-5819
-rw-r--r--doc/prozess/gs-prozess-6641
-rw-r--r--doc/prozess/gs-prozess-71121
-rw-r--r--doc/prozess/gs-prozess-8377
-rw-r--r--doc/prozess/gs-prozess-9477
-rw-r--r--doc/system/systemhandbuch.11685
-rw-r--r--doc/system/systemhandbuch.21351
-rw-r--r--doc/system/systemhandbuch.31366
-rw-r--r--doc/system/systemhandbuch.41185
-rw-r--r--doc/user/benutzerhandbuch.1580
-rw-r--r--doc/user/benutzerhandbuch.2443
-rw-r--r--doc/user/benutzerhandbuch.32019
-rw-r--r--doc/user/benutzerhandbuch.42242
-rw-r--r--doc/user/benutzerhandbuch.5a1446
-rw-r--r--doc/user/benutzerhandbuch.5b1632
-rw-r--r--doc/user/benutzerhandbuch.5c711
-rw-r--r--doc/user/benutzerhandbuch.5d211
-rw-r--r--doc/user/benutzerhandbuch.5e223
-rw-r--r--doc/user/benutzerhandbuch.6474
-rw-r--r--doc/user/benutzerhandbuch.anhang484
-rw-r--r--doc/warenhaus/Anhang Warenhaus65
-rw-r--r--doc/warenhaus/Inhalt Warenhaus50
-rw-r--r--doc/warenhaus/gs-Warenhaus handbuch.impressum89
-rw-r--r--doc/warenhaus/gs-Warenhaus-1124
-rw-r--r--doc/warenhaus/gs-Warenhaus-272
-rw-r--r--doc/warenhaus/gs-Warenhaus-3309
-rw-r--r--doc/warenhaus/gs-Warenhaus-4378
-rw-r--r--doc/warenhaus/gs-Warenhaus-51468
-rw-r--r--doc/warenhaus/gs-Warenhaus-6589
-rw-r--r--doc/warenhaus/gs-Warenhaus-7235
-rw-r--r--dos/block i-o180
-rw-r--r--dos/dir.dos693
-rw-r--r--dos/disk descriptor.dos339
-rw-r--r--dos/dos hd inserter41
-rw-r--r--dos/dos inserter59
-rw-r--r--dos/dos-dat-handbuch650
-rw-r--r--dos/dump49
-rw-r--r--dos/eu disk descriptor107
-rw-r--r--dos/fat.dos369
-rw-r--r--dos/fetch371
-rw-r--r--dos/fetch save interface70
-rw-r--r--dos/get put interface.dos368
-rw-r--r--dos/insert.dos14
-rw-r--r--dos/konvert75
-rw-r--r--dos/manager-M.dos211
-rw-r--r--dos/manager-S.dos268
-rw-r--r--dos/name conversion.dos77
-rw-r--r--dos/open66
-rw-r--r--dos/save233
-rw-r--r--dos/shard interface20
-rw-r--r--dynamo/dyn.332073
-rw-r--r--dynamo/dyn.abnahme19
-rw-r--r--dynamo/dyn.bev50
-rw-r--r--dynamo/dyn.cob19
-rw-r--r--dynamo/dyn.delaytest8
-rw-r--r--dynamo/dyn.errors68
-rw-r--r--dynamo/dyn.forest47
-rw-r--r--dynamo/dyn.forst776
-rw-r--r--dynamo/dyn.gekoppeltependel19
-rw-r--r--dynamo/dyn.grashasenfuchs42
-rw-r--r--dynamo/dyn.help24
-rw-r--r--dynamo/dyn.inserter54
-rw-r--r--dynamo/dyn.mac44
-rw-r--r--dynamo/dyn.mehreredelays9
-rw-r--r--dynamo/dyn.natchez14
-rw-r--r--dynamo/dyn.oszillator26
-rw-r--r--dynamo/dyn.plot235
-rw-r--r--dynamo/dyn.plot+729
-rw-r--r--dynamo/dyn.print43
-rw-r--r--dynamo/dyn.proc160
-rw-r--r--dynamo/dyn.quadrat13
-rw-r--r--dynamo/dyn.rts376
-rw-r--r--dynamo/dyn.ruestungswettlauf32
-rw-r--r--dynamo/dyn.simon28
-rw-r--r--dynamo/dyn.std9
-rw-r--r--dynamo/dyn.steifedgl15
-rw-r--r--dynamo/dyn.tool217
-rw-r--r--dynamo/dyn.vec209
-rw-r--r--dynamo/dyn.wachstum19
-rw-r--r--dynamo/dyn.wasseröko64
-rw-r--r--dynamo/dyn.welt-forrester124
-rw-r--r--dynamo/dyn.wohnen105
-rw-r--r--dynamo/dyn.workfluc44
-rw-r--r--dynamo/dyn.wurzel14
-rw-r--r--dynamo/out.world43
-rw-r--r--eudas/Adressenbin0 -> 3584 bytes
-rw-r--r--eudas/dummy.text14
-rw-r--r--eudas/eudas.152
-rw-r--r--eudas/eudas.262
-rw-r--r--eudas/eudas.358
-rw-r--r--eudas/eudas.4150
-rw-r--r--eudas/eudas.generator86
-rw-r--r--eudas/eudas.init1463
-rw-r--r--eudas/pos.17319
-rw-r--r--graphic/Beispiel.Kreuz41
-rw-r--r--graphic/Beispiel.Sinus45
-rw-r--r--graphic/GRAPHIK.Picfile738
-rw-r--r--graphic/GRAPHIK.Plot285
-rw-r--r--graphic/GRAPHIK.Plotter247
-rw-r--r--graphic/GRAPHIK.Server97
-rw-r--r--graphic/GRAPHIK.Transform366
-rw-r--r--graphic/GRAPHIK.vektor plot506
-rw-r--r--graphic/HP7475.plot254
-rw-r--r--graphic/PC.plot758
-rw-r--r--graphic/ZEICHENSATZbin0 -> 11776 bytes
-rw-r--r--graphic/gen Graphik16
-rw-r--r--graphic/gen Plotter16
-rw-r--r--graphic/graphik editor324
-rw-r--r--hamster/ls-Herbert und Robbi 184
-rw-r--r--hamster/ls-Herbert und Robbi 231
-rw-r--r--hamster/ls-Herbert und Robbi 384
-rw-r--r--hamster/ls-Herbert und Robbi-gen33
-rw-r--r--hamster/ls-MENUKARTE:Herbert und Robbibin0 -> 94720 bytes
-rw-r--r--lisp/lisp.11306
-rw-r--r--lisp/lisp.2584
-rw-r--r--lisp/lisp.3767
-rw-r--r--lisp/lisp.4143
-rw-r--r--lisp/lisp.bootstrap118
-rw-r--r--menugenerator/Generatordatei: Archivmenu323
-rw-r--r--menugenerator/fonttab.ls-Menu-Generatorbin0 -> 2560 bytes
-rw-r--r--menugenerator/ls-MENUBASISTEXTEbin0 -> 17408 bytes
-rw-r--r--menugenerator/ls-Menu-Generator 147
-rw-r--r--menugenerator/ls-Menu-Generator 272
-rw-r--r--menugenerator/ls-Menu-Generator-gen30
-rw-r--r--mp-bap/ls-MENUKARTE:MP-BAPbin0 -> 79872 bytes
-rw-r--r--mp-bap/ls-MP BAP 1119
-rw-r--r--mp-bap/ls-MP BAP 2126
-rw-r--r--mp-bap/ls-MP BAP-gen30
-rw-r--r--net/basic net1148
-rw-r--r--net/net files-M5
-rw-r--r--net/net hardware interface389
-rw-r--r--net/net inserter145
-rw-r--r--net/net manager797
-rw-r--r--net/net report41
-rw-r--r--net/netz20
-rw-r--r--net/netzhandbuch2045
-rw-r--r--net/netzhandbuch.anhang58
-rw-r--r--net/netzhandbuch.index259
-rw-r--r--net/port server164
-rw-r--r--net/printer server99
-rw-r--r--net/spool cmd112
-rw-r--r--net/spool manager915
-rw-r--r--printer/dotmatrix24/beschreibungen2462
-rw-r--r--printer/dotmatrix24/fonttab.brotherbin0 -> 38400 bytes
-rw-r--r--printer/dotmatrix24/fonttab.epson.lq1500bin0 -> 35840 bytes
-rw-r--r--printer/dotmatrix24/fonttab.epson.lq850bin0 -> 38400 bytes
-rw-r--r--printer/dotmatrix24/fonttab.nec.p5bin0 -> 39936 bytes
-rw-r--r--printer/dotmatrix24/fonttab.nec.p5.newbin0 -> 39936 bytes
-rw-r--r--printer/dotmatrix24/fonttab.nec.p6+bin0 -> 48128 bytes
-rw-r--r--printer/dotmatrix24/fonttab.okibin0 -> 38400 bytes
-rw-r--r--printer/dotmatrix24/fonttab.toshiba.p321bin0 -> 15872 bytes
-rw-r--r--printer/dotmatrix24/inserter793
-rw-r--r--printer/dotmatrix24/module241554
-rw-r--r--printer/dotmatrix24/printer.24.nadel776
-rw-r--r--printer/dotmatrix24/readme320
-rw-r--r--printer/dotmatrix9/beschreibungen997
-rw-r--r--printer/dotmatrix9/fonttab.1bin0 -> 11264 bytes
-rw-r--r--printer/dotmatrix9/fonttab.10bin0 -> 15872 bytes
-rw-r--r--printer/dotmatrix9/fonttab.20bin0 -> 36864 bytes
-rw-r--r--printer/dotmatrix9/fonttab.20.lcbin0 -> 36864 bytes
-rw-r--r--printer/dotmatrix9/fonttab.20.lxbin0 -> 24576 bytes
-rw-r--r--printer/dotmatrix9/fonttab.7bin0 -> 46080 bytes
-rw-r--r--printer/dotmatrix9/fonttab.7.cxpbin0 -> 46080 bytes
-rw-r--r--printer/dotmatrix9/fonttab.7.fujbin0 -> 56832 bytes
-rw-r--r--printer/dotmatrix9/fonttab.7.mtbin0 -> 46080 bytes
-rw-r--r--printer/dotmatrix9/module91099
-rw-r--r--printer/dotmatrix9/printer.neun.nadel1129
-rw-r--r--printer/dotmatrix9/readme324
-rw-r--r--printer/laser/fonttab.apple.laserwriterbin0 -> 100864 bytes
-rw-r--r--printer/laser/fonttab.canon.lbp-8bin0 -> 58368 bytes
-rw-r--r--printer/laser/fonttab.epson.sqbin0 -> 29696 bytes
-rw-r--r--printer/laser/fonttab.hp.laserjetbin0 -> 24064 bytes
-rw-r--r--printer/laser/fonttab.kyocera.f-1010bin0 -> 71168 bytes
-rw-r--r--printer/laser/fonttab.nec.lc-08bin0 -> 38400 bytes
-rw-r--r--printer/laser/genfont.kyocera.f-1010.dynamic130
-rw-r--r--printer/laser/genfont.kyocera.f-1010.dynamic230
-rw-r--r--printer/laser/laser.inserter275
-rw-r--r--printer/laser/printer.apple.laserwriter770
-rw-r--r--printer/laser/printer.canon.lbp-8327
-rw-r--r--printer/laser/printer.epson.sq585
-rw-r--r--printer/laser/printer.hp.laserjet417
-rw-r--r--printer/laser/printer.kyocera.f-1010373
-rw-r--r--printer/laser/printer.nec.lc-08626
-rw-r--r--printer/laser/readme155
-rw-r--r--prolog/calc32
-rw-r--r--prolog/family29
-rw-r--r--prolog/permute15
-rw-r--r--prolog/prieks58
-rw-r--r--prolog/prolog2488
-rw-r--r--prolog/prolog installation117
-rw-r--r--prolog/puzzle24
-rw-r--r--prolog/quicksort14
-rw-r--r--prolog/standard35
-rw-r--r--prolog/sum13
-rw-r--r--prolog/thesaurus360
-rw-r--r--prolog/topographie59
-rw-r--r--prozess/ls-MENUKARTE:Prozessbin0 -> 62464 bytes
-rw-r--r--prozess/ls-Prozess 1 für AKTRONIC-Adapter57
-rw-r--r--prozess/ls-Prozess 1 für MUFI als Endgerät57
-rw-r--r--prozess/ls-Prozess 1 für MUFI im Terminalkanal55
-rw-r--r--prozess/ls-Prozess 239
-rw-r--r--prozess/ls-Prozess 326
-rw-r--r--prozess/ls-Prozess 461
-rw-r--r--prozess/ls-Prozess 584
-rw-r--r--prozess/ls-Prozess-gen146
-rw-r--r--system/crypt138
-rw-r--r--system/eumel printer.53473
-rw-r--r--system/eumelmeter131
-rw-r--r--system/font convertor 91095
-rw-r--r--system/free channel430
-rw-r--r--system/port server164
-rw-r--r--system/printer server99
-rw-r--r--system/purge85
-rw-r--r--system/referencer1077
-rw-r--r--system/reporter531
-rw-r--r--system/scheduler420
-rw-r--r--system/spool cmd178
-rw-r--r--system/spool manager1058
-rw-r--r--system/std analysator68
-rw-r--r--tecal/TeCal856
-rw-r--r--tecal/TeCal Auskunftbin0 -> 45056 bytes
-rw-r--r--tecal/TeCal.gen55
-rw-r--r--warenhaus/ls-MENUKARTE:Warenhausbin0 -> 60928 bytes
-rw-r--r--warenhaus/ls-Warenhaus 0: mit Kartenleser an AKTRONIC-Adapter36
-rw-r--r--warenhaus/ls-Warenhaus 0: mit Kartenleser an MUFI als Endgerät36
-rw-r--r--warenhaus/ls-Warenhaus 0: mit Kartenleser an MUFI im Terminalkanal30
-rw-r--r--warenhaus/ls-Warenhaus 0: ohne Kartenleser27
-rw-r--r--warenhaus/ls-Warenhaus 137
-rw-r--r--warenhaus/ls-Warenhaus 2112
-rw-r--r--warenhaus/ls-Warenhaus 382
-rw-r--r--warenhaus/ls-Warenhaus 448
-rw-r--r--warenhaus/ls-Warenhaus 5103
-rw-r--r--warenhaus/ls-Warenhaus-gen29
374 files changed, 134225 insertions, 0 deletions
diff --git a/at/AT Generator b/at/AT Generator
new file mode 100644
index 0000000..d3bfd6d
--- /dev/null
+++ b/at/AT Generator
@@ -0,0 +1,135 @@
+(*************************************************************************)
+(*** Generiert Für IBM-AT einen neuen SYSUR-Zweig. ***)
+(*** Danach wird die eingebaute Hardwareuhr für die Systemzeit benutzt ***)
+(*** und andere Partitionen können mit neuem 'shutup' gebootet werden. ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+LET ack = 0,
+ nak = 1;
+
+cl eop (1, 4);
+erzeuge collector;
+erzeuge archive manager;
+erzeuge operator;
+erzeuge configurator;
+loesche collector;
+forget ("AT Generator", quiet);
+break.
+
+loesche collector :
+ end (/"colly");
+ put ("Collector gelöscht.");
+ line (2).
+
+erzeuge collector :
+ put line ("Generating 'Collector'...");
+ begin ("colly", PROC generate collector, t);
+ warte auf meldung;
+ IF answer = nak THEN end (/"colly");
+ errorstop (meldung)
+ FI.
+ TASK VAR t.
+
+erzeuge archive manager :
+ put line ("Generating 'ARCHIVE'...");
+ end (/"ARCHIVE");
+ begin ("ARCHIVE", PROC archive manager, t).
+
+erzeuge operator :
+ put line ("Generating 'OPERATOR'...");
+ end (/"OPERATOR");
+ begin ("OPERATOR", PROC monitor, t).
+
+erzeuge configurator :
+ put line ("Generating 'configurator'...");
+ end (/"configurator");
+ begin ("configurator", PROC generate configurator, t);
+ warte auf meldung;
+ IF answer = nak THEN errorstop (meldung) FI.
+
+warte auf meldung :
+ DATASPACE VAR ds; INT VAR answer;
+ wait (ds, answer, t);
+ BOUND TEXT VAR m := ds;
+ TEXT VAR meldung := m;
+ forget (ds).
+
+PROC generate collector :
+
+ disable stop;
+ fetch all (/"configurator");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ free global manager.
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate collector;
+
+PROC generate configurator :
+
+ disable stop;
+ fetch all (/"colly");
+ DATASPACE VAR ds := nilspace;
+ BOUND TEXT VAR m := ds; m := "";
+ send (father, mess, ds);
+ forget (ds);
+ enable stop;
+ new configuration;
+ setup;
+ global manager (PROC ( DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time).
+
+mess : IF is error THEN m := error message;
+ nak
+ ELSE ack FI.
+
+END PROC generate configurator;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
diff --git a/at/AT Utilities b/at/AT Utilities
new file mode 100644
index 0000000..760e728
--- /dev/null
+++ b/at/AT Utilities
@@ -0,0 +1,1057 @@
+(*************************************************************************)
+(*** AT-spezifische Software, die zum Lesen der Hardwareuhr und ***)
+(*** Booten in anderen Partitionen benötigt wird. ***)
+(*** ***)
+(*** Zusammengestellt und geändert : Werner Sauerwein, GMD ***)
+(*** Stand : 31.10.86 ***)
+(*************************************************************************)
+
+PACKET splitting DEFINES low byte, (* Copyright (C) 1985 *)
+ high byte, (* Martin Schönbeck, Spenge *)
+ low word, (* Stand: 13.09.85 *)
+ high word:
+
+INT PROC high byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 2)
+
+END PROC high byte;
+
+INT PROC low byte (INT CONST value):
+
+ TEXT VAR x := " ";
+ replace (x, 1, value);
+ code (x SUB 1)
+
+END PROC low byte;
+
+INT PROC high word (REAL CONST double precission int):
+
+ int (double precission int / 65536.0)
+
+END PROC high word;
+
+INT PROC low word (REAL CONST double precission int):
+
+ string of low bytes ISUB 1.
+
+string of low bytes:
+ code (int (double precission int MOD 256.0)) +
+ code (int ((double precission int MOD 65536.0) / 256.0)).
+
+END PROC low word;
+
+END PACKET splitting;
+
+
+PACKET basic block io DEFINES
+
+ read block,
+ write block:
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, 0, block no, return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ INT CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, 0, block no, return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds, INT CONST ds page,
+ REAL CONST archive block):
+
+ enable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+
+END PROC write block;
+
+PROC read block (DATASPACE VAR ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ read block;
+ retry if read error.
+
+read block:
+ block in (ds, ds page no, high word (block no),
+ low word (block no), return code).
+
+retry if read error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ read block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN block in (ds, ds page no, 0, 0, return code)
+ FI.
+
+END PROC read block;
+
+PROC write block (DATASPACE CONST ds,
+ INT CONST ds page no,
+ REAL CONST block no,
+ INT VAR return code):
+ write block;
+ retry if write error.
+
+write block:
+ block out (ds, ds page no, high word (block no),
+ low word (block no), return code).
+
+retry if write error:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP
+ reset to block 0 if fifth try;
+ write block
+ PER.
+
+reset to block 0 if fifth try:
+ IF retry = 5
+ THEN disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ block in (dummy ds, 2, 0, 0, return code);
+ forget (dummy ds);
+ enable stop
+ FI.
+
+END PROC write block;
+
+END PACKET basic block io;
+
+
+PACKET utilities DEFINES getchoice, cleol, cleop, inverse, put center:
+
+INT PROC get choice (INT CONST von, bis, TEXT VAR retchar):
+ get choice (von, bis, von, retchar)
+END PROC get choice;
+
+INT PROC get choice (INT CONST von, bis, zusatz, TEXT VAR retchar):
+ LET return = ""13"",
+ escape = ""27"",
+ left = ""8"";
+ TEXT VAR buffer;
+ INT VAR cx, cy;
+ get cursor (cx, cy); out (" " + left);
+ REP
+ REP
+ cursor (cx, cy); buffer := incharety;
+ UNTIL input ok OR buffer = escape PER;
+ IF buffer = escape THEN retchar := escape;
+ LEAVE get choice WITH 0
+ FI;
+ out (buffer);
+ leseschleife bis left or ret;
+ IF retchar = left THEN out (left + " ") FI;
+ IF retchar = escape THEN LEAVE get choice WITH 0 FI
+ UNTIL retchar = return OR retchar = escape PER;
+ int (buffer).
+
+input ok : (buffer >= text (von) AND buffer <= text (bis)) OR buffer = text (zusatz).
+
+leseschleife bis left or ret:
+ REP
+ inchar (retchar)
+ UNTIL retchar = return OR retchar = left OR retchar = escape PER.
+
+END PROC get choice;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+END PACKET utilities
+
+
+PACKET part DEFINES activate, show actual partition table:
+ (* Copyright (C) 1985 *)
+ (* Martin Schönbeck, Spenge *)
+ (* Stand : 02.02.86 *)
+ (* Changed by : W.Sauerwein *)
+ (* I.Ley *)
+ (* Stand : 03.10.86 *)
+ LET fd channel = 28;
+
+ROW 256 INT VAR boot block;
+INT VAR boot block session := session - 1;
+
+PROC get boot block:
+ IF boot block session <> session
+ THEN hole aktuellen boot block
+ FI.
+
+hole aktuellen boot block:
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ get external block (dummy ds, 2, 0, fd channel);
+ IF NOT is error
+ THEN transfer data to boot block
+ FI;
+ forget (dummy ds).
+
+transfer data to boot block:
+ IF not valid boot block
+ THEN try to get valid boot block from file
+ FI;
+ boot block := partition table. block;
+ boot block session := session.
+
+not valid boot block:
+ partition table. block [256] <> boot indicator OR
+ it is an old boot block of eumel.
+
+boot indicator: -21931.
+
+it is an old boot block of eumel:
+ partition table. block [1] = 1514.
+
+try to get valid boot block from file:
+ forget (dummy ds);
+ partition table := old ("bootblock");
+ IF is error THEN LEAVE transfer data to boot block FI.
+
+END PROC get boot block;
+
+PROC put boot block:
+ IF boot block ist uptodate
+ THEN schreibe block auf platte
+ ELSE errorstop ("boot block nicht uptodate")
+ FI.
+
+boot block ist uptodate:
+ boot block session = session.
+
+schreibe block auf platte:
+ disable stop;
+ DATASPACE VAR dummy ds := nilspace;
+ BOUND STRUCT (ALIGN dummy,
+ ROW 256 INT block) VAR partition table := dummy ds;
+ transfer data to dataspace;
+ put external block (dummy ds, 2, 0, fd channel);
+ forget (dummy ds).
+
+transfer data to dataspace:
+ partition table. block := boot block.
+
+END PROC put boot block;
+
+INT PROC partition type (INT CONST partition):
+ low byte (boot block [entry (partition) + 2])
+END PROC partition type;
+
+REAL PROC partition start (INT CONST partition):
+ unsigned low word + high word.
+
+unsigned low word:
+ real (low byte (boot block [entry (partition) + 4])) +
+ real (high byte (boot block [entry (partition) + 4])) * 256.0.
+
+high word:
+ real (boot block [entry (partition) + 5]).
+
+END PROC partition start;
+
+INT PROC partition word 0 (INT CONST partition):
+ boot block (entry (partition))
+END PROC partition word 0;
+
+INT PROC first track (INT CONST partition):
+ high byte (boot block [entry (partition) + 1])
+ + 4 * (low byte (boot block [entry (partition) + 1]) AND (128 + 64))
+END PROC first track;
+
+INT PROC last track (INT CONST partition):
+ high byte (boot block [entry (partition) + 3])
+ + 4 * (low byte (boot block [entry (partition) + 3]) AND (128 + 64))
+END PROC last track;
+
+BOOL PROC partition activ (INT CONST partition):
+ low byte (boot block [entry (partition)]) = 128
+END PROC partition activ;
+
+REAL PROC partition size (INT CONST partition):
+ unsigned low word + high word.
+
+unsigned low word:
+ real (low byte (boot block [entry (partition) + 6])) +
+ real (high byte (boot block [entry (partition) + 6])) * 256.0.
+
+high word:
+ real (boot block [entry (partition) + 7]).
+
+END PROC partition size;
+
+INT PROC tracks:
+ get value (-10, fd channel)
+END PROC tracks;
+
+PROC activate (INT CONST part type):
+ IF partition type exists AND is possible type
+ THEN deactivate all partitions and
+ activate desired partition
+ ELSE errorstop ("Gewünschte Partitionart gibt es nicht")
+ FI.
+
+is possible type:
+ part type > 0 AND
+ part type < 256.
+
+partition type exists:
+ INT VAR partition;
+ FOR partition FROM 1 UPTO 4 REP
+ IF partition type (partition) = part type
+ THEN LEAVE partition type exists WITH TRUE
+ FI;
+ PER;
+ FALSE.
+
+deactivate all partitions and activate desired partition:
+ FOR partition FROM 1 UPTO 4 REP
+ deactivate this partition;
+ IF partition type (partition) = part type
+ THEN activate partition
+ FI
+ PER;
+ put boot block.
+
+deactivate this partition:
+ set bit (boot block [entry (partition)], 7);
+ (* first setting needed, because reset bit does xor *)
+ reset bit (boot block [entry (partition)], 7).
+
+activate partition:
+ set bit (boot block [entry (partition)], 7)
+
+END PROC activate;
+
+INT PROC entry (INT CONST partition):
+ get boot block;
+ 256 - 5 * 8 + (partition * 8)
+END PROC entry;
+
+INT PROC get value (INT CONST control code, channel for value):
+ enable stop;
+ INT VAR old channel := channel;
+ continue (channel for value);
+ INT VAR value;
+ control (control code, 0, 0, value);
+ continue (old channel);
+ value
+END PROC get value;
+
+PROC get external block (DATASPACE VAR ds, INT CONST ds page,
+ archive block, get channel):
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ read block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht gelesen werden");
+ CASE 2: error stop ("Lesefehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+END PROC get external block;
+
+PROC put external block (DATASPACE CONST ds, INT CONST ds page,
+ archive block, get channel):
+ INT VAR old channel := channel;
+ continue (get channel);
+ disable stop;
+ write block (ds, ds page, archive block, error);
+ INT VAR error;
+ SELECT error OF
+ CASE 0:
+ CASE 1: error stop ("Platte kann nicht geschrieben werden");
+ CASE 2: error stop ("Schreibfehler bei Block "+ text (archive block));
+ CASE 3: error stop ("Versorgungsfehler Archiv");
+ OTHERWISE error stop ("unbekannter Fehler auf Platte");
+ END SELECT;
+ continue (old channel).
+END PROC put external block;
+
+(**************************************************************************)
+
+ LET max partitions = 4;
+ ROW max partitions INT VAR part list;
+ ROW max partitions INT VAR part type, part active,
+ part first track, part last track;
+ ROW max partitions REAL VAR part start,
+ part size;
+ INT VAR zylinder,
+ startzeile tabelle :: 1,
+ active partition,
+ partitions,
+ partition, i, j, help;
+
+
+PROC get actual partition data :
+ get boot block;
+ zylinder := tracks;
+ FOR i FROM 1 UPTO max partitions REP
+ part type (i) := partition type (i);
+ part first track (i) := first track (i);
+ part last track (i) := last track (i);
+ part start (i) := partition start (i);
+ part size (i) := partition size (i);
+ part active (i) := partition word 0 (i);
+ IF partition activ (i) THEN active partition := i FI
+ PER;
+ get number of installed partitions;
+ generate part list.
+
+get number of installed partitions :
+ partitions := 0;
+ FOR i FROM 1 UPTO max partitions REP
+ IF part type (i) <> 0 THEN partitions INCR 1 FI
+ PER.
+
+generate part list :
+ FOR i FROM 1 UPTO max partitions REP
+ IF part type (i) <> 0 THEN part list (i) := i
+ ELSE part list (i) := 0
+ FI;
+ PER;
+ schiebe nullen nach hinten;
+ sort part list.
+
+schiebe nullen nach hinten :
+ i := 1; INT VAR k := 0;
+ REP k INCR 1;
+ IF part list (i) = 0 THEN circle
+ ELSE i INCR 1
+ FI
+ UNTIL k = max partitions - 1 PER.
+
+circle :
+ FOR j FROM i UPTO max partitions - 1 REP
+ part list (j) := part list (j + 1)
+ PER;
+ part list (max partitions) := 0.
+
+sort part list :
+ FOR i FROM 2 UPTO partitions REP
+ FOR j FROM 1 UPTO i - 1 REP
+ IF part first track (part list (i)) < part first track (part list (j))
+ THEN tausche FI
+ PER
+ PER.
+
+tausche :
+ help := part list (i);
+ part list (i) := part list (j);
+ part list (j) := help.
+
+END PROC get actual partition data;
+
+
+PROC show partition table :
+ headline;
+ devide table;
+ columns;
+ underlines;
+ rows;
+ footlines.
+
+head line :
+ cl eop (1, startzeile tabelle);
+ put center (inverse (" "
+ + "Aktuelle Partitions - Tabelle"
+ + " ")).
+
+devide table :
+ FOR i FROM 1 UPTO 8
+ REP
+ cursor (50, startzeile tabelle + i); out (inverse (""))
+ PER.
+
+columns :
+ cursor ( 1, startzeile tabelle + 2);
+ out (" Nr. System Typ-Nr. Zustand Größe Start Ende");
+ cursor (54, startzeile tabelle + 2);
+ out ("Plattengröße / Zylinder ").
+
+underlines :
+ cursor ( 1, startzeile tabelle + 3);
+ out ("-------------------------------------------------");
+ cursor (52, startzeile tabelle + 3);
+ out ("--------------------------").
+
+rows :
+ FOR i FROM 1 UPTO max partitions
+ REP cursor (2, startzeile tabelle + 3 + i);
+ put (text (i) + " :")
+ PER.
+
+footlines:
+ cursor (1, startzeile tabelle + 9);
+ put center (inverse (75 * " ")).
+
+END PROC show partition table;
+
+PROC update table :
+ get actual partition data;
+ FOR i FROM 1 UPTO partitions REP update partition PER;
+ FOR i FROM partitions + 1 UPTO max partitions REP rubout partition PER;
+ zeige plattengroesse.
+
+update partition :
+ partition := part list (i);
+ show partition.
+
+rubout partition :
+ cursor (6, startzeile tabelle + 3 + i);
+ out (" ").
+
+show partition :
+ cursor (6, startzeile tabelle + 3 + i);
+ put (name + type + zustand + groesse + startspur + endspur).
+
+name : subtext (subtext (part name, 1, 9)
+ + " ", 1, 10).
+
+type : text (part type (partition), 5) + " ".
+
+zustand : IF active partition = partition THEN (" aktiv ")
+ ELSE (" ")
+ FI.
+
+startspur : " " + text (part first track (partition), 5).
+endspur : text (part last track (partition), 6).
+groesse : text (part groesse, 5).
+
+zeige plattengroesse :
+ put gesamt;
+ put noch freie;
+ put maximaler zwischenraum.
+
+put maximaler zwischenraum :
+ cursor (54, startzeile tabelle + 6);
+ put ("max. zusammenh. : " + text (maximaler zwischenraum, 4)).
+
+put gesamt :
+ cursor (54, startzeile tabelle + 4);
+ put ("insgesamt : " + text (zylinder, 4)).
+
+put noch freie :
+ cursor (54, startzeile tabelle + 5);
+ put ("davon noch frei : " + text (freie zylinder, 4)).
+
+part groesse :
+ partition groesse (partition).
+
+part name :
+ SELECT part type (partition) OF
+ CASE 1 : "DOS"
+ CASE 69, 70, 71, 72 : "EUMEL"
+ OTHERWISE text (part type (partition))
+ END SELECT.
+
+freie zylinder :
+ zylinder - belegte zylinder.
+
+belegte zylinder :
+ help := 0;
+ FOR i FROM 1 UPTO partitions REP
+ help INCR partition groesse (part list (i))
+ PER;
+ help.
+
+END PROC update table;
+
+INT PROC maximaler zwischenraum :
+ IF partitions = 0 THEN zylinder
+ ELSE max (maximaler platz vor und zwischen den partitionen,
+ platz hinter letzter partition)
+ FI.
+
+maximaler platz vor und zwischen den partitionen :
+ help := platz vor erster partition;
+ FOR i FROM 1 UPTO partitions - 1
+ REP
+ help := max (help, begin of part i plus 1 - end of part i - 1)
+ PER;
+ help.
+
+platz vor erster partition :
+ part first track (part list (1)).
+
+platz hinter letzter partition :
+ zylinder - part last track (part list (partitions)) - 1.
+
+begin of part i plus 1 :
+ part first track (part list (i + 1)).
+
+end of part i :
+ part last track (part list (i)).
+
+END PROC maximaler zwischenraum;
+
+INT PROC partition groesse (INT CONST part) :
+ part last track (part) - part first track (part) + 1
+END PROC partition groesse;
+
+PROC show actual partition table:
+ show partition table;
+ update table;
+ line (4)
+END PROC show actual partition table;
+
+PROC show actual partition table (ROW max partitions INT VAR typnr):
+ show actual partition table;
+ FOR i FROM 1 UPTO max partitions REP
+ typnr (i) := partition type (part list (i))
+ PER;
+END PROC show actual partition table;
+
+END PACKET part;
+
+
+PACKET hw clock DEFINES hw clock: (* Copyright (C) 1985 *)
+ (* Martin Schönbeck, Spenge *)
+LET clock length = 7, (* Stand: 06.11.85 *)
+ clock command = 4;
+
+BOUND STRUCT (ALIGN dummy,
+ ROW clock length INT clock field) VAR clock data;
+
+REAL PROC hw clock:
+
+ disable stop;
+ get clock;
+ hw date + hw time.
+
+get clock:
+ DATASPACE VAR ds := nilspace;
+ clock data := ds;
+ INT VAR return code, actual channel := channel;
+ go to shard channel;
+ blockin (ds, 2, -clock command, 0, return code);
+ IF actual channel = 0 THEN break (quiet)
+ ELSE continue (actual channel)
+ FI;
+ IF return code <> 0
+ THEN errorstop ("Keine Hardware Uhr vorhanden");
+ FI;
+ put clock into text;
+ forget (ds).
+
+put clock into text:
+ TEXT VAR clock text := clock length * " ";
+ INT VAR i;
+ FOR i FROM 1 UPTO clock length REP
+ replace (clock text, i, clock data. clock field [i]);
+ PER.
+
+go to shard channel:
+ INT VAR retry;
+ FOR retry FROM 1 UPTO 20 REP
+ continue (32);
+ IF is error
+ THEN clear error;
+ pause (30)
+ FI;
+ UNTIL channel = 32 PER.
+
+hw date:
+ date (day + "." + month + "." + year).
+
+day: subtext (clock text, 7, 8).
+
+month: subtext (clock text, 5, 6).
+
+year: subtext (clock text, 1, 4).
+
+hw time:
+ time (hour + ":" + minute + ":" + second).
+
+hour: subtext (clock text, 9, 10).
+
+minute: subtext (clock text, 11, 12).
+
+second: subtext (clock text, 13, 14).
+
+END PROC hw clock;
+
+END PACKET hw clock
+
+
+PACKET old shutup DEFINES old shutup, (* Copyright (C) 1985 *)
+ old save system: (* Martin Schönbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC old shutup : shutup END PROC old shutup;
+
+PROC old save system : save system END PROC old save system;
+
+END PACKET old shutup;
+
+
+PACKET new shutup DEFINES shutup,
+ shutup dialog,
+ save system,
+ generate shutup manager,
+ generate shutup dialog manager:
+
+LET ack = 0;
+
+PROC shutup:
+
+ system down (PROC old shutup)
+
+END PROC shutup;
+
+PROC shutup (INT CONST new system):
+
+ IF new system <> 0
+ THEN prepare for new system
+ FI;
+ system down (PROC old shutup).
+
+prepare for new system:
+ activate (new system);
+ prepare for rebooting.
+
+prepare for rebooting:
+ INT VAR old channel := channel;
+ continue (32);
+ INT VAR dummy;
+ control (-5, 0, 0, dummy);
+ break (quiet);
+ continue (old channel).
+
+END PROC shutup;
+
+PROC save system:
+
+ IF yes ("Leere Floppy eingelegt")
+ THEN system down (PROC old save system)
+ FI
+
+END PROC save system;
+
+PROC system down (PROC operation):
+
+ BOOL VAR dialogue :: command dialogue;
+ command dialogue (FALSE);
+ operation;
+ command dialogue (dialogue);
+ IF command dialogue
+ THEN wait for configurator;
+ show date;
+ FI.
+
+show date:
+ page;
+ line (2);
+ put (" Heute ist der"); putline (date);
+ put (" Es ist"); put (time of day); putline ("Uhr");
+ line (2).
+
+END PROC system down;
+
+DATASPACE VAR ds := nilspace;
+
+PROC wait for configurator:
+
+ INT VAR i, receipt;
+ FOR i FROM 1 UPTO 20 WHILE configurator exists REP
+ pause (30);
+ forget (ds);
+ ds := nilspace;
+ ping pong (configurator, ack, ds, receipt)
+ UNTIL receipt >= 0 PER.
+
+configurator exists:
+ disable stop;
+ TASK VAR configurator := task ("configurator");
+ clear error;
+ NOT is niltask (configurator).
+
+END PROC wait for configurator;
+
+PROC generate shutup manager:
+
+ generate shutup manager ("shutup", 0);
+
+END PROC generate shutup manager;
+
+PROC generate shutup manager (TEXT CONST name, INT CONST new system):
+
+ TASK VAR son;
+ shutup question := name;
+ new system for manager := new system;
+ begin (name, PROC shutup manager, son)
+
+END PROC generate shutup manager;
+
+INT VAR new system for manager;
+TEXT VAR shutup question;
+
+PROC shutup manager:
+
+ disable stop;
+ command dialogue (TRUE);
+ REP
+ break;
+ line ;
+ IF yes (shutup question)
+ THEN clear error;
+ shutup (new system for manager);
+ pause (300);
+ FI;
+ PER
+
+END PROC shutup manager;
+
+PROC shutup dialog:
+ init;
+ show actual partition table (typnr);
+ REP
+ enter part number;
+ get cursor (cx, cy);
+ IF NOT escaped CAND yes (shutup question)
+ THEN message;
+ shutup (partition type);
+ LEAVE shutup dialog
+ FI;
+ PER.
+
+shutup question:
+ IF partition null
+ THEN "Shutup ausführen"
+ ELSE "Shutup nach Partition mit Typnummer " + text (typnr (partition)) + " ausführen"
+ FI.
+
+message:
+ cl eol (1, cy);
+ put line ("Bitte auf ENDE - Meldung warten !").
+
+partition type:
+ IF partition = 0
+ THEN 0
+ ELSE typnr (partition)
+ FI.
+
+init:
+ LET startzeile menu = 12,
+ escape = ""27"",
+ max partitions = 4;
+
+ ROW max partitions INT VAR typnr;
+ INT VAR partition, cx, cy;
+ TEXT VAR retchar.
+
+partition null:
+ partition = 0 COR typnr (partition) = 0.
+
+enter part number :
+ cl eop (1, startzeile menu);
+ cursor (54, startzeile menu ); put ("Abbruch mit <ESC>");
+ cursor (54, startzeile menu + 1); put ("Shutup ohne Wechsel mit <0>");
+ cursor ( 1, startzeile menu);
+ put ("Zu welcher Partition wollen Sie wechseln :");
+ get cursor (cx, cy);
+ REP
+ REP cursor (cx, cy);
+ partition := get choice (0, 4, retchar);
+ IF sure escaped THEN LEAVE shutup dialog FI;
+ UNTIL NOT escaped PER;
+ IF partition <> 0 CAND NOT partition exists
+ THEN fehler;
+ put ("Diese Partition gibt es nicht")
+ FI;
+ UNTIL partition = 0 OR partition exists PER;
+ cl eol (54, startzeile menu);
+ cl eol (54, startzeile menu + 1);
+ cl eop (1, cy + 2).
+
+partition exists:
+ typnr (partition) <> 0.
+
+escaped :
+ retchar = escape.
+
+sure escaped :
+ IF escaped THEN cl eop (1, 20); cursor (1, 22);
+ IF yes ("Shutup-Dialog abbrechen") THEN TRUE
+ ELSE cl eop (1, 20);
+ FALSE
+ FI
+ ELSE FALSE
+ FI.
+
+fehler :
+ cl eop (1, 20);
+ put (""7"" + inverse ("FEHLER :")); line (2).
+
+END PROC shutup dialog;
+
+PROC generate shutup dialog manager:
+ TASK VAR son;
+ begin ("shutup dialog", PROC shutup dialog manager, son)
+END PROC generate shutup dialog manager;
+
+PROC shutup dialog manager:
+ disable stop;
+ command dialogue (TRUE);
+ REP
+ break; line;
+ clear error;
+ INT VAR sess := session;
+ shutup dialog;
+ IF sess <> session THEN pause (300) FI;
+ PER;
+END PROC shutup dialog manager;
+
+END PACKET new shutup
+
+
+PACKET config manager with time DEFINES configuration manager ,
+ configuration manager with time :
+ (* Copyright (C) 1985 *)
+INT VAR old session := 0; (* Martin Schönbeck, Spenge *)
+ (* Stand: 06.11.85 *)
+PROC configuration manager:
+
+ configurate;
+ break;
+ global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
+ configuration manager with time)
+
+END PROC configuration manager;
+
+PROC configuration manager with time (DATASPACE VAR ds, INT CONST order,
+ phase, TASK CONST order task):
+
+ IF old session <> session
+ THEN
+ disable stop;
+ set clock (hw clock);
+ set clock (hw clock); (* twice, to avoid all paging delay *)
+ IF is error THEN IF online THEN put error; clear error; pause (100)
+ ELSE clear error
+ FI FI;
+ old session := session;
+ set autonom;
+ FI;
+ configuration manager (ds, order, phase, order task);
+
+END PROC configuration manager with time;
+
+END PACKET config manager with time;
+
diff --git a/at/AT install b/at/AT install
new file mode 100644
index 0000000..11f9b55
--- /dev/null
+++ b/at/AT install
@@ -0,0 +1,93 @@
+(*************************************************************************)
+(*** Insertiert alle notwendigen Pakete, damit ein AT-System generiert ***)
+(*** werden kann, das die Hardwareuhr lesen und Partitionen bedienen ***)
+(*** kann. Startet den "AT Generator". ***)
+(*** ***)
+(*** Autor : W. Sauerwein Stand : 15.07.86 ***)
+(*************************************************************************)
+
+erste bildschirmmeldung;
+IF ich bin single THEN putline ("Die AT-spezifische Software ist nur auf Multi-User-Systemen benutzbar !")
+ ELSE hole dateien vom archiv;
+ insertiere alle pakete;
+ put line ("Running ""AT Generator""...");
+ run ("AT Generator")
+FI;
+forget ("AT install", quiet).
+
+ich bin single : (pcb (9) AND 255) <= 1.
+
+insertiere alle pakete :
+ insert and say ("AT Utilities").
+
+erste bildschirmmeldung :
+ page;
+ put center (" Generator für AT-spezifische Software gestartet."); line;
+ put center ("--------------------------------------------------");
+ line (2).
+
+hole dateien vom archiv :
+ TEXT VAR datei;
+ datei := "AT Utilities"; hole wenn noetig;
+ datei := "AT Generator"; hole wenn noetig;
+ release (archive);
+ line.
+
+hole wenn noetig :
+ IF NOT exists (datei) THEN
+ put line ("Loading """ + datei + """...");
+ fetch (datei, archive)
+ FI.
+
+PROC insert and say (TEXT CONST datei) :
+
+ INT VAR cx, cy;
+ put line ("Inserting """ + datei + """...");
+ get cursor (cx, cy);
+ insert (datei);
+ cl eop (cx, cy); line;
+ forget (datei, quiet).
+
+END PROC insert and say;
+
+TEXT PROC inverse (TEXT CONST t):
+ ""15"" + t + " " + ""14""
+END PROC inverse;
+
+PROC put center (TEXT CONST t):
+ put center (t, 80)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t):
+ put center (zeile, t, 80)
+END PROC put center;
+
+PROC put center (TEXT CONST t, INT CONST gesamtbreite):
+ INT VAR cy;
+ get cursor (cy, cy);
+ put center (cy, t, gesamtbreite)
+END PROC put center;
+
+PROC put center (INT CONST zeile, TEXT CONST t, INT CONST gesamtbreite):
+ cursor ((gesamtbreite - length (t)) DIV 2, zeile);
+ put (t).
+END PROC put center;
+
+PROC cl eol:
+ out (""5"")
+END PROC cl eol;
+
+PROC cl eop:
+ out (""4"")
+END PROC cl eop;
+
+PROC cl eol (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eol
+END PROC cl eol;
+
+PROC cl eop (INT CONST cx, cy):
+ cursor (cx, cy);
+ cl eop
+END PROC cl eop;
+
diff --git a/basic/BASIC.Administration b/basic/BASIC.Administration
new file mode 100644
index 0000000..6df6854
--- /dev/null
+++ b/basic/BASIC.Administration
@@ -0,0 +1,1886 @@
+(***************************************************************************)
+(* *)
+(* Zweite von drei Dateien des EUMEL-BASIC-Systems *)
+(* *)
+(* Autor: Heiko Indenbirken *)
+(* Überarbeitet von: Rudolf Ruland und Michael Overdick *)
+(* *)
+(* Stand: 27.10.1987 *)
+(* *)
+(***************************************************************************)
+
+PACKET basic errors DEFINES basic error, (* Autor: Heiko Indenbirken *)
+ return error, (* Stand: 26.08.1987/rr/mo *)
+ basic warning:
+
+TEXT VAR erste zeile,
+ message;
+LET errorsize = 40;
+LET ERROR = STRUCT (INT no, TEXT msg);
+
+ROW errorsize ERROR CONST error msg :: ROW errorsize ERROR :
+(ERROR:( 1, "NEXT ohne FOR"),
+ ERROR:( 2, "Syntaxfehler:"),
+ ERROR:( 5, "Fehlerhafter Funktionsaufruf"),
+ ERROR:( 8, "Zeile mit dieser Nummer existiert nicht"),
+ ERROR:(10, "Das Feld ist bereits dimensioniert"),
+ ERROR:(13, "Falscher Typ:"),
+ ERROR:(15, "Text zu lang"),
+ ERROR:(18, "Undefinierte 'user function'"),
+ ERROR:(22, "Ausdruck erwartet"),
+ ERROR:(26, "FOR ohne NEXT"),
+ ERROR:(29, "WHILE ohne WEND"),
+ ERROR:(30, "WEND ohne WHILE"),
+ ERROR:(51, "Interner Fehler"),
+ ERROR:(80, "Fehlerhafte Zeilennummer"),
+ ERROR:(81, "Falsche Reihenfolge der Zeilennummern"),
+ ERROR:(82, "Falscher Typ des Operanden:"),
+ ERROR:(83, "Falscher Typ der Operanden:"),
+ ERROR:(84, "Falsche Felddimension:"),
+ ERROR:(85, "Rekursive Funktionsdefinition"),
+ ERROR:(86, "Fehlerhafte Laufvariable:"),
+ ERROR:(87, "Fehlerhafte Bereichsangabe:"),
+ ERROR:(88, "Fehlerhafte Dimensionierung:"),
+ ERROR:(89, "Parametervariable kommt mehrmals vor"),
+ ERROR:(90, "AS ohne NAME"),
+ ERROR:(91, "BASE ohne OPTION"),
+ ERROR:(92, "ELSE ohne IF"),
+ ERROR:(93, "STEP ohne FOR"),
+ ERROR:(94, "TAB ohne (L)PRINT"),
+ ERROR:(95, "THEN ohne IF"),
+ ERROR:(96, "TO ohne Zusammenhang"),
+ ERROR:(97, "USING ohne (L)PRINT"),
+ ERROR:(98, "Unbekannte Funktion,"),
+ ERROR:(99, "Unbekannte Prozedur,"),
+ ERROR:(100,"Nicht implementiert"),
+ ERROR:(101,"SUB ohne GO"),
+ ERROR:(102,"GO ohne TO oder SUB"),
+ ERROR:(103,"Accessrecht VAR erwartet, CONST gefunden"),
+ ERROR:(104,"Funktionsaufruf ohne Zusammenhang"),
+ ERROR:(105,"Nach OPTION BASE ist nur 0 oder 1 erlaubt"),
+ ERROR:(106,"Bei SWAP nur gleiche Variablentypen erlaubt"));
+
+TEXT PROC errortext (INT CONST no):
+ INT VAR i;
+ FOR i FROM 1 UPTO errorsize
+ REP IF errormsg [i].no = no
+ THEN LEAVE errortext WITH errormsg [i].msg FI
+ PER;
+ "Unbekannter BASIC-Fehler #" + text (no) .
+END PROC errortext;
+
+PROC basic error (TEXT CONST packet,
+ INT CONST error nr,
+ INT CONST line nr,
+ INT CONST statement nr,
+ TEXT CONST position, addition,
+ BOOL CONST leave statement):
+ erste zeile aufbauen;
+ einfache fehlermeldung aufbauen;
+ diese auf terminal ausgeben;
+ diese in sysout datei ausgeben wenn noetig; (* F20/rr *)
+ fehlermeldung in fehlerdatei ausgeben;
+ IF leave statement (* DEF/mo *)
+ THEN errorstop (101, packet + "-Fehler")
+ FI.
+
+erste zeile aufbauen:
+ IF line nr = 0 AND statement nr = 0
+ THEN erste zeile := "FEHLER"
+ ELSE erste zeile := "FEHLER (Dateizeile ";
+ erste zeile CAT text (line nr);
+ erste zeile CAT ") in Zeile ";
+ erste zeile CAT text (statement nr);
+ FI;
+
+ erste zeile CAT " bei >> ";
+ erste zeile CAT position;
+ erste zeile CAT " << : " .
+
+einfache fehlermeldung aufbauen:
+ message := " ";
+ message CAT error text (error nr);
+ message CAT " " .
+
+diese auf terminal ausgeben: (* F20/rr *)
+ display (""13""10"");
+ display (erste zeile);
+ display (""13""10"");
+ display (message + addition);
+ display (""13""10"") .
+
+diese in sysout datei ausgeben wenn noetig : (* F20/rr *)
+ IF sysout <> ""
+ THEN putline (erste zeile);
+ putline (message + addition);
+ line;
+ FI .
+
+fehlermeldung in fehlerdatei ausgeben:
+ note (erste zeile);
+ note line;
+ note (message);
+ note (addition);
+ note line .
+
+END PROC basic error;
+
+PROC basic warning (INT CONST line nr, (* mo *)
+ statement nr,
+ TEXT CONST warning text):
+generate warning;
+on screen;
+in sysout file;
+into the notebook.
+
+generate warning:
+ IF line nr = 0 AND statement nr = 0
+ THEN erste zeile := "WARNUNG"
+ ELSE erste zeile := "WARNUNG (Dateizeile ";
+ erste zeile CAT text (line nr);
+ erste zeile CAT ") in Zeile ";
+ erste zeile CAT text (statement nr);
+ FI;
+ erste zeile CAT ": ";
+ erste zeile CAT warning text.
+
+on screen:
+ display (""13""10"");
+ display (erste zeile);
+ display (""13""10"").
+
+in sysout file:
+ IF sysout <> ""
+ THEN putline (erste zeile);
+ line;
+ FI.
+
+into the notebook:
+ IF warnings
+ THEN note (erste zeile);
+ note line
+ FI.
+
+END PROC basic warning;
+
+PROC return error:
+ errorstop (1003, "RETURN ohne GOSUB")
+END PROC return error;
+
+END PACKET basic errors;
+
+PACKET basic types DEFINES symbol of, (* Autor: Heiko Indenbirken *)
+ type of, (* Stand: 07.09.1987/rr/mo *)
+ dim of,
+ shift, deshift,
+ reserved,
+ param list,
+ is bool op:
+
+LET (* S y m b o l T y p e n *)
+ any = 0, const = 1, var = 2, array = 3,
+ expr = 4, unused = 5, letter = 6, param = 7,
+ res word = 8, operator = 9, eos = 10, del = 11,
+ stat no = 12, eol = 13, eop = 14,
+ user fn = 20; (* DEF/mo *)
+(* Operatoren *)
+LET less equal = 28, unequal = 29, greater equal = 30;
+
+TEXT VAR dummy;
+
+TEXT PROC symbol of (INT CONST n) :
+ IF n < 0
+ THEN ""19"" + symbol of (-n)
+ ELSE SELECT n OF
+ CASE less equal : "<="
+ CASE unequal : "<>"
+ CASE greater equal : ">="
+
+ CASE eos : "EOS"
+ CASE eol : "EOL"
+ CASE eop : "EOF"
+ OTHERWISE : character END SELECT
+ FI .
+
+character :
+ IF n > 32 AND n < 128
+ THEN code (n)
+ ELIF n >= 128 AND n <= 255
+ THEN res word of (n)
+ ELSE "%" + subtext (text (n+1000), 2) + " " FI .
+
+END PROC symbol of;
+
+TEXT PROC type of (INT CONST n) :
+ SELECT n OF
+ CASE any : "ANY"
+ CASE const : "Konstante"
+ CASE var : "Variable"
+ CASE array : "Feld"
+ CASE expr : "Ausdruck"
+ CASE unused : " -?- "
+ CASE letter : "Buchstabe"
+ CASE param : "Parameter"
+ CASE res word : "reserviertes Wort"
+ CASE operator : "Operator"
+ CASE eos : "EOS"
+ CASE del : "Trennzeichen"
+ CASE stat no : "Zeilennumer"
+ CASE eol : "EOL"
+ CASE eop : "EOF"
+ CASE user fn : "'user function'" (* DEF/mo *)
+ OTHERWISE "?TYPE #" + text (n) ENDSELECT.
+END PROC type of;
+
+TEXT PROC dim of (TEXT CONST parameter):
+ IF parameter = ""
+ THEN ""
+ ELSE base limits and size FI .
+
+base limits and size:
+ INT CONST dimension :: (LENGTH parameter DIV 2) - 2;
+ TEXT VAR result :: text (parameter ISUB dimension+1);
+ INT VAR i;
+ result CAT ": [";
+ FOR i FROM 1 UPTO dimension-1
+ REP result CAT text (parameter ISUB i);
+ result CAT ", "
+ PER;
+ result CAT text (parameter ISUB dimension);
+ result CAT "] ";
+ result CAT text (parameter ISUB dimension+2);
+ result .
+
+END PROC dim of;
+
+TEXT PROC param list (INT CONST first, no):
+ IF no < first
+ THEN "keine"
+ ELSE parameter list FI .
+
+parameter list:
+ INT VAR i;
+ TEXT VAR result :: "(";
+ FOR i FROM first UPTO no
+ REP result CAT dump (dtype (i));
+ IF i = no
+ THEN result CAT ")"
+ ELSE result CAT ", " FI
+ PER;
+ result .
+
+END PROC param list;
+
+TEXT PROC shift (TEXT CONST word) :
+ INT VAR i;
+ dummy := word;
+ FOR i FROM 1 UPTO length (word)
+ REP shift char PER;
+ dummy .
+
+shift char:
+ INT VAR local letter :: code (dummy SUB i);
+ IF 97 <= local letter AND local letter <= 122
+ THEN replace (dummy, i, code (local letter - 32)) FI .
+
+END PROC shift;
+
+TEXT PROC deshift (TEXT CONST word) :
+ INT VAR i;
+ dummy := word;
+ FOR i FROM 1 UPTO length (word)
+ REP deshift char PER;
+ dummy .
+
+deshift char:
+ INT VAR local letter :: code (dummy SUB i);
+ IF 65 <= local letter AND local letter <= 90
+ THEN replace (dummy, i, code (local letter + 32)) FI;
+
+END PROC deshift;
+
+(* Verwaltung der Reservierten BASIC-Wörter *)
+LET first operator = 249, (* MOD NOT AND OR XOR EQV IMP *)
+ first bool op = 250; (* 249 250 251 252 253 254 255 *)
+
+INT VAR index;
+ROW 9 TEXT VAR res words :: ROW 9 TEXT :
+("",
+ ""129"as"163"go"167"if"188"on"217"to"252"or",
+ ""128"abs"130"asc"131"atn"141"cos"142"cvd"143"cvi"145"def"150"dim"152"end"153"eof"154"erl"155"err"157"exp"159"fix"160"for"161"fre"162"get"172"int"175"len"176"let"178"loc"179"log"191"out"192"pos"194"put"202"rnd"197"rem"204"sgn"205"sin"207"spc"208"sqr"214"tab"215"tan"221"val"227"cls"234"usr"235"sub"249"mod"250"not"251"and"253"xor"254"eqv"255"imp",
+ ""132"base"133"call"134"cdbl"136"chr$"137"cint"144"data"151"else"165"goto"166"hex$"173"kill"177"line"181"lset"182"mid$"183"mkd$"184"mki$"185"name"186"next"187"oct$"189"open"196"read"203"rset"209"step"210"stop"211"str$"213"swap"216"then"219"tron"222"wait"223"wend"228"erm$"230"lpos",
+ ""135"chain"138"clear"139"close"156"error"158"field"164"gosub"169"input"171"instr"174"left$"193"print"218"troff"220"using"224"while"225"width"226"write"231"time$"232"date$"233"timer",
+ ""140"common"146"defdbl"147"defint"148"defsng"149"defstr"168"inkey$"170"input$"180"lprint"190"option"199"resume"200"return"201"right$"206"space$"229"csrlin",
+ ""198"restore"212"string$",
+ "",
+ ""195"randomize");
+
+BOOL PROC reserved (TEXT CONST name, INT VAR no, type):
+ IF reserve is not possible COR not found within res words
+ THEN FALSE
+ ELSE no := code (this words SUB (index-1));
+ type := res word or op;
+ TRUE
+ FI .
+
+reserve is not possible:
+ INT CONST len :: length (name);
+ len < 2 OR len > 9 .
+
+not found within res words:
+ index := pos (this words, name);
+ index = 0 .
+
+this words:
+ res words [len] .
+
+res word or op:
+ IF no >= first operator
+ THEN operator
+ ELSE res word FI .
+
+END PROC reserved;
+
+INT PROC reserved (TEXT CONST name):
+ IF reserve is not possible COR not found within res words
+ THEN 0
+ ELSE code (this words SUB (index-1)) FI .
+
+reserve is not possible:
+ INT CONST len :: length (name);
+ len < 2 OR len > 9 .
+
+not found within res words:
+ index := pos (this words, name);
+ index = 0 .
+
+this words:
+ res words [len] .
+
+END PROC reserved;
+
+TEXT PROC res word of (INT CONST no):
+ INT VAR i;
+ FOR i FROM 2 UPTO 9
+ REP index := pos (res words [i], code (no));
+ IF index > 0
+ THEN LEAVE res word of WITH shift (this name) FI
+ PER;
+ "" .
+
+this name:
+ subtext (res words [i], index+1, next code) .
+
+next code:
+ INT VAR c := pos (res words [i], ""127"", ""255"", index+1);
+ IF c = 0
+ THEN length (res words [i])
+ ELSE c-1 FI .
+
+END PROC res word of;
+
+BOOL PROC is bool op (INT CONST no): (* mo *)
+ no >= first bool op
+END PROC is bool op;
+
+END PACKET basic types;
+
+PACKET basic table handling DEFINES init table, (* Autor: Heiko Indenbirken *)
+ put name, (* Stand: 13.08.1987/rr/mo *)
+ known, name of,
+ remember,
+ recognize,
+ table entries,
+ hash table, next table,
+ scope compulsory: (* DEF/mo *)
+
+LET hash length = 1024,
+ hash length minus one = 1023,
+ start of name table = 256,
+ table length = 4500;
+
+LET SYMBOL = STRUCT (INT type, ADDRESS adr, DTYPE data, TEXT dim);
+LET TABLE = STRUCT (INT entries,
+ ROW hash length INT hash table,
+ ROW table length INT next,
+ ROW table length TEXT name table,
+ ROW table length SYMBOL symbol table);
+
+DATASPACE VAR table space;
+BOUND TABLE VAR table;
+INITFLAG VAR tab := FALSE;
+SYMBOL CONST nilsymbol :: SYMBOL:(0, LOC 0, void type, "");
+INT VAR i;
+BOOL VAR compulsory with scope :: TRUE; (* DEF/mo *)
+
+PROC init table:
+ IF NOT initialized (tab)
+ THEN table space := nilspace;
+ table := table space;
+ FI;
+ table.entries := start of name table;
+ FOR i FROM 1 UPTO hash length
+ REP table.hash table [i] := 0 PER;
+ compulsory with scope := TRUE; (* DEF/mo *)
+
+END PROC init table;
+
+PROC put name (TEXT CONST scope, name, INT VAR pointer): (* DEF/mo *)
+ IF compulsory with scope
+ THEN put name (scope + name, pointer)
+ ELIF NOT in table
+ THEN put name (name, pointer)
+ FI.
+
+in table:
+ hash (scope + name, pointer);
+ pointer := hash table (pointer);
+ WHILE not end of chain
+ REP IF name is found THEN LEAVE in table WITH TRUE FI;
+ pointer := table. next (pointer);
+ PER;
+ FALSE .
+
+name is found:
+ table.name table [pointer] = scope + name.
+
+not end of chain:
+ pointer > 0 .
+
+END PROC put name;
+
+PROC put name (TEXT CONST name, INT VAR pointer):
+ IF no entry in hash table
+ THEN create a new chain
+ ELSE create a new entry in chain FI;
+ insert name in name table .
+
+no entry in hash table:
+ INT VAR hash index;
+ hash (name, hash index);
+ table.hash table [hash index] = 0 .
+
+create a new chain:
+ table.hash table [hash index] := table.entries .
+
+create a new entry in chain:
+ pointer := table.hash table [hash index];
+ REP IF name is found
+ THEN LEAVE put name
+ ELIF end of chain
+ THEN table.next [pointer] := table.entries;
+ LEAVE create a new entry in chain
+ ELSE pointer := next pointer FI
+ PER .
+
+name is found:
+ table.name table [pointer] = name.
+
+end of chain:
+ INT CONST next pointer := table.next [pointer];
+ next pointer = 0 .
+
+insert name in name table:
+ IF table.entries >= table length
+ THEN errorstop ("volle Namenstabelle") FI;
+
+ pointer := table.entries;
+ table.symbol table [pointer] := nilsymbol;
+ table.name table [pointer] := name;
+ table.next [pointer] := 0;
+ table.entries INCR 1 .
+
+END PROC put name;
+
+PROC hash (TEXT CONST name, INT VAR index) :
+ INT VAR j;
+ index := 0;
+ FOR j FROM 1 UPTO length (name)
+ REP addmult cyclic PER;
+ index INCR 1 .
+
+addmult cyclic :
+ index INCR index ;
+ IF index > hash length minus one
+ THEN wrap around FI;
+ index := (index + code (name SUB j)) MOD hash length minus one .
+
+wrap around:
+ index DECR hash length minus one .
+
+ENDPROC hash ;
+
+INT PROC table entries:
+ table.entries
+END PROC table entries;
+
+INT PROC hash table (INT CONST n):
+ table.hash table [n]
+END PROC hash table;
+
+INT PROC next table (INT CONST n):
+ table.next [n]
+END PROC next table;
+
+TEXT PROC name of (INT CONST index):
+ IF index < 0
+ THEN errorstop ("PROC name of: negativer Index"); ""
+ ELIF index < start of name table
+ THEN symbol of (index)
+ ELIF index <= table.entries
+ THEN table.name table (index)
+ ELSE errorstop ("PROC name of: Index größer als nametable");
+ ""
+ FI
+
+END PROC name of;
+
+PROC recognize (INT CONST symb, type, ADDRESS CONST adr, DTYPE CONST data, TEXT CONST dim):
+ symbol.type := type;
+ symbol.adr := adr;
+ symbol.data := data;
+ symbol.dim := dim .
+
+symbol: table.symboltable [symb] .
+END PROC recognize;
+
+PROC remember (INT CONST symb, INT VAR type, ADDRESS VAR adr, DTYPE VAR data, TEXT VAR dim):
+ SYMBOL CONST symbol := table.symboltable [symb];
+ type := symbol.type;
+ adr := symbol.adr;
+ data := symbol.data;
+ dim := symbol.dim
+END PROC remember;
+
+BOOL PROC known (INT CONST symb) :
+ table.symboltable [symb].type > 0
+END PROC known;
+
+PROC scope compulsory (BOOL CONST new state): (* DEF/mo *)
+ compulsory with scope := new state
+END PROC scope compulsory;
+
+END PACKET basic table handling;
+
+PACKET basic scanner DEFINES begin scanning, (* Autor: Heiko Indenbirken *)
+ next symbol, (* Stand: 27.10.1987/rr/mo *)
+ next data,
+ next statement,
+ define chars,
+ scan line,
+ scan line no, (* F29/rr *)
+ get data types of input vars, (* F25/rr *)
+ basic error,
+ basic warning,
+ basic list,
+ set scope,
+ scanner scope:
+
+
+LET (* S y m b o l T y p e n *)
+ any = 0, const = 1, var = 2, array = 3,
+ res word= 8, operator= 9, eos = 10, del =11,
+ stat no = 12, user fn = 20; (* DEF/mo *)
+
+LET (* S y m b o l z e i c h e n *)
+ less = 60, greater = 62,
+ less equal = 28, unequal = 29, greater equal = 30,
+ point = 46, eol = 13, eop = 14,
+ go = 163, gosub = 164, goto = 165,
+ sub = 235, to = 217;
+
+LET name chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz.0123456789!#$%",
+ quote = """", open bracket = "(",
+ comma = ",", close bracket = ")",
+ colon = ":",
+ exponent chars= "dDeE";
+
+FILE VAR source file;
+TEXT VAR defint chars, defstr chars, record, letter,
+ scope, new name; (* DEF/mo *)
+REAL VAR r dummy;
+INT VAR act stat no, record no, rec len, scan pos, i dummy;
+BOOL VAR eol generated, at line begin, listing := FALSE;
+
+PROC define chars (TEXT CONST begin, end, DTYPE CONST data):
+ INT VAR i;
+ FOR i FROM code (begin) UPTO code (end)
+ REP IF data = int type
+ THEN defint chars CAT code (i)
+ ELIF data = text type
+ THEN defstr chars CAT code (i)
+ FI
+ PER .
+
+END PROC define chars;
+
+
+PROC scanline (TEXT VAR line, INT VAR col):
+ line := record;
+ col := scan pos
+END PROC scanline;
+
+INT PROC scan line no : record no END PROC scan line no;
+
+
+PROC get data types of input vars (ROW 100 DTYPE VAR input var data, (* F25/rr *)
+ INT VAR number input vars) :
+
+ TEXT VAR first var char;
+ INT VAR var pos := scan pos;
+ to begin of actual var;
+ REP get next input var;
+ skip brackets if necessary;
+ IF var char <> comma THEN LEAVE get data types of input vars FI;
+ skip comma;
+ PER;
+
+ . var char : record SUB var pos
+
+ . to begin of actual var :
+ WHILE pos (name chars, var char) <> 0 REP var pos DECR 1 PER;
+ var pos INCR 1;
+ number input vars := 0;
+
+ . get next input var :
+ first var char := deshift (var char);
+ WHILE pos (name chars, var char) <> 0 REP var pos INCR 1 PER;
+ var pos DECR 1;
+ number input vars INCR 1;
+ input var data (number input vars) := var datatype (first var char, var char);
+ var pos := pos (record, ""33"", ""255"", var pos + 1);
+
+ . skip brackets if necessary :
+ IF var char = open bracket
+ THEN INT VAR bracket counter := 1;
+ REP count bracket UNTIL bracket counter = 0 PER;
+ var pos := pos (record, ""33"", ""255"", var pos + 1);
+ FI;
+
+ . count bracket :
+ INT CONST open := pos (record, open bracket, var pos + 1),
+ close := pos (record, close bracket, var pos + 1);
+ IF open > 0
+ THEN IF close > 0
+ THEN IF open > close
+ THEN close bracket found
+ ELSE open bracket found
+ FI;
+ ELSE open bracket found
+ FI;
+ ELSE IF close > 0
+ THEN close bracket found
+ ELSE LEAVE get data types of input vars
+ FI;
+ FI;
+
+ . open bracket found :
+ bracket counter INCR 1;
+ var pos := open;
+
+ . close bracket found :
+ bracket counter DECR 1;
+ var pos := close;
+
+ . skip comma :
+ var pos := pos (record, ""33"", ""255"", var pos + 1);
+
+END PROC get data types of input vars;
+
+
+PROC begin scanning (FILE VAR basic file):
+ enable stop;
+ source file := basic file;
+ to first record (source file);
+ col (source file, 1);
+ IF eof (source file)
+ THEN errorstop ("Datei ist leer") FI;
+
+ defint chars := "";
+ defstr chars := "";
+ scope := ""; (* DEF/mo *)
+ act stat no := 0;
+ read record (source file, record);
+ rec len := length (record);
+ scan pos := 0;
+ record no := 1;
+ eol generated := FALSE;
+ at line begin := TRUE;
+ IF listing
+ THEN line;
+ putline (record);
+ IF sysout <> ""
+ THEN cout (record no)
+ FI
+ ELSE cout (record no)
+ FI.
+
+END PROC begin scanning;
+
+PROC next statement:
+ IF eof (source file)
+ THEN errorstop (99, "")
+ ELSE eol generated := FALSE;
+ at line begin := TRUE;
+ down (source file);
+ read record (source file, record);
+ rec len := length (record);
+ scan pos := 0;
+ record no INCR 1;
+ FI;
+ IF listing
+ THEN putline (record);
+ IF sysout <> ""
+ THEN cout (record no)
+ FI
+ ELSE cout (record no)
+ FI.
+
+END PROC next statement;
+
+PROC next symbol (TEXT VAR name, INT VAR no, type, DTYPE VAR data):
+ enable stop;
+ clear symbol;
+ IF eol generated
+ THEN next statement FI;
+
+ IF eol reached
+ THEN generate eol
+ ELIF at line begin CAND stat no found (* F15/rr *)
+ THEN generate stat no
+ ELSE generate chars FI .
+
+clear symbol:
+ name := "";
+ no := 0;
+ type := any;
+ data := void type .
+
+eol reached:
+ scan pos := pos (record, ""33"", ""255"", scan pos+1);
+ scan pos = 0 .
+
+generate eol :
+ IF eof (source file)
+ THEN name := "EOF"; no := eop; type := eos
+ ELSE name := "EOL"; no := eol; type := eos FI;
+ eol generated := TRUE .
+
+stat no found: (* F15/rr *)
+ at line begin := FALSE;
+ pos ("0123456789", act char) <> 0 .
+
+generate stat no: (* F15/rr *)
+ INT CONST next scan pos := last number pos;
+ name := subtext (record, scan pos, next scan pos);
+ act stat no := int (name);
+ scan pos := next scan pos;
+ no := act stat no; type := stat no .
+
+last number pos : (* F15/rr *)
+ INT CONST high := pos (record, ""058"", ""255"", scan pos),
+ low := pos (record, ""032"", ""047"", scan pos);
+ IF high > 0
+ THEN IF low > 0
+ THEN min (high, low) - 1
+ ELSE high - 1
+ FI
+ ELIF low > 0
+ THEN low - 1
+ ELSE LENGTH record
+ FI .
+
+generate chars:
+ SELECT code (act char) OF
+ CASE 32: next symbol (name, no, type, data) (* Space *)
+ CASE 34: generate text denoter (* " *)
+ CASE 39: generate eol (* ' *)
+ CASE 42, 43, 45, 47, 92, 94, 61: generate operator (* *,+,-,/,\,^,=*)
+ CASE 60: generate less op (*<, <=, <> *)
+ CASE 62: generate greater op (*>, >= *)
+ CASE 46: treat point (* . *)
+ CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57:
+ generate numeric const (* 0 - 9 *)
+ CASE 58: generate eos (* : *)
+ CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 90, 97, 98, 99, 100, 101, 102, 103,
+ 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117,
+ 118, 119, 120, 121, 122, (* small and large letters *)
+ generate res word or id
+ OTHERWISE generate delimiter END SELECT .
+
+generate text denoter:
+ get text const (name, data);
+ type := const .
+
+generate operator:
+ name := act char; no := code (name); type := operator .
+
+generate less op:
+ IF next char = "="
+ THEN name := "<="; no := less equal; skip char
+ ELIF next char = ">"
+ THEN name := "<>"; no := unequal; skip char
+ ELSE name := "<"; no := less FI;
+ type := operator .
+
+generate greater op:
+ IF next char = "="
+ THEN name := ">="; no := greater equal; skip char
+ ELSE name := ">"; no := greater; FI;
+ type := operator .
+
+treat point:
+ IF pos ("0123456789", next char) <> 0
+ THEN generate numeric const
+ ELSE name := ".";
+ no := point;
+ type := del
+ FI.
+
+generate numeric const:
+ get numeric const (name, data);
+ type := const .
+
+last name char:
+ name SUB LENGTH name .
+
+generate eos:
+ name := ":"; no := eos; type := eos .
+
+generate res word or id:
+ get name chars;
+ IF reserved (deshift name, no, type)
+ THEN IF type = res word AND no = go
+ THEN treat go
+ FI
+ ELSE IF function name
+ THEN data := ftn datatype;
+ type := user fn
+ ELSE data := var datatype (deshift (name) SUB 1, last name char);
+ type := var or array
+ FI;
+ put name (scope, deshift name, no)
+ FI.
+
+treat go:
+ next symbol (new name, no, type, data);
+ IF no = to AND type = res word
+ THEN name CAT new name;
+ no := goto
+ ELIF no = sub AND type = res word
+ THEN name CAT new name;
+ no := gosub
+ ELSE scan error (102, name, "")
+ FI.
+
+get name chars:
+ TEXT VAR deshift name :: "";
+ INT VAR begin of name :: scan pos;
+ FOR scan pos FROM scan pos UPTO rec len
+ WHILE name chars found
+ REP deshift name CAT deshifted char PER;
+ scan pos DECR 1;
+ name := subtext (record, begin of name, scan pos).
+
+name chars found:
+ pos (name chars, act char) > 0 .
+
+function name:
+ subtext (deshift name, 1, 2) = "fn" .
+
+ftn datatype:
+ IF last name char = "$"
+ THEN text type
+ ELIF last name char = "%"
+ THEN int type
+ ELSE real type FI .
+
+var or array:
+ IF array name
+ THEN name CAT "()";
+ deshift name CAT "()"; (* F30/rr *)
+ array
+ ELSE var FI .
+
+array name:
+ next scan char = "(" .
+
+deshifted char:
+ letter := act char;
+ IF letter >= "A" AND letter <= "Z"
+ THEN code (code (letter) + 32)
+ ELSE letter FI .
+
+generate delimiter:
+ name := act char; no := code (name); type := del .
+
+next scan char: record SUB pos (record, ""33"", ""255"", scan pos+1).
+next char: (record SUB scan pos + 1) .
+act char: record SUB scan pos .
+skip char: scan pos INCR 1 .
+END PROC next symbol;
+
+DTYPE PROC var datatype (TEXT CONST first name char, last name char) :
+
+ IF last name char = "!" OR last name char = "#"
+ THEN real type
+ ELIF last name char = "$"
+ THEN text type
+ ELIF last name char = "%"
+ THEN int type
+ ELIF pos (defint chars, first name char) > 0
+ THEN int type
+ ELIF pos (defstr chars, first name char) > 0
+ THEN text type
+ ELSE real type FI .
+
+END PROC var datatype;
+
+BOOL PROC next data (TEXT VAR data text, DTYPE VAR data type) : (* F17/rr *)
+
+ data type := void type;
+ IF no more data
+ THEN scan pos := rec len;
+ data text := "";
+ FALSE
+ ELIF quoted string
+ THEN get quoted string;
+ TRUE
+ ELSE get unquoted string;
+ TRUE
+ FI
+
+ . no more data :
+ scan pos := pos (record, ""33"", ""255"", scan pos+1);
+ scan pos = 0
+
+ . quoted string :
+ (record SUB scan pos) = quote
+
+ . get quoted string :
+ get text const (data text, data type);
+
+ . get unquoted string :
+ INT CONST comma or colon pos 1 := position of comma or colon minus one;
+ data text := compress (subtext (record, scan pos, comma or colon pos 1));
+ scan pos := comma or colon pos 1;
+
+ . position of comma or colon minus one :
+ INT CONST colon pos := pos (record, colon, scan pos),
+ comma pos := pos (record, comma, scan pos);
+ IF colon pos > 0
+ THEN IF comma pos > 0
+ THEN min (colon pos, comma pos) - 1
+ ELSE colon pos - 1
+ FI
+ ELSE IF comma pos > 0
+ THEN comma pos - 1
+ ELSE LENGTH record
+ FI
+ FI
+
+END PROC next data;
+
+PROC get numeric const (TEXT VAR value, DTYPE VAR data):
+ get sign;
+ get const;
+ check datatype .
+
+get sign:
+ IF act char = "-"
+ THEN value := "-";
+ scan pos INCR 1
+ ELIF act char = "+"
+ THEN value := "+";
+ scan pos INCR 1
+ ELSE value := "" FI .
+
+get const:
+ get digits;
+ get point;
+ get digits;
+ get exponent .
+
+get digits:
+ FOR scan pos FROM scan pos UPTO rec len
+ WHILE digit found
+ REP value CAT act char PER .
+
+get point:
+ IF act char = "."
+ THEN value CAT ".";
+ scan pos INCR 1
+ ELIF pos (exponent chars, act char) > 0
+ THEN value CAT ".0"
+ ELSE LEAVE get const FI .
+
+get exponent:
+ IF pos (exponent chars, act char) > 0 (* F1/rr *)
+ THEN value CAT "e";
+ scan pos INCR 1;
+ evtl get sign;
+ get digits
+ FI .
+
+evtl get sign:
+ IF act char = "+" OR act char = "-"
+ THEN value CAT act char;
+ scan pos INCR 1
+ FI .
+
+digit found:
+ "0" <= act char AND act char <= "9" .
+
+check datatype:
+ IF act char = "%"
+ THEN IF integer ok (value)
+ THEN data := int type
+ ELSE scan error (2, value, "INT-Konstante nicht korrekt") FI
+ ELIF act char = "!" OR act char = "#"
+ THEN IF real ok (value)
+ THEN data := real type
+ ELSE scan error (2, value, "REAL-Konstante nicht korrekt") FI
+ ELIF integer ok (value)
+ THEN scan pos DECR 1; data := int type
+ ELIF real ok (value)
+ THEN scan pos DECR 1;
+ data := real type
+ ELSE scan error (2, value, "Numerische Konstante nicht korrekt") FI .
+
+act char: record SUB scan pos .
+END PROC get numeric const;
+
+PROC get text const (TEXT VAR value, DTYPE VAR data):
+ INT CONST quote 1 := scan pos;
+ scan pos := pos (record, """", scan pos+1);
+ IF quote 1 < scan pos
+ THEN value := subtext (record, quote 1+1, scan pos-1);
+ data := text type
+ ELSE scan error (15, subtext (record, quote 1), "("" fehlt)") FI .
+
+END PROC get text const;
+
+BOOL PROC integer ok (TEXT VAR zahl):
+ disable stop;
+ i dummy := int (zahl);
+ IF is error
+ THEN clear error;
+ FALSE
+ ELIF last conversion ok
+ THEN zahl := ""0""0"";
+ replace (zahl, 1, i dummy);
+ TRUE
+ ELSE FALSE FI .
+
+END PROC integer ok;
+
+BOOL PROC real ok (TEXT VAR zahl):
+ disable stop;
+ r dummy := real (zahl);
+ IF is error
+ THEN clear error;
+ FALSE
+ ELIF last conversion ok
+ THEN zahl := ""0""0""0""0""0""0""0""0"";
+ replace (zahl, 1, r dummy);
+ TRUE
+ ELSE FALSE FI .
+
+END PROC real ok;
+
+PROC basic error (INT CONST no, TEXT CONST name, addition):
+ basic error ("Compiler", no, record no, act stat no, name, addition, TRUE)
+END PROC basic error;
+
+PROC basic error (INT CONST no, TEXT CONST name, addition, BOOL CONST leave statement):
+ basic error ("Compiler", no, record no, act stat no, name, addition, leave statement)
+END PROC basic error;
+
+PROC scan error (INT CONST no, TEXT CONST name, addition):
+ basic error ("Scanner", no, record no, act stat no, name, addition, TRUE)
+END PROC scan error;
+
+PROC basic warning (TEXT CONST warning text): (* mo *)
+ basic warning (record no, act stat no, warning text)
+END PROC basic warning;
+
+PROC basic list (BOOL CONST t):
+ listing := t
+END PROC basic list;
+
+BOOL PROC basic list:
+ listing
+END PROC basic list;
+
+PROC set scope (TEXT CONST new scope): (* DEF/mo *)
+ scope := new scope
+END PROC set scope;
+
+TEXT PROC scanner scope: (* DEF/mo *)
+ scope
+END PROC scanner scope;
+
+END PACKET basic scanner;
+
+
+PACKET basic stat no DEFINES init stat no, (* Autor: Heiko Indenbirken *)
+ stat no pos, (* Stand: 27.10.1987/rr/mo *)
+ label pos,
+ all stat no:
+
+LET nil = "";
+
+TEXT VAR found stat no :: nil;
+INT VAR i, akt stat no :: 0, found no :: 0;
+
+PROC init stat no (FILE VAR f, INT VAR error no): (* F21/rr *)
+(*Die Datei 'f' muß im 'modify-Mode' sein. *)
+ INT VAR line no;
+ akt stat no := -1; (* F28/rr *)
+ found no := 0;
+ found stat no := nil;
+ error no := 0; (* F21/rr *)
+ to first record (f);
+ col (f, 1);
+ disable stop;
+ FOR line no FROM 1 UPTO 4000
+ REP exec (PROC (TEXT CONST, INT CONST) check, f, line no);
+ IF is error THEN check error FI;
+ IF eof (f)
+ THEN LEAVE init stat no
+ ELSE down (f) FI
+ PER;
+
+. check error : (* F21/rr *)
+ IF error code = 100
+ THEN clear error;
+ error no INCR 1;
+ ELSE LEAVE init stat no;
+ FI;
+
+END PROC init stat no;
+
+PROC check (TEXT CONST record, INT CONST line no):
+ IF statement no vorhanden
+ THEN remember statement no FI .
+
+statement no vorhanden: (* F15/rr *)
+ INT CONST first number pos := pos (record, ""048"", ""057"", 1);
+ first number pos > 0 CAND first number pos = first non blank pos .
+
+first non blank pos : (* F15/rr *)
+ pos (record, ""033"", ""255"", 1) .
+
+remember statement no:
+ get statement no;
+ IF neue nummer ist groesser als vorherige
+ THEN akt stat no := neue nummer;
+ cout (neue nummer);
+ found no INCR 1;
+ found stat no CAT mki (neue nummer)
+ ELSE basic error ("Stat no", 81, line no, neue nummer, number,
+ "Letzte Zeilennummer davor: " + text (akt stat no), TRUE)
+ FI .
+
+get statement no : (* F15/rr *)
+ disable stop;
+ TEXT CONST number := subtext (record, first number pos, last number pos);
+ INT VAR neue nummer := int (number);
+ IF NOT last conversion ok OR is error
+ THEN clear error;
+ basic error ("Stat no", 80, line no, akt stat no, number,
+ "Die Zeilennummer muß im Bereich 0-32767 liegen", TRUE)
+ FI;
+ enable stop .
+
+last number pos : (* F15/rr *)
+ INT CONST high := pos (record, ""058"", ""255"", first number pos),
+ low := pos (record, ""032"", ""047"", first number pos);
+ IF high > 0
+ THEN IF low > 0
+ THEN min (high, low) - 1
+ ELSE high - 1
+ FI
+ ELIF low > 0
+ THEN low - 1
+ ELSE LENGTH record
+ FI .
+
+neue nummer ist groesser als vorherige:
+ neue nummer > akt stat no .
+
+END PROC check;
+
+INT PROC stat no pos (INT CONST stat no):
+ FOR i FROM found no DOWNTO 1
+ REP IF (found stat no ISUB i) = stat no
+ THEN LEAVE stat no pos WITH i FI
+ PER;
+ 0
+END PROC stat no pos;
+
+INT PROC label pos (INT CONST stat no):
+ FOR i FROM found no DOWNTO 1
+ REP IF (found stat no ISUB i) = stat no
+ THEN LEAVE label pos WITH i FI
+ PER;
+ basic error (8, text (stat no), nil); (* F16/rr *)
+ 0
+END PROC label pos;
+
+PROC all stat no (TEXT VAR stat no, INT VAR no):
+ stat no := found stat no;
+ no := found no
+END PROC all stat no;
+
+END PACKET basic stat no;
+
+PACKET basic storage DEFINES init storage, (* Autor: Heiko Indenbirken *)
+ next local adr, (* Stand: 12.06.86 *)
+ next ref,
+ local adr,
+ local storage,
+ type size,
+ quiet type:
+
+
+
+LET ref length = 2;
+
+INT VAR quiet size, quiet align;
+ADDRESS VAR loc adr, free loc adr;
+DTYPE VAR quiet value;
+identify ("QUIET", quiet size, quiet align, quiet value);
+
+PROC init storage:
+ free loc adr := LOC 0;
+ loc adr := LOC 0;
+
+END PROC init storage;
+
+(* Verwaltung der lokalen Addressen für Zwischenergebnisse *)
+ADDRESS PROC next local adr (DTYPE CONST type):
+ INT VAR type len :: type size (type);
+ loc adr := free loc adr;
+ adjust (loc adr, type len);
+ free loc adr := loc adr + type len;
+ loc adr .
+
+END PROC next local adr;
+
+ADDRESS PROC next ref:
+ loc adr := free loc adr;
+ adjust (loc adr, ref length);
+ free loc adr := loc adr + ref length;
+ loc adr .
+
+END PROC next ref;
+
+ADDRESS PROC local adr:
+ loc adr
+END PROC local adr;
+
+INT PROC local storage:
+ int (subtext (dump (free loc adr), 6))
+END PROC local storage;
+
+INT PROC type size (DTYPE CONST type):
+ IF type = int type OR type = bool type
+ THEN 1
+ ELIF type = row type
+ THEN 2
+ ELIF type = real type
+ THEN 4
+ ELIF type = text type
+ THEN 8
+ ELIF type = quiet value
+ THEN quiet size
+ ELSE errorstop ("Unbekannter DTYPE: " + dump (type)); 0 FI .
+
+END PROC type size;
+
+DTYPE PROC quiet type:
+ quiet value
+END PROC quiet type;
+
+END PACKET basic storage;
+
+PACKET basic identify DEFINES (* Autor: Heiko Indenbirken *)
+ (* Stand: 20.08.1987/rr/mo *)
+ identify,
+ convert paramfield,
+ dump ftn,
+ is basic function: (* mo *)
+
+LET nil = "";
+
+LET ENTRY = STRUCT (TEXT param, INT no, next, OPN opn, DTYPE result);
+
+ROW 256 ENTRY VAR ftn table;
+
+clear ftn table;
+init ftn names;
+init int operator;
+init real operator;
+init text operator;
+init predefined funktions;
+
+PROC dump ftn (INT CONST n, TEXT VAR param, INT VAR no, next,
+ OPN VAR opn, DTYPE VAR result):
+ param := ftn table [n].param;
+ no := ftn table [n].no;
+ next := ftn table [n].next;
+ opn := ftn table [n].opn;
+ result := ftn table [n].result
+
+END PROC dump ftn;
+
+PROC identify (INT CONST ftn no, first, params, OPN VAR operation, BOOL VAR found):
+ TEXT VAR param;
+ INT VAR pos :: min (ftn no, 256);
+ convert paramfield (first, params, param);
+ REP IF param = ftn table [pos].param AND ftn no = ftn table [pos].no
+ THEN declare (params+1, ftn table [pos].result);
+ declare (params+1, 1);
+ operation := ftn table [pos].opn;
+ found := TRUE;
+ LEAVE identify
+ ELSE pos := ftn table [pos].next FI
+ UNTIL pos <= 0 PER; (* F14/rr *)
+ operation := nop;
+ found := FALSE .
+
+END PROC identify;
+
+PROC next free entry (INT VAR free pos):
+ FOR free pos FROM 1 UPTO 256
+ REP IF ftn table [free pos].next < 0 AND ftn table [free pos].no = 0 (* mo *)
+ THEN LEAVE next free entry FI
+ PER;
+ errorstop ("Überlauf der Funktionstabelle") .
+
+END PROC next free entry;
+
+PROC convert paramfield (INT CONST first, params, TEXT VAR param):
+ INT VAR i;
+ param := nil;
+ FOR i FROM first UPTO params
+ REP param CAT datatype PER .
+
+datatype:
+ DTYPE CONST data :: dtype (i);
+ IF data = int type
+ THEN "I"
+ ELIF data = real type
+ THEN "R"
+ ELIF data = text type
+ THEN "T"
+ ELIF data = bool type
+ THEN "b"
+ ELSE errorstop ("Falscher DTYPE: " + dump (data));
+ nil
+ FI .
+
+END PROC convert paramfield;
+
+PROC convert paramfield (TEXT CONST params, INT CONST first):
+ INT VAR i;
+ FOR i FROM first UPTO first+length (params)-1
+ REP parameter (i, this type, 1, GLOB 0) PER .
+
+this type:
+ IF (params SUB i) = "I"
+ THEN int type
+ ELIF (params SUB i) = "R"
+ THEN real type
+ ELIF (params SUB i) = "T"
+ THEN text type
+ ELSE errorstop ("Unbekannter Typ: " + params);
+ undefined type
+ FI .
+
+END PROC convert paramfield;
+
+PROC init op (INT CONST ftn no, TEXT CONST param, ftn name):
+ IF elan opn found
+ THEN insert new opn in chain
+ ELSE errorstop ("PROC " + ftn name + " (" + param + ") nicht gefunden") FI .
+
+elan opn found:
+ OPN VAR opn;
+ BOOL VAR found;
+ convert paramfield (param, 1);
+ identify (ftn name, 1, length (param), opn, found);
+ found .
+
+insert new opn in chain:
+ INT VAR ftn pos :: ftn no;
+ REP IF end of chain found
+ THEN cat new entry in chain
+ ELIF free entry in chain found
+ THEN cover this entry
+ ELSE next entry FI
+ UNTIL ftn pos <= 0 PER .
+
+end of chain found:
+ act entry.next = 0 .
+
+cat new entry in chain:
+ INT VAR free pos;
+ next free entry (free pos);
+ act entry.next := free pos;
+ free entry := ENTRY:(param, ftn no, 0, opn, dtype (LENGTH param+1));
+ LEAVE insert new opn in chain .
+
+free entry in chain found:
+ act entry.next = -1 .
+
+cover this entry:
+ act entry := ENTRY:(param, ftn no, 0, opn, dtype (LENGTH param+1));
+ LEAVE insert new opn in chain .
+
+next entry:
+ ftn pos := act entry.next .
+
+act entry: ftn table [ftn pos] .
+free entry: ftn table [free pos] .
+
+END PROC init op;
+
+BOOL PROC is basic function (INT CONST ftn no): (* mo *)
+
+ pos (ftn names, code (ftn no)) <> 0
+
+END PROC is basic function;
+
+.
+clear ftn table:
+ INT VAR k;
+ FOR k FROM 1 UPTO 256
+ REP ftn table [k] := ENTRY:(nil, 0,-1, nop, undefined type) PER .
+
+init ftn names:
+ TEXT CONST ftn names :: "+-*/\^<=>"28""29""30""249""251""252""253""254"" +
+ ""128""130""131""134""136""137""141""143""142"" +
+ ""153""154""155""157""159""161""166""168""170""171""172"" +
+ ""174""175""178""179""182""184""183""187""192"" +
+ ""201""202""204""205""206""207""208""211""212"" +
+ ""215""221""228""229""230""231""232""233"";
+ FOR k FROM 1 UPTO length (ftn names)
+ REP ftn table [ftn pos] := ENTRY:(nil, ftn pos,-1, nop, void type) PER .
+
+ftn pos:
+ code (ftn names SUB k) .
+
+init int operator:
+ init op ( 43, "II", "+");
+ init op ( 45, "II", "-");
+ init op ( 42, "II", "*");
+ init op ( 47, "II", "/"); (* mo *)
+ init op ( 92, "II", "DIV"); (* mo *)
+ init op ( 94, "II", "^");
+ init op ( 61, "II", "EQU");
+ init op ( 29, "II", "UEQ");
+ init op ( 60, "II", "LES");
+ init op ( 28, "II", "LEQ");
+ init op ( 62, "II", "GRE");
+ init op ( 30, "II", "GEQ");
+ init op (249, "II", "MOD"); (* mo *)
+ init op (251, "II", "AND");
+ init op (252, "II", "OR");
+ init op (253, "II", "XOR");
+ init op (254, "II", "EQV");
+ init op (255, "II", "IMP").
+
+init real operator:
+ init op ( 43, "RR", "+");
+ init op ( 45, "RR", "-");
+ init op ( 42, "RR", "*");
+ init op ( 47, "RR", "/");
+ init op ( 92, "RR", "DIV"); (* mo *)
+ init op ( 94, "RR", "^");
+ init op ( 61, "RR", "EQU");
+ init op ( 29, "RR", "UEQ");
+ init op ( 60, "RR", "LES");
+ init op ( 28, "RR", "LEQ");
+ init op ( 62, "RR", "GRE");
+ init op ( 30, "RR", "GEQ");
+ init op (249, "RR", "realmod"). (* mo *)
+
+init text operator:
+ init op ( 43, "TT", "+");
+ init op ( 61, "TT", "EQU");
+ init op ( 29, "TT", "UEQ");
+ init op ( 60, "TT", "LES");
+ init op ( 28, "TT", "LEQ");
+ init op ( 62, "TT", "GRE");
+ init op ( 30, "TT", "GEQ") .
+
+init predefined funktions:
+ init op (128, "I", "abs");
+ init op (128, "R", "abs");
+ init op (130, "T", "asc");
+ init op (131, "R", "arctan");
+ init op (131, "I", "arctan");
+ init op (134, "I", "cdbl");
+ init op (134, "R", "cdbl");
+ init op (136, "I", "chr");
+ init op (136, "R", "chr");
+ init op (137, "R", "cint");
+ init op (137, "I", "cint");
+ init op (141, "R", "cos");
+ init op (141, "I", "cos");
+ init op (143, "T", "cvi");
+ init op (142, "T", "cvd");
+# init op (153, "", "eof");# (* File *)
+ init op (154, "", "errorline");
+ init op (155, "", "errorcode");
+ init op (157, "R", "exp");
+ init op (157, "I", "exp");
+ init op (159, "R", "floor");
+ init op (159, "I", "floor");
+ init op (161, "I", "fre");
+ init op (161, "R", "fre");
+ init op (161, "T", "fre");
+ init op (166, "I", "hex");
+ init op (166, "R", "hex");
+ init op (168, "", "incharety");
+ init op (170, "I", "inchars");
+ init op (170, "R", "inchars");
+ init op (171, "TT", "instr");
+ init op (171, "ITT", "instr");
+ init op (171, "RTT", "instr");
+ init op (172, "I", "ent");
+ init op (172, "R", "ent");
+ init op (174, "TI", "left");
+ init op (174, "TR", "left");
+ init op (175, "T", "length");
+# init op (178, "I", "line no");# (* File *)
+ init op (179, "R", "ln");
+ init op (179, "I", "ln");
+ init op (182, "TII", "mid");
+ init op (182, "TI", "mid");
+ init op (182, "TRR", "mid");
+ init op (182, "TR", "mid");
+ init op (183, "I", "mkd");
+ init op (183, "R", "mkd");
+ init op (187, "I", "oct");
+ init op (187, "R", "oct");
+ init op (192, "I", "pos");
+ init op (192, "R", "pos");
+ init op (201, "TI", "right");
+ init op (201, "TR", "right");
+ init op (202, "", "rnd"); (* F12/rr *)
+ init op (202, "I", "rnd");
+ init op (202, "R", "rnd");
+ init op (204, "I", "sign");
+ init op (204, "R", "sign");
+ init op (205, "R", "sin");
+ init op (205, "I", "sin");
+ init op (206, "I", "space");
+ init op (206, "R", "space");
+ init op (207, "I", "space");
+ init op (207, "R", "space");
+ init op (208, "R", "sqrt");
+ init op (208, "I", "sqrt");
+ init op (211, "I", "basictext");
+ init op (211, "R", "basictext");
+ init op (212, "IT", "string");
+ init op (212, "RT", "string");
+ init op (212, "II", "string");
+ init op (212, "RR", "string");
+ init op (212, "RI", "string");
+ init op (212, "IR", "string");
+ init op (215, "R", "tan");
+ init op (215, "I", "tan");
+ init op (221, "T", "val"); (* F18/rr *)
+ init op (228, "", "errormessage");
+ init op (229, "", "csrlin");
+ init op (230, "I", "lpos");
+ init op (230, "R", "lpos");
+ init op (231, "", "time");
+ init op (232, "", "date");
+ init op (233, "", "timer").
+
+END PACKET basic identify;
+
+PACKET basic data handling (* Autor: R. Ruland *)
+ (* Stand: 23.10.87/mo *)
+ DEFINES init data,
+ data line,
+ data, read,
+ restore,
+ next int,
+ next real,
+ next text:
+
+LET (* R e s u l t T y p e n *)
+ stat code = 0, stat char = ""0"",
+ data code = 1, data char = ""1"",
+ text code = 2, text char = ""2"",
+
+ int overflow = 4,
+ real overflow = 6;
+
+INT VAR type;
+TEXT VAR data text :: "", number text;
+
+PROC init data:
+
+ data text := ""
+
+END PROC init data;
+
+
+PROC init data (TEXT VAR data, INT VAR data pos):
+
+ data := data text;
+ data pos := 1
+
+END PROC init data;
+
+
+PROC restore (TEXT CONST data, INT VAR data pos, INT CONST line no):
+
+ INT CONST data length :: LENGTH data;
+ data pos := 1;
+ WHILE data pos < data length
+ REP type := code (data SUB data pos);
+ data pos INCR 1;
+ SELECT type OF
+ CASE stat code : IF int value (data, data pos) >= line no
+ THEN LEAVE restore FI
+ CASE data code, text code : data pos INCR int value (data, data pos)
+ OTHERWISE : errorstop (1051, "Fehlerhaften Dateneintrag gefunden: " + text (type))
+ ENDSELECT;
+ PER;
+ errorstop (1004, "RESTORE: Keine DATA-Anweisung in oder nach Zeile " + text (line no)
+ + " gefunden");
+
+END PROC restore;
+
+
+INT PROC next int (TEXT CONST data, INT VAR data pos):
+
+ number text := next text (data, data pos);
+ disable stop;
+ INT VAR result := int (number text);
+ IF is error
+ THEN IF error code = int overflow THEN handle overflow FI;
+ ELIF NOT last conversion ok CAND number text <> ""
+ THEN errorstop (1013, "READ: Falscher Datentyp, " + number text + " ist kein INT")
+ FI;
+ result
+
+ . handle overflow :
+ clear error;
+ result := result value;
+ IF cursor x pos <> 1 THEN next line FI;
+ basic out ("WARNUNG : INT-Überlauf bei READ, gefunden: " + number text);
+ next line;
+
+ . result value :
+ IF (number text SUB 1) = "-" THEN minint ELSE maxint FI
+
+END PROC next int;
+
+
+REAL PROC next real (TEXT CONST data, INT VAR data pos):
+
+ number text := next text (data, data pos);
+ disable stop;
+ REAL VAR result := val (number text);
+ IF is error
+ THEN IF error code = real overflow OR error code = int overflow (* <- wegen Fehler in REAL PROC real (T C) *)
+ THEN handle overflow or underflow
+ FI;
+ ELIF NOT last conversion ok CAND number text <> ""
+ THEN errorstop (1013, "READ: Falscher Datentyp, " + number text + " ist kein REAL")
+ FI;
+ result
+
+ . handle overflow or underflow : (* F23/rr *)
+ clear error;
+ IF cursor x pos <> 1 THEN next line FI;
+ basic out ("WARNUNG : " + overflow or underflow + " bei READ, gefunden: " + number text);
+ next line;
+
+ . overflow or underflow :
+ IF is overflow
+ THEN result := sign * (max real - 0.99999999999994e120); (* <- wegen Fehler in TEXT PROC text (R C) *)
+ "REAL-Überlauf"
+ ELSE result := 0.0;
+ "REAL-Unterlauf"
+ FI
+
+ . sign :
+ IF (number text SUB 1) = "-" THEN -1.0 ELSE 1.0 FI
+
+ . is overflow :
+ INT VAR exponent pos := pos (number text, "E");
+ IF exponent pos = 0 THEN exponent pos := pos (number text, "e") FI;
+ IF exponent pos = 0
+ THEN TRUE
+ ELSE (number text SUB (exponent pos + 1)) <> "-"
+ FI
+
+END PROC next real;
+
+
+TEXT PROC next text (TEXT CONST data, INT VAR data pos):
+
+ INT CONST len :: int value (data, data pos);
+ data pos INCR len;
+ subtext (data, data pos-len, data pos-1)
+
+END PROC next text;
+
+
+INT PROC int value (TEXT CONST data, INT VAR data pos):
+
+ data pos INCR 2;
+ subtext (data, data pos-2, data pos-1) ISUB 1
+
+END PROC int value;
+
+
+PROC data line (INT CONST line no):
+
+ data text CAT stat char;
+ data text CAT mki (line no)
+
+END PROC data line;
+
+
+PROC data (TEXT CONST string, DTYPE VAR data type) :
+
+ data text CAT data + mki (length (string));
+ data text CAT string;
+
+ . data :
+ IF data type = void type
+ THEN data char
+ ELIF data type = text type
+ THEN text char
+ ELSE errorstop (1051, "Unbekannter DTYPE: " + dump (data type)); ""
+ FI
+
+END PROC data;
+
+
+PROC read (TEXT CONST data, INT VAR data pos, INT VAR i):
+
+ type := code (data SUB data pos);
+ data pos INCR 1;
+ IF data pos >= LENGTH data
+ THEN errorstop (1004, "Keine Daten mehr für READ")
+ ELIF type = data code
+ THEN i := next int (data, data pos)
+ ELIF type = stat code
+ THEN data pos INCR 2;
+ read (data, data pos, i)
+ ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein INT")
+ FI;
+
+END PROC read;
+
+
+PROC read (TEXT CONST data, INT VAR data pos, REAL VAR r):
+
+ type := code (data SUB data pos);
+ data pos INCR 1;
+ IF data pos >= LENGTH data
+ THEN errorstop (1004, "Keine Daten mehr für READ")
+ ELIF type = data code
+ THEN r := next real (data, data pos)
+ ELIF type = stat code
+ THEN data pos INCR 2;
+ read (data, data pos, r)
+ ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein REAL")
+ FI;
+
+END PROC read;
+
+
+PROC read (TEXT CONST data, INT VAR data pos, TEXT VAR t):
+
+ type := code (data SUB data pos);
+ data pos INCR 1;
+ IF data pos >= LENGTH data
+ THEN errorstop (1004, "Keine Daten mehr für READ")
+ ELIF type = data code OR type = text code
+ THEN t := next text (data, data pos)
+ ELIF type = stat code
+ THEN data pos INCR 2;
+ read (data, data pos, t)
+ ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein TEXT")
+ FI;
+
+END PROC read;
+
+
+TEXT PROC data string (TEXT CONST data, INT VAR data pos):
+
+ IF type = text code
+ THEN """" + next text (data, data pos) + """"
+ ELSE "unbekannter DTYPE: " + text (type)
+ FI
+
+END PROC data string;
+
+END PACKET basic data handling;
+
+
+PACKET basic odds and ends DEFINES trace, (* Autor: Heiko Indenbirken *)
+ start basic, (* Stand: 26.10.1987/rr/mo *)
+ end basic,
+ loop end,
+ basic stop:
+
+(* Fehlerbehandlung *)
+
+PROC trace (INT CONST stat no):
+ basic out ("[" + text (stat no) + "]")
+
+END PROC trace;
+
+(*Laufzeitprozeduren *)
+PROC start basic:
+ set line nr (0);
+ initialize random (0.1); (* F26/rr *)
+ init output;
+ init input
+
+END PROC start basic;
+
+PROC end basic:
+ IF is error
+ THEN switch back to old sysout state
+ FI .
+
+END PROC end basic;
+
+(* Schleifenüberprüfung *)
+BOOL PROC loop end (REAL CONST x, max, step) :
+ IF step > 0.0
+ THEN x > max
+ ELSE x < max FI
+
+END PROC loop end;
+
+BOOL PROC loop end (INT CONST x, max, step) :
+ IF step > 0
+ THEN x > max
+ ELSE x < max FI
+
+END PROC loop end;
+
+PROC basic stop (INT CONST stat no):
+ basic out ("STOP beendet das Programm in Zeile " + text (stat no));
+ next line
+
+END PROC basic stop;
+
+END PACKET basic odds and ends
+
diff --git a/basic/BASIC.Compiler b/basic/BASIC.Compiler
new file mode 100644
index 0000000..d4e4c21
--- /dev/null
+++ b/basic/BASIC.Compiler
@@ -0,0 +1,2305 @@
+(***************************************************************************)
+(* *)
+(* Dritte von drei Dateien des EUMEL-BASIC-Systems *)
+(* *)
+(* Autor: Heiko Indenbirken *)
+(* Überarbeitet von: Rudolf Ruland und Michael Overdick *)
+(* *)
+(* Stand: 27.10.1987 *)
+(* *)
+(***************************************************************************)
+
+PACKET basic compiler DEFINES basic, (* Autor: Heiko Indenbirken *)
+ basic version: (* Stand: 27.10.1987/rr/mo *)
+
+PROC basic version :
+
+putline (""13" "15" BASIC - Compiler Version 1.1 (27.10.1987) "14"");
+
+END PROC basic version;
+
+LET compiler msg = " ******* ENDE DER UEBERSETZUNG *******",
+ compiler err msg = " Fehler entdeckt";
+
+LET (* S y m b o l T y p e n *)
+ any = 0, const = 1, var = 2, array = 3, denoter = 5,
+ res word= 8, operator= 9, eos = 10, del =11, stat no = 12,
+ result const = 13, (* F3/rr *)
+ user fn = 20; (* DEF/mo *)
+
+LET (* S y m b o l z e i c h e n *)
+ plus = 43, minus = 45, mult = 42,
+ div = 47, backslash = 92, exponent = 94,
+ equal = 61, semicolon = 59, comma = 44,
+ numbersign = 35, open bracket = 40, close bracket = 41,
+ eol = 13, eop = 14, mod op = 249;
+
+LET (* Reservierte Worte *)
+ as s = 129, base s = 132, call s = 133, chain s = 135,
+ clear s = 138, close s = 139, common s = 140, data s = 144,
+ def s = 145, defdbl s = 146, defint s = 147, defsng s = 148,
+ defstr s = 149, dim s = 150, else s = 151, end s = 152,
+ eof s = 153, error s = 156, field s = 158, for s = 160,
+ get s = 162, gosub s = 164, goto s = 165, if s = 167, (* F2/rr *)
+ input s = 169, kill s = 173, let s = 176, line in s = 177,
+ lprint s = 180, lset s = 181, mid s = 182, name s = 185,
+ next s = 186, on s = 188, open s = 189, option s = 190,
+ print s = 193, put s = 194, rand s = 195, read s = 196,
+ rem s = 197, restore s = 198, resume s = 199, return s = 200,
+ rset s = 203, step s = 209, stop s = 210, swap s = 213,
+ tab s = 214, then s = 216, to s = 217, troff s = 218,
+ tron s = 219, using s = 220, wait s = 222, wend s = 223,
+ while s = 224, width s = 225, write s = 226, not = 250,
+ cls s = 227, usr = 234, sub = 235; (* mo *)
+
+LET nil = "",
+ intern error = 51;
+
+LET SYMBOL = STRUCT (TEXT name, INT no, type, ADDRESS adr, DTYPE data);
+ADDRESS CONST niladr :: LOC -4;
+SYMBOL CONST nilsymbol :: SYMBOL : (nil, any, any, nil adr, void type);
+SYMBOL VAR symb;
+BOOL VAR found;
+OPN VAR opn;
+
+TEXT OP NAME (SYMBOL CONST val):
+ IF val.type = const
+ THEN constant value
+ ELIF val.type = stat no
+ THEN text (val.no)
+ ELSE val.name FI .
+
+constant value:
+ IF val.data = int type AND length (val.name) = 2
+ THEN text (val.name ISUB 1)
+ ELIF val.data = real type AND length (val.name) = 8
+ THEN text (val.name RSUB 1)
+ ELSE val.name FI .
+
+END OP NAME;
+
+PROC careful error (INT CONST no, TEXT CONST name, addition): (* DEF/mo *)
+ IF at end of statement
+ THEN basic error (no, name, addition)
+ ELSE basic error without leaving statement
+ FI.
+
+at end of statement:
+ symb.type = eos.
+
+basic error without leaving statement:
+ basic error (no, name, addition, FALSE);
+ error no INCR 1.
+
+END PROC careful error;
+
+(* P r e c o m p i l e r *)
+PROC next symbol:
+ symb.adr := niladr;
+ next symbol (symb.name, symb.no, symb.type, symb.data);
+
+ IF symb.no = end symbol AND symb.type = res word
+ THEN symb.no := -symb.no;
+ symb.type := eos;
+ FI
+END PROC next symbol;
+
+PROC skip (INT CONST symbol, type):
+ IF symb.type = type AND symb.no = symbol
+ THEN next symbol
+ ELSE basic error (2, NAME symb, name of (symbol) + " erwartet") FI .
+END PROC skip;
+
+PROC get letter (SYMBOL VAR symbol):
+ IF symb.type = var AND (LENGTH symb.name) = 1
+ THEN symbol := symb;
+ next symbol
+ ELSE basic error (2, NAME symb, "Buchstabe erwartet, " + type of (symb.type) + " gefunden") FI .
+
+END PROC get letter;
+
+PROC get var (SYMBOL VAR symbol):
+ IF symb.type = var
+ THEN variable (symbol)
+ ELIF symb.type = array
+ THEN array var (symbol)
+ ELSE basic error (2, NAME symb, "Variable erwartet, " + type of (symb.type) + " gefunden") FI .
+
+END PROC get var;
+
+PROC get expr (SYMBOL VAR symbol):
+ get expression (symbol, 0)
+END PROC get expr;
+
+PROC get const (SYMBOL VAR symbol, DTYPE CONST data):
+ IF symb.type = const
+ THEN symbol := symb;
+ declare const (symbol, data); (* F3/rr *)
+ next symbol
+ ELSE basic error (2, NAME symb, "Konstante erwartet, " + type of (symb.type) + " gefunden") FI .
+
+END PROC get const;
+
+PROC get var (SYMBOL VAR symbol, DTYPE CONST data):
+ get var (symbol);
+ convert (symbol, data)
+END PROC get var;
+
+PROC get expr (SYMBOL VAR symbol, DTYPE CONST data):
+ get expression (symbol, 0);
+ convert (symbol, data)
+END PROC get expr;
+
+PROC get expression (SYMBOL VAR result, INT CONST last prio):
+ get single result;
+ WHILE symb.type = operator AND higher priority
+ REP get dyadic operand;
+ gen dyadic operation
+ PER .
+
+get single result:
+ INT VAR prio;
+ SELECT symb.type OF
+ CASE var: variable (result)
+ CASE array: array var (result)
+ CASE const: get const
+ CASE operator: get monadic operator
+ CASE res word: basic function (result)
+ CASE user fn: user function (result) (* DEF/mo *)
+ OTHERWISE get bracket END SELECT .
+
+get const:
+ result := symb;
+ declare const (result, result. data); (* F3/rr *)
+ next symbol .
+
+get monadic operator:
+ get operator;
+ prio := monadic op prio; (* mo *)
+ get monadic operand;
+ generate monadic operator .
+
+monadic op prio: (* mo *)
+ IF op no = not
+ THEN 6
+ ELSE 12
+ FI.
+
+get monadic operand:
+ SYMBOL VAR operand;
+ next symbol;
+ get expression (operand, prio).
+
+generate monadic operator:
+(* Mögliche Ops: +, - und NOT *)
+ parameter (1, operand.data, const, operand.adr);
+ parameter (2, operand.data, var, next local adr (operand.data));
+ parameter (3, void type, const, nil adr);
+
+ IF op no = plus
+ THEN result := operand
+ ELIF op no = minus
+ THEN generate minus op
+ ELIF op no = not
+ THEN generate not op
+ ELSE basic error (2, op name, "Kein monadischer Operator") FI .
+
+generate minus op:
+ IF operand.data = int type
+ THEN apply (1, 2, int minus)
+ ELIF operand.data = real type
+ THEN apply (1, 2, real minus)
+ ELSE basic error (82, op name, NAME operand + " : " + dump (operand.data)) FI;
+ result := SYMBOL:(op name, 0, result const, local adr, operand.data) .
+
+generate not op:
+ IF operand.data = int type
+ THEN apply (1, 1, int not opn)
+ ELIF operand.data = real type
+ THEN apply (1, 1, real not opn)
+ ELSE basic error (82, op name, NAME operand + " : " + dump (operand.data)) FI;
+ result := SYMBOL:(op name, 0, result const, local adr, operand.data) .
+
+get operator:
+ INT CONST op no :: symb.no;
+ TEXT CONST op name :: symb.name .
+
+higher priority:
+ get operator;
+ prio := dyadic op prio;
+ prio > last prio .
+
+dyadic op prio:
+ IF is bool op (op no) THEN bool op prio
+ ELIF op no = plus OR op no = minus THEN 8
+ ELIF op no = mod op THEN 9
+ ELIF op no = backslash THEN 10
+ ELIF op no = mult OR op no = div THEN 11
+ ELIF op no = exponent THEN 13
+ ELSE (* relational operator *) 7
+ FI.
+
+bool op prio:
+ 256 - op no.
+
+get bracket:
+ IF symb.type = del AND symb.no = open bracket
+ THEN next symbol
+ ELSE basic error (22, NAME symb, "") FI;
+ get expression (result, 0);
+ skip (close bracket, del) .
+
+get dyadic operand:
+ next symbol;
+ get expression (operand, prio) .
+
+gen dyadic operation:
+ convert operands;
+ identify dyadic operator;
+ generate dyadic operator .
+
+convert operands:
+ DTYPE CONST op type :: type of operation;
+ convert (result, op type);
+ convert (operand, op type) .
+
+type of operation:
+ IF is bool op (op no)
+ THEN int type
+ ELIF result.data = operand.data
+ THEN result.data
+ ELSE real type FI .
+
+identify dyadic operator:
+ BOOL VAR local found;
+ OPN VAR local opn;
+ DTYPE VAR data;
+ parameter (1, result.data, const, result.adr);
+ parameter (2, operand.data, const, operand.adr);
+ identify (op no, 1, 2, local opn, local found);
+ IF NOT local found
+ THEN basic error (83, symbol of (op no),
+ NAME result + " : " + dump (result.data) + " und " +
+ NAME operand + " : " + dump (operand.data))
+ ELSE data := dtype (3) FI .
+
+generate dyadic operator:
+ declare (3, var);
+ define (3, next local adr (data));
+ apply (3, push);
+ apply (1, 2, local opn);
+ result := SYMBOL:(op name, 0, result const, local adr, data) .
+
+END PROC get expression;
+
+PROC variable (SYMBOL VAR symbol):
+ symbol := symb;
+ next symbol;
+ IF known (symbol.no)
+ THEN get adr from table
+ ELSE declare var (symbol, nil) FI .
+
+get adr from table:
+ TEXT VAR defined dim;
+ remember (symbol.no, symbol.type, symbol.adr, symbol.data, defined dim) .
+
+END PROC variable;
+
+PROC array var (SYMBOL VAR symbol field):
+(* Aufbau der Dimensionsangaben in der Symboltabelle *)
+(* limit 1 [limit 2]... Basis Elemente *)
+(* jeweils als 2 Byte Integer/Text *)
+(* Die Dimension ist dann DIM/2-2 *)
+ ROW 100 SYMBOL VAR indizes;
+ TEXT VAR limits;
+ INT VAR dim;
+
+ symbol field := symb; next symbol;
+ get paramfield (indizes, dim, int type);
+
+ IF known (symbol field.no)
+ THEN check field dim and data
+ ELSE declare new field FI;
+ generate field index .
+
+check field dim and data:
+ INT VAR type;
+ DTYPE VAR data;
+ remember (symbol field.no, type, symbol field.adr, data, limits);
+
+ IF old dim <> dim
+ THEN basic error (84, symbol field.name, "Dimensioniert in " + text (old dim) + " Dimensionen, gefundene Anzahl Indizes: " + text (dim))
+ ELIF NOT (symbol field.data = data)
+ THEN basic error (intern error, symbol field.name, dump (data) + " <=> " + dump (symbol field.data))
+ ELIF NOT (symbol field.type = type)
+ THEN basic error (intern error, symbol field.name, "Feld erwartet, " + type of (type) + " gefunden") FI .
+
+old dim: (length (limits) DIV 2) - 2 .
+
+declare new field:
+ limits := dim * ""10""0"" + mki (array base) +
+ mki ((10 - array base + 1)**dim);
+ declare var (symbol field, limits) .
+
+generate field index:
+ init field subscription;
+ FOR j FROM 1 UPTO dim
+ REP increase field index;
+ calc index length and limit;
+ calculate field pointer;
+ symbol field.adr := REF pointer
+ PER .
+
+init field subscription:
+ ADDRESS VAR pointer :: next local adr (row type),
+ index adr :: next local adr (int type);
+ INT VAR j, elem length :: (limits ISUB (dim+2)) * typesize (symbol field.data),
+ elem limit,
+ elem offset :: 1 - (limits ISUB (dim+1));
+ BOOL CONST base zero := elem offset = 1 .
+
+increase field index:
+ IF base zero
+ THEN parameter (1, int type, const, index.adr);
+ parameter (2, int type, const, one value);
+ parameter (3, int type, var, index adr);
+ parameter (4, void type, const, nil adr);
+ apply (1, 3, int add);
+ ELSE index adr := index.adr FI .
+
+index: indizes [j] .
+
+calc index length and limit:
+ elem limit := (limits ISUB j) + elem offset;
+ elem length := elem length DIV elem limit .
+
+calculate field pointer:
+ parameter (1, int type, const, symbol field.adr);
+ parameter (2, int type, const, index adr);
+ parameter (3, int type, elem length);
+ parameter (4, int type, elem limit);
+ parameter (5, int type, const, pointer);
+ parameter (6, void type, const, nil adr);
+ apply (1, 5, subscript);
+
+END PROC array var;
+
+PROC get paramfield (ROW 100 SYMBOL VAR params list, INT VAR no):
+ skip (open bracket, del);
+ FOR no FROM 1 UPTO 100
+ REP get expression (params list [no], 0);
+ IF symb.type = del AND symb.no = close bracket
+ THEN next symbol;
+ LEAVE get paramfield
+ ELSE skip (comma, del) FI
+ PER .
+
+END PROC get paramfield;
+
+PROC get paramfield (ROW 100 SYMBOL VAR params list, INT VAR no, DTYPE CONST data):
+ skip (open bracket, del);
+ FOR no FROM 1 UPTO 100
+ REP get expression (params list [no], 0);
+ convert (params list [no], data);
+ IF symb.type = del AND symb.no = close bracket
+ THEN next symbol;
+ LEAVE get paramfield
+ ELSE skip (comma, del) FI
+ PER .
+
+END PROC get paramfield;
+
+PROC examine access rights (ROW 100 SYMBOL VAR params list, INT CONST no):
+
+ INT VAR j;
+ FOR j FROM 1 UPTO no REP
+ IF params list [j].type = const OR params list [j].type = result const
+ THEN IF access (j) = 2
+ THEN basic error (103, NAME params list [j], "im " + text (j)
+ + ". Eintrag der Parameterliste")
+ FI
+ FI
+ PER
+
+END PROC examine access rights;
+
+PROC basic function (SYMBOL VAR ftn): (* Änd. 11.08.87, mo *)
+ init and check function;
+ IF symb.type = del AND symb.no = open bracket
+ THEN get paramfield (params list, number params);
+ FI;
+ apply function .
+
+init and check function:
+ ROW 100 SYMBOL VAR params list;
+ INT VAR number params :: 0;
+ BOOL CONST is usr :: symb.no = usr;
+ IF is usr
+ THEN check proc name
+ FI;
+ ftn := symb;
+ next symbol .
+
+check proc name:
+ next symbol;
+ IF symb.type = array
+ THEN symb.name := subtext (symb.name, 1, LENGTH symb.name-2)
+ ELIF symb.type <> var
+ THEN basic error (2, NAME symb, "Prozedurname erwartet")
+ FI.
+
+apply function:
+ OPN VAR ftn local opn;
+ BOOL VAR ftn found;
+ INT CONST result :: number params+1;
+
+ INT VAR j;
+ FOR j FROM 1 UPTO number params
+ REP parameter (j, params list [j].data, const, params list [j].adr) PER;
+ IF is usr
+ THEN identify proc;
+ examine access rights (params list, number params);
+ ELSE identify function
+ FI;
+
+ ftn.adr := next local adr (ftn.data);
+
+ declare (result, var);
+ define (result, ftn.adr);
+ apply (result, push);
+ apply (1, number params, ftn local opn).
+
+identify proc:
+ identify (deshift (ftn.name), 1, number params, ftn local opn, ftn found);
+ ftn.data := dtype (result);
+ IF NOT ftn found
+ THEN basic error (99, ftn.name, "Parameter angegeben: " + param list (1, number params))
+ ELIF ftn.data = void type
+ THEN basic error (5, ftn.name, "Die Prozedur liefert keinen Wert")
+ ELIF NOT (ftn.data = int type) AND NOT (ftn.data = real type) AND NOT (ftn.data = text type)
+ THEN basic error (5, ftn.name, "Der Typ des Resultats ist nicht erlaubt, gefunden: "
+ + dump (dtype (result)))
+ FI.
+
+identify function:
+ identify (ftn.no, 1, number params, ftn local opn, ftn found);
+ IF ftn found
+ THEN ftn.data := dtype (result)
+ ELIF is basic function (ftn.no)
+ THEN basic error (98, ftn.name, "Argument(e) angegeben: " + param list (1, number params))
+ ELSE basic error (22, ftn.name, "Anweisung(sbestandteil) gefunden")
+ FI.
+
+END PROC basic function;
+
+PROC user function (SYMBOL VAR result): (* DEF/mo *)
+ check if function defined;
+ get arguments if expected;
+ gosub (user function label);
+ copy result.
+
+check if function defined:
+ TEXT CONST scope :: name of (symb.no) + "?";
+ IF NOT known (symb.no)
+ THEN basic error (18, symb.name, "")
+ ELIF scanner scope = scope
+ THEN basic error (85, symb.name, "")
+ FI.
+
+get arguments if expected:
+ INT VAR param counter;
+ TEXT VAR dim text;
+ result := symb;
+ remember (symb.no, symb.type, result.adr, result.data, dim text);
+ INT VAR number of params :: LENGTH dim text DIV 2 - 1;
+ next symbol;
+ IF number of params > 0
+ THEN get all arguments
+ ELIF symb.no = open bracket AND symb.type = del
+ THEN basic error (5, symb.name, "Kein Argument erwartet")
+ FI.
+
+get all arguments:
+ IF symb.no <> open bracket OR symb.type <> del
+ THEN basic error (5, NAME symb, text (number of params) + " Argument(e) erwartet")
+ FI;
+ next symbol;
+ FOR param counter FROM 2 UPTO number of params REP
+ get one argument;
+ skip comma;
+ PER;
+ get one argument;
+ skip close bracket.
+
+get one argument:
+ SYMBOL VAR ftn param;
+ ftn param.no := dim text ISUB param counter;
+ remember (ftn param.no, ftn param.type, ftn param.adr, ftn param.data, ftn param.name);
+ IF ftn param.type <> var
+ THEN basic error (intern error, name of (ftn param.no), "Parametereintrag fehlerhaft")
+ FI;
+ SYMBOL VAR expr res;
+ get expr (expr res, ftn param.data);
+ apply move (ftn param.adr, expr res.adr, ftn param.data).
+
+skip comma:
+ IF symb.no = close bracket AND symb.type = del
+ THEN basic error (5, symb.name, text (number of params) + " Argumente erwartet")
+ ELIF symb.no <> comma OR symb.type <> del
+ THEN basic error (2, NAME symb, " , in Argumentenliste erwartet")
+ FI;
+ next symbol.
+
+skip close bracket:
+ IF symb.no = comma AND symb.type = del
+ THEN basic error (5, symb.name, "Nur " + text (number of params) + " Argument(e) erwartet")
+ ELIF symb.no <> close bracket OR symb.type <> del
+ THEN basic error (2, NAME symb, " ) nach Argumentenliste erwartet")
+ FI;
+ next symbol.
+
+user function label:
+ label list [dim text ISUB 1].
+
+copy result :
+ apply move (next local adr (result.data), result.adr, result.data);
+ result.adr := local adr.
+
+END PROC user function;
+
+PROC apply move (ADDRESS CONST dest adr, source adr, DTYPE CONST datype):
+ parameter (1, datype, var, dest adr);
+ parameter (2, datype, const, source adr);
+ parameter (3, void type, const, nil adr);
+
+ IF datype = int type
+ THEN apply (1, 2, int move)
+ ELIF datype = real type
+ THEN apply (1, 2, real move)
+ ELIF datype = text type
+ THEN apply (1, 2, text move)
+ ELSE basic error (2, "=", "Unbekannter Datentyp: " + dump (datype)) FI .
+
+END PROC apply move;
+
+PROC convert (SYMBOL VAR symbol, DTYPE CONST to data): (* F3/rr *)
+ IF to data = from data
+ THEN
+ ELIF symbol.type = const
+ THEN declare const (symbol, to data)
+ ELIF to data = int type
+ THEN make int
+ ELIF to data = real type
+ THEN make real
+ ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI .
+
+from data : symbol.data .
+
+make real :
+ IF symbol.data = int type
+ THEN parameter (1, symbol.data, const, symbol.adr);
+ parameter (2, real type, var, next local adr (real type));
+ parameter (3, void type, const, nil adr);
+ apply (1, 1, int to real);
+ symbol.adr := local adr;
+ symbol.data := real type
+ ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI .
+
+make int :
+ IF symbol.data = real type
+ THEN parameter (1, symbol.data, const, symbol.adr);
+ parameter (2, int type, var, next local adr (int type));
+ parameter (3, void type, const, nil adr);
+ apply (1, 1, real to int);
+ symbol.adr := local adr;
+ symbol.data := int type
+ ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI .
+
+END PROC convert;
+
+PROC declare const (SYMBOL VAR symbol constant, DTYPE CONST data):
+ convert symb value;
+ IF new constant
+ THEN declare this constant
+ ELSE get table entry FI .
+
+convert symb value:
+ IF data = symbol constant.data
+ THEN LEAVE convert symb value
+ ELIF data = int type AND symbol constant.data = real type
+ THEN symbol constant.name := mki (symbol constant.name RSUB 1);
+ ELIF data = real type AND symbol constant.data = int type
+ THEN symbol constant.name := mkd (symbol constant.name ISUB 1);
+ ELIF data = text type AND symbol constant.data = int type
+ THEN symbol constant.name := text (symbol constant.name ISUB 1)
+ ELIF data = text type AND symbol constant.data = real type
+ THEN symbol constant.name := text (symbol constant.name RSUB 1)
+ ELSE basic error (13, NAME symbol constant, dump (data) + " erwartet, "
+ + dump (symbol constant.data) + " gefunden") FI;
+ symbol constant.data := data .
+
+new constant:
+(* Konstanten werden wie folgt abgelegt: *)
+(* INT: § HL *)
+(* REAL: § MMMMMMME *)
+(* TEXT: § Text *)
+ put name ("§ " + symbol constant.name, symbol constant.no);
+ NOT known (symbol constant.no) .
+
+declare this constant:
+ IF data = int type
+ THEN allocate denoter (symbol constant.adr, symbol constant.name ISUB 1)
+ ELIF data = real type
+ THEN allocate denoter (symbol constant.adr, symbol constant.name RSUB 1)
+ ELIF data = text type
+ THEN allocate denoter (symbol constant.adr, symbol constant.name) FI;
+ recognize (symbol constant.no, const, symbol constant.adr, data, nil) .
+
+get table entry:
+ INT VAR table type;
+ TEXT VAR table dim;
+ remember (symbol constant.no, table type, symbol constant.adr, symbol constant.data, table dim);
+ IF table dim <> nil
+ THEN basic error (intern error, NAME symbol constant, "Dimension in Tabelle ungleich niltext")
+ ELIF NOT (symbol constant.data = data)
+ THEN basic error (intern error, NAME symbol constant, "Falscher DTYPE in Tabelle, erw: " + dump (data)
+ + ", gef: " + dump (symbol constant.data)) FI .
+
+END PROC declare const;
+
+PROC declare var (SYMBOL VAR symbol var, TEXT CONST dim): (* F4/rr *)
+ allocate variable;
+ recognize (symbol var.no, symbol var.type, symbol var.adr, symbol var.data, dim) .
+
+allocate variable :
+ symbol var.adr := next local adr (symbol var.data);
+ IF dim <> nil
+ THEN INT VAR index;
+ ADDRESS VAR dummy;
+ FOR index FROM 2 UPTO no of elements
+ REP dummy := next local adr (symbol var.data) PER;
+ FI .
+
+no of elements:
+ (dim ISUB (LENGTH dim DIV 2)) .
+END PROC declare var;
+
+PROC parameter (INT CONST p, DTYPE CONST d type, INT CONST value):
+ declare (p, d type);
+ declare (p, denoter);
+ define (p, value);
+END PROC parameter;
+
+PROC apply (INT CONST first, number params, TEXT CONST name):
+ identify (name, first, number params, opn, found);
+ IF NOT found
+ THEN errorstop (1051, "PROC " + name + ", Parameter: " + param list (first, number params) + ", nicht gefunden!") FI;
+ apply (first, number params, opn)
+
+END PROC apply;
+
+PROC clear local stack : (* F4/rr *)
+
+ define local variables;
+ clear index;
+ define (rep); index incr one;
+ if local storage less or equal index then goto end;
+ get cell address;
+ clear cell;
+ apply (rep);
+ define (end);
+ clear cell address;
+
+ . define local variables :
+ LABEL VAR rep, end;
+ ADDRESS VAR index;
+ declare (rep); declare (end);
+ allocate variable (index, type size (int type));
+
+ . clear index :
+ parameter (1, int type, var, index);
+ apply (1, 1, clear);
+
+ . index incr one :
+ parameter (1, int type, var, index);
+ apply (1, 1, incone);
+
+ . if local storage less or equal index then goto end :
+ parameter (1, int type, const, loc storage);
+ parameter (2, int type, const, index);
+ apply (1, 2, lsequ);
+ apply (end, TRUE);
+
+ . get cell address :
+ parameter (1, int type, const, LOC 2);
+ parameter (2, int type, const, index);
+ parameter (3, int type, 1);
+ parameter (4, int type, 16000);
+ parameter (5, int type, const, LOC 0);
+ apply (1, 5, subscript);
+
+ . clear cell :
+ parameter (1, int type, var, REF LOC 0);
+ apply (1, 1, clear);
+
+ . clear cell address :
+ parameter (1, int type, var, LOC 0);
+ apply (1, 1, clear);
+ parameter (1, int type, var, LOC 1);
+ apply (1, 1, clear);
+
+END PROC clear local stack;
+
+(* M a i n *)
+(* ̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃ *)
+(* C o m p i l e r *)
+(* ***** G l o b a l e V a r i a b l en ***** *)
+INT VAR end symbol :: 0, error no :: 0, act stat no :: 0, array base :: 0;
+BOOL VAR basic trace, was warning;
+ADDRESS VAR data pos, data text;
+
+
+(* Globale Operationen *)
+OPN VAR basic init, basic frame, basic module, ret, equal op,
+ int minus, real minus, int not opn, real not opn,
+ trace op, ln op, push,
+ int incr, real incr, int add,
+ int move, real move, text move, test,
+ real to int, int to real, subscript,
+ clear, incone, lsequ, (* F4/rr *)
+ basic out text;
+
+(* Parameter VOID *)
+ init ("RTN", 1, 0, ret);
+
+(* Parameter INT *)
+ declare (1, int type);
+ init ("intnot", 1, 1, int not opn); (* mo *)
+ init ("PP", 1, 1, push);
+ init ("LN", 1, 1, ln op);
+ init ("real", 1, 1, int to real);
+ init ("TEST", 1, 1, test);
+ init ("CLEAR", 1, 1, clear);
+ init ("INCONE", 1, 1, incone);
+ init ("trace", 1, 1, trace op);
+
+(* Parameter INT INT *)
+ declare (2, int type);
+ init ("COMPLINT", 1, 2, int minus);
+ init ("MOVE", 1, 2, int move);
+ init ("INC", 1, 2, int incr);
+ init ("EQU", 1, 2, equal op);
+ init ("LSEQU", 1, 2, lsequ);
+
+(* Parameter INT INT INT *)
+ declare (3, int type);
+ init ("ADD", 1, 3, int add);
+
+(* Paramter REAL *)
+ declare (1, real type);
+ init ("realnot", 1, 1, real not opn); (* mo *)
+ init ("cint", 1, 1, real to int);
+
+(* Parameter REAL REAL *)
+ declare (2, real type);
+ init ("COMPLREAL", 1, 2, real minus);
+ init ("FMOVE", 1, 2, real move);
+ init ("INCR", 1, 2, real incr);
+
+(* Parameter TEXT *)
+ declare (1, text type);
+ init ("basicout", 1, 1, basic out text);
+
+(* Paramter TEXT TEXT *)
+ declare (2, text type);
+ init ("TMOVE", 1, 2, text move);
+
+(* Parameter ADDRESS INT DENOTER DENOTER ADDRESS *)
+ declare (3, denoter);
+ declare (4, denoter);
+ init ("SUBSCRIPT", 1, 5, subscript);
+
+PROC init (TEXT CONST name, INT CONST local from, number params, OPN VAR local opn):
+ identify (name, local from, number params, local opn, found);
+ IF NOT found
+ THEN errorstop (1051, "PROC init (TC, IC, IC, OPN VAR): OPN für """ + name + """ nicht gefunden") FI
+END PROC init;
+
+(* Runtime Konstanten *)
+ ADDRESS VAR true value, false value, niltext value,
+ zero value, one value, two value, three value,
+ comma value, int one value, real one value,
+ loc storage; (* F4/rr *)
+
+(* +++++ Globale Variablen +++++ *)
+ BOOL VAR proc found;
+ INT VAR deftype, field elems, i, params;
+ ROW 100 SYMBOL VAR param;
+ SYMBOL VAR base size, begin range, end range, expr result, field, filename,
+ from, len, image, label, old name, new name,
+ question, size, tab pos, var result;
+ TEXT VAR constant, field size, proc name;
+
+(* Label-Verwaltung *)
+LET label list size = 4100;
+BOUND ROW label list size LABEL VAR label list;
+DATASPACE VAR label ds;
+INITFLAG VAR label init :: FALSE;
+INT VAR last label no;
+
+(* ***** I n t e r f a c e P r o z d u r e n ***** *)
+PROC basic:
+ basic (last param)
+END PROC basic;
+
+PROC basic (TEXT CONST basic file name):
+ basic (basic file name, nil)
+END PROC basic;
+
+PROC basic (TEXT CONST basic file name, prog name):
+ IF NOT exists (basic file name)
+ THEN errorstop ("""" + basic file name + """ gibt es nicht")
+ ELSE FILE VAR basic file :: sequential file (modify, basic file name); (* F5/rr *)
+ headline (basic file, basic file name);
+ last param (basic file name);
+ basic (basic file, prog name)
+ FI;
+
+END PROC basic;
+
+PROC basic (FILE VAR source file, TEXT CONST prog name):
+ IF prog name <> nil CAND prog name is not a tag (* F5/rr *)
+ THEN errorstop ("unzulässiger Programmname : """ + prog name + """");
+ FI;
+ modify (source file); (* F5/rr *)
+ disable stop;
+ init label table;
+ store status;
+ coder on (data allocation by coder);
+ compile (source file, progname);
+ restore status;
+ start basic prog .
+
+prog name is not a tag : (* F5/rr *)
+ LET tag = 1;
+ INT VAR symbol type;
+ TEXT VAR symbol name;
+ scan (prog name);
+ next symbol (symbol name, symbol type);
+ symbol name <> prog name OR symbol type <> tag .
+
+init label table:
+ IF NOT initialized (label init)
+ THEN label ds := nilspace;
+ label list := label ds;
+ FI .
+
+store status:
+ INT CONST source line :: line no (source file),
+ source col :: col (source file);
+ BOOL CONST check status :: check;
+ check on .
+
+restore status:
+ to line (source file, source line);
+ col (source file, source col);
+ IF NOT check status
+ THEN check off FI .
+
+start basic prog:
+ IF error no > 0 OR is error
+ THEN basic error end
+ ELSE normal end
+ FI;
+ close (source file) .
+
+basic error end:
+ coder off (FALSE, FALSE, nop);
+ IF is error
+ THEN put error;
+ clear error
+ ELSE display (""13""10""10""); (* F20/rr *)
+ display (text (error no) + compiler err msg);
+ display (""13""10""10"");
+ display (compiler msg);
+ display (""13""10"");
+ IF sysout <> ""
+ THEN line (2);
+ put (text (error no) + compiler err msg);
+ line (2);
+ put (compiler msg);
+ line
+ FI
+ FI;
+ show file and error .
+
+show file and error: (* F20/rr *)
+ IF anything noted CAND command dialogue
+ THEN noteedit (source file);
+ FI;
+ errorstop (nil) .
+
+normal end:
+ IF prog name = nil
+ THEN run basic proc
+ ELSE insert basic proc FI;
+ IF warnings AND was warning
+ THEN show file and error
+ FI.
+
+run basic proc:
+ coder off (FALSE, TRUE, basic frame);
+ display (""13""10"") .
+
+insert basic proc:
+ coder off (TRUE, TRUE, basic frame);
+ coder on (data allocation by coder);
+ coder off (FALSE, FALSE, basic init);
+ display (""13""10"") .
+
+END PROC basic;
+
+PROC compile (FILE VAR source file, TEXT CONST progname):
+ enable stop;
+ init compiler;
+ init basic prog;
+
+ begin scanning (source file);
+ next symbol;
+ get statement group (eop);
+ end compiling .
+
+init compiler:
+ end symbol := 0;
+ error no := 0;
+ act stat no := 0;
+ array base := 0;
+ basic trace := FALSE;
+ was warning := FALSE;
+
+ init storage;
+ init label;
+ init data;
+ init table .
+
+init label:
+ TEXT VAR local stat no;
+ INT VAR stat nos;
+ init stat no (source file, error no); (* F21/rr *)
+ IF error no > 0 THEN LEAVE compile FI;
+ all stat no (local stat no, stat nos);
+ FOR i FROM 1 UPTO stat nos
+ REP declare (label list [i]) PER;
+ last label no := stat nos. (* DEF/mo *)
+
+init basic prog:
+ LIB VAR packet;
+ declare (basic packet name, packet);
+ define (packet);
+ parameter (1, void type, const, nil adr);
+ declare (basic init);
+ IF progname = nil
+ THEN declare (basic frame)
+ ELSE declare (progname, 1, 0, basic frame) FI;
+ declare (basic module);
+ declare runtime const;
+ declare basic init;
+ declare basic frame;
+ declare basic module .
+
+basic packet name:
+ IF progname <> ""
+ THEN "BASIC." + progname
+ ELSE "BASIC"
+ FI.
+
+declare runtime const:
+ allocate variable (data text, type size (text type));
+ allocate variable (data pos, type size (int type));
+ allocate variable (loc storage, type size (int type)); (* F4/rr *)
+
+ allocate denoter (true value, 0);
+ allocate denoter (false value, -1);
+ allocate denoter (niltext value, nil);
+ allocate denoter (one value, 1);
+ allocate denoter (two value, 2);
+ allocate denoter (three value, 3);
+ allocate denoter (real one value, 1.0);
+ allocate denoter (comma value, ",");
+
+ zero value := true value;
+ int one value := one value .
+
+declare basic init:
+ begin module;
+ define (basic init, 4);
+ parameter (1, text type, var, data text);
+ parameter (2, int type, var, data pos);
+ apply (1, 2, "initdata");
+ parameter (1, void type, const, nil adr);
+ apply (1, 0, ret);
+ end module .
+
+declare basic frame:
+ begin module;
+ define (basic frame, 4);
+
+ IF prog name = nil
+ THEN parameter (1, void type, const, nil adr);
+ apply (1, 0, basic init);
+ FI;
+
+ declare (1, int type);
+ declare (1, const);
+ define (1, 0);
+ parameter (2, void type, const, nil adr);
+ apply (1, 1, ln op);
+
+ apply (1, 0, "disablestop");
+ apply (1, 0, "startbasic");
+
+ parameter (1, int type, var, data pos);
+ parameter (2, int type, const, one value);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, int move);
+
+ parameter (1, void type, const, nil adr);
+ apply (1, 0, basic module);
+ apply (1, 0, "endbasic");
+ parameter (1, void type, const, nil adr);
+ apply (1, 0, ret);
+ end module .
+
+declare basic module:
+ LABEL VAR start lab;
+ begin module;
+ define (basic module);
+ declare (start lab);
+ apply (1, 0, "enablestop");
+ gosub (start lab);
+ parameter (1, void type, const, nil adr);
+ apply (1, 0, "returnerror"); (* mo *)
+ define (start lab);
+ clear local stack . (* F4/rr *)
+
+end compiling:
+ parameter (1, void type, const, nil adr);
+ apply (1, 0, ret);
+ define (loc storage, local storage - 1); (* F4/rr *)
+ set length of local storage (basic module, max (2, local storage)); (* F4/rr *)
+ IF error no = 0
+ THEN end module FI .
+
+END PROC compile;
+
+PROC get statement group (INT CONST new symbol):
+(* 'get statement group' compiliert das ganze Programm bis zum Auftreten *)
+(* von 'end symbol' *)
+ disable stop;
+ new end symbol;
+ get all basic lines;
+ old end symbol .
+
+new end symbol:
+ INT CONST old symbol :: end symbol;
+ end symbol := new symbol .
+
+old end symbol:
+ end symbol := old symbol .
+
+get all basic lines:
+ REP get basic line;
+
+ IF is error
+ THEN error handling
+ ELIF symb.type = eos
+ THEN check this eos FI
+ PER .
+
+error handling: (* F20/rr *)
+ IF error in basic program
+ THEN error no INCR 1
+ ELIF end of source file
+ THEN clear error;
+ LEAVE get all basic lines
+ ELIF halt from terminal
+ THEN LEAVE get statement group
+ ELSE error no INCR 1;
+ handle internal error;
+ LEAVE get statement group
+ FI;
+ clear error;
+ scope compulsory (TRUE); (* DEF/mo *)
+ set scope (""); (* DEF/mo *)
+ next statement;
+ next symbol .
+
+error in basic program:
+ errorcode = 101.
+
+end of source file:
+ errorcode = 99.
+
+halt from terminal:
+ errorcode = 1.
+
+handle internal error : (* F20/rr *)
+ TEXT VAR error :: "BASIC-Compiler ERROR";
+ IF errorcode <> 0
+ THEN error CAT " #" + text (errorcode) FI;
+ IF errorline > 0
+ THEN error CAT " at " + text (errorline) FI;
+ error CAT " : ";
+ error CAT errormessage;
+ IF sysout <> "" THEN putline (error) FI;
+ note (error);
+ noteline;
+ clear error;
+ errorstop (error).
+
+check this eos:
+ IF symb.no = eol
+ THEN next symbol
+ ELIF symb.no = -new symbol OR symb.no = eop
+ THEN LEAVE get all basic lines (* mo *)
+ ELSE basic error (intern error, NAME symb, "EOL erwartet, " +
+ type of (symb.type) + " gefunden")
+ FI .
+
+END PROC get statement group;
+
+PROC get basic line (INT CONST new symbol):
+(*Die Abbruchbedingungen werden neu gesetzt und bei Verlassen der *)
+(*Prozedur zurückgesetzt. *)
+ disable stop;
+ INT CONST old symbol :: end symbol;
+ end symbol := new symbol;
+ get basic line;
+ end symbol := old symbol .
+
+END PROC get basic line;
+
+PROC get basic line:
+(* 'get basic line' behandelt genau eine Zeile mit Zeilennummer. *)
+ enable stop;
+ IF symb.type = stat no
+ THEN gen stat no (symb.no) FI;
+
+ REP get one basic statement PER .
+
+get one basic statement:
+(* 'get one basic statement' behandelt genau ein Statement. *)
+ IF symb.type = eos
+ THEN get end of statement
+ ELIF symb.type = res word OR symb.type = var OR symb.type = array
+ THEN get one statement
+ ELSE basic error (2, NAME symb, type of (symb.type) + " ohne Zusammenhang") FI .
+
+get end of statement:
+ IF symb.no = eos
+ THEN next symbol
+ ELSE LEAVE get basic line FI .
+
+get one statement:
+ IF symb.type = res word
+ THEN get res word statement
+ ELIF symb.type = var OR symb.type = array
+ THEN let statement
+ FI;
+ skip comma if else expected;
+ IF symb.type <> eos
+ THEN basic error (2, NAME symb, "EOS erwartet, " + type of (symb.type) + " gefunden")
+ FI.
+
+skip comma if else expected:
+ IF end symbol = else s AND symb.type = del AND symb.no = comma
+ THEN next symbol;
+ IF symb.type <> eos OR symb.no <> -else s
+ THEN basic error (2, NAME symb, "ELSE erwartet")
+ FI
+ FI.
+
+get res word statement:
+ SELECT symb.no OF
+ CASE as s : basic error (90, symb.name, "")
+ CASE base s : basic error (91, symb.name, "")
+ CASE call s,
+ chain s : call statement
+ CASE clear s : not implemented
+ CASE close s : not implemented
+ CASE cls s : cls statement (* mo *)
+ CASE common s : not implemented
+ CASE data s : data statement
+ CASE def s : def statement (* mo *)
+ CASE defint s,
+ defdbl s,
+ defsng s,
+ defstr s : def type statement
+ CASE dim s : dim statement
+ CASE else s : basic error (92, symb.name, "")
+ CASE end s : end statement
+ CASE error s : error statement
+ CASE field s : not implemented
+ CASE for s : for statement
+ CASE get s : not implemented
+ CASE gosub s : gosub statement
+ CASE goto s : goto statement
+ CASE if s : if statement
+ CASE input s : input statement
+ CASE kill s : kill statement
+ CASE let s : let statement
+ CASE line in s: line statement
+ CASE lprint s : lprint statement (* mo *)
+ CASE l set s : l set statement
+ CASE mid s : mid statement
+ CASE name s : name statement
+ CASE next s : basic error (1, symb.name, "")
+ CASE on s : on statement
+ CASE open s : not implemented
+ CASE option s : option statement
+ CASE print s : print statement
+ CASE put s : not implemented
+ CASE rand s : randomize statement
+ CASE read s : read statement
+ CASE rem s : rem statement
+ CASE restore s: restore statement
+ CASE resume s : not implemented
+ CASE return s : return statement
+ CASE r set s : r set statement
+ CASE step s : basic error (93, symb.name, "")
+ CASE stop s : stop statement
+ CASE sub : basic error (101, symb.name, "")
+ CASE swap s : swap statement
+ CASE tab s : basic error (94, symb.name, "")
+ CASE then s : basic error (95, symb.name, "")
+ CASE to s : basic error (96, symb.name, "")
+ CASE troff s : troff statement
+ CASE tron s : tron statement
+ CASE using s : basic error (97, symb.name, "")
+ CASE wait s : not implemented
+ CASE wend s : basic error (30, symb.name, "")
+ CASE while s : while statement
+ CASE width s : width statement
+ CASE write s : write statement
+ OTHERWISE basic error (104, symb.name, "") END SELECT.
+
+not implemented:
+ basic error (100, symb.name, "").
+
+call statement:
+(*CALL <proc name> [(<argument list>)] *)
+ next symbol;
+ get proc name;
+ get proc parameter;
+ apply proc .
+
+get proc name:
+ proc name := symb.name;
+ IF symb.type = array
+ THEN proc name := subtext (proc name, 1, LENGTH proc name-2) FI;
+ next symbol .
+
+get proc parameter:
+ params := 0;
+ IF symb.type = del AND symb.no = open bracket
+ THEN get paramfield (param, params) FI .
+
+apply proc:
+ OPN VAR proc opn;
+ FOR i FROM 1 UPTO params
+ REP parameter (i, param [i].data, const, param [i].adr) PER;
+ identify (deshift (proc name), 1, params, proc opn, proc found);
+
+ IF NOT proc found
+ THEN basic error (99, proc name, "Parameter angegeben: " + param list (1, params))
+ ELIF result found
+ THEN basic error (5, proc name, "Kein Resultat erlaubt (gefunden: " + dump (result data) + ")")
+ FI;
+
+ examine access rights (param, params);
+
+ parameter (params+1, void type, const, nil adr);
+ apply (1, params, proc opn) .
+
+result found:
+ NOT (result data = void type) .
+
+result data:
+ dtype (params+1) .
+
+cls statement:
+(*CLS *)
+ next symbol;
+ apply (1, 0, "nextpage").
+
+data statement:
+(*DATA <list of constants> *)
+ DTYPE VAR const data;
+ data line (act stat no);
+ REP IF next data (constant, const data)
+ THEN data (constant, const data)
+ ELSE basic error (2, "EOL", "Daten fehlen !") FI;
+
+ next symbol;
+ IF symb.type = eos
+ THEN LEAVE data statement
+ ELIF symb.type <> del OR symb.no <> comma
+ THEN basic error (2, NAME symb, " , erwartet") FI
+ PER .
+
+def statement: (* DEF/mo *)
+(*DEF FN<name> [(parameter list)] = <function definition> *)
+ get function name;
+ store label of function;
+ get all params;
+ get function definition.
+
+get function name:
+ next symbol;
+ IF symb.type <> user fn
+ THEN treat wrong function name
+ ELIF LENGTH symb.name <= 2
+ THEN basic error (2, symb.name, "Unerlaubter Funktionsname")
+ ELIF known (symb.no)
+ THEN basic warning ("Die Funktion """ + symb.name + """ wurde bereits definiert");
+ was warning := TRUE
+ FI;
+ SYMBOL VAR function :: symb;
+ function.name := name of (function.no).
+
+treat wrong function name:
+ IF symb.type = var OR symb.type = array
+ THEN basic error (2, symb.name, "Funktionsname muß mit FN beginnen")
+ ELSE basic error (2, NAME symb, "Funktionsname erwartet")
+ FI.
+
+store label of function:
+ IF last label no < label list size
+ THEN last label no INCR 1
+ ELSE errorstop ("Zu viele Label")
+ FI;
+ declare (label list [last label no]);
+ TEXT VAR dim text :: "";
+ dim text CAT last label no;
+ recognize (function.no, user fn, niladr, function.data, dim text).
+
+get all params:
+ set scope (function.name + "?");
+ next symbol;
+ IF symb.type = del AND symb.no = open bracket
+ THEN REP
+ try to get a param;
+ try to get del
+ UNTIL symb.no = close bracket OR
+ (symb.type <> del AND symb.type <> var) PER;
+ skip close bracket
+ FI.
+
+try to get a param:
+ REP
+ IF symb.type <> var
+ THEN next symbol
+ FI;
+ IF symb.type <> var
+ THEN careful error (2, NAME symb, "Parametervariable erwartet");
+ IF symb.type <> del
+ THEN next symbol
+ FI
+ ELSE treat param
+ FI
+ UNTIL symb.type <> del OR symb.no = close bracket PER.
+
+treat param:
+ IF NOT known (symb.no)
+ THEN declare var (symb, nil);
+ ELIF already appeared in param list
+ THEN careful error (89, symb.name, "");
+ FI;
+ dim text CAT symb.no.
+
+already appeared in param list:
+ INT VAR param counter;
+ FOR param counter FROM 2 UPTO LENGTH dim text DIV 2 REP
+ IF (dim text ISUB param counter) = symb.no
+ THEN LEAVE already appeared in param list WITH TRUE
+ FI
+ PER;
+ FALSE.
+
+try to get del:
+ IF symb.type = var
+ THEN next symbol
+ FI;
+ IF symb.type = var OR (symb.type = del CAND (symb.no <> comma AND symb.no <> close bracket))
+ THEN careful error (2, symb.name, " , in Parameterliste erwartet")
+ FI.
+
+skip close bracket:
+ IF symb.type = del AND symb.no = close bracket
+ THEN next symbol
+ ELSE careful error (2, NAME symb, " ) nach Parameterliste erwartet")
+ FI.
+
+get function definition:
+ scope compulsory (FALSE);
+ skip (equal, operator);
+ generate forward jump;
+ define this label;
+ get expr (expr result, function.data);
+ recognize (function.no, user fn, expr result.adr, function.data, dim text);
+ goret;
+ define (behind);
+ scope compulsory (TRUE);
+ set scope ("").
+
+generate forward jump:
+ LABEL VAR behind;
+ declare (behind);
+ apply (behind).
+
+define this label:
+ define (label list [last label no]).
+
+
+def type statement:
+(*DEFINT/DBL/SNG/STR <range(s) of letters> *)
+ deftype := symb.no;
+ next symbol;
+ REP get letter (begin range);
+ IF symb.type = operator AND symb.no = minus
+ THEN next symbol;
+ get letter (end range)
+ ELSE end range := begin range FI;
+
+ IF name of (begin range.no) > name of (end range.no)
+ THEN basic error (87, begin range.name + "-" + end range.name, "")
+ ELSE define chars (name of (begin range.no), name of (end range.no), data type) FI;
+
+ IF symb.type = eos
+ THEN LEAVE def type statement
+ ELSE skip (comma, del) FI
+ PER .
+
+data type:
+ SELECT deftype OF
+ CASE defint s: int type
+ CASE defstr s: text type
+ OTHERWISE real type ENDSELECT .
+
+ dim statement:
+(*DIM <list of subscripted var results> *)
+ next symbol;
+ REP get field var;
+ get field size;
+ declare field;
+
+ IF symb.type = eos
+ THEN LEAVE dim statement
+ ELSE skip (comma, del) FI
+ PER .
+
+get field var:
+ IF symb.type = array
+ THEN IF known (symb.no)
+ THEN basic error (10, symb.name, "")
+ ELSE field := symb;
+ next symbol
+ FI
+ ELIF symb.type = var
+ THEN basic error (2, symb.name, "Dimensionsangabe fehlt")
+ ELSE basic error (2, NAME symb, "Feldname erwartet")
+ FI.
+
+get field size:
+ field size := "";
+ field elems := 1;
+ skip (open bracket, del);
+
+ REP get const (size, int type);
+ INT CONST field limit :: size.name ISUB 1;
+ IF field limit < array base
+ THEN basic error (88, NAME size, "Die Obergrenze muß >= " +
+ text (array base) + " sein")
+ ELSE field size CAT (mki (field limit));
+ field elems := field elems * (field limit + 1 - array base)
+ FI;
+
+ IF symb.type = del AND symb.no = close bracket
+ THEN next symbol;
+ LEAVE get field size
+ ELSE skip (comma, del) FI
+ PER .
+
+declare field:
+ field size CAT mki (array base);
+ field size CAT mki (field elems);
+ declare var (field, field size) .
+
+end statement:
+(*END *)
+ next symbol;
+ parameter (1, void type, const, nil adr);
+ apply (1, 0, ret) .
+
+error statement:
+(*ERROR <integer expr result> *)
+ next symbol;
+ get expr (expr result, int type);
+ parameter (1, int type, const, expr result.adr);
+ parameter (2, text type, const, niltext value);
+ apply (1, 2, "errorstop") .
+
+gosub statement:
+(*GOSUB <line number> *)
+ next symbol;
+ get const (label, int type);
+ gosub (this label) .
+
+goto statement :
+(*GOTO <line number> *)
+ next symbol;
+ get const (label, int type);
+ apply (this label) .
+
+this label: label list [label pos (label no)] .
+label no: label.name ISUB 1 .
+
+input statement:
+(*INPUT [;]["Anfrage" ;/,] Variable [, Variable] *)
+ ROW 100 DTYPE VAR input var data;
+ INT VAR number input vars;
+ LABEL VAR input lab;
+ next symbol;
+ declare (input lab);
+ define (input lab);
+ get semicolon for cr lf;
+ get question and question mark;
+ apply (1, 3, "readinput");
+ get input eof;
+ get data types of input vars (input var data, number input vars); (* F25/rr *)
+ check data types of input vars; (* F8/F25/rr *)
+ apply (1, 0, "inputok");
+ apply (input lab, FALSE);
+ assign list of input var . (* F8/F25/rr *)
+
+get semicolon for cr lf:
+ IF symb.type = del AND symb.no = semicolon
+ THEN next symbol;
+ parameter (1, bool type, const, false value)
+ ELSE parameter (1, bool type, const, true value) FI .
+
+get question and question mark:
+ IF symb.type = const AND symb.data = text type
+ THEN get const (question, text type);
+ parameter (2, text type, const, question.adr);
+ parameter (3, bool type, const, question mark value);
+ next symbol
+ ELSE parameter (2, text type, const, niltext value);
+ parameter (3, bool type, const, true value); (* F7/rr *)
+ FI .
+
+question mark value:
+ IF symb.type = del AND symb.no = semicolon
+ THEN true value
+ ELIF symb.type = del AND symb.no = comma
+ THEN false value
+ ELSE basic error (2, NAME symb, " ; oder , erwartet"); nil adr FI .
+
+get input eof:
+ IF symb.type = res word AND symb.no = eof s
+ THEN next symbol;
+ get const (label, int type);
+ apply (1, 0, "inputeof");
+ apply (this label, TRUE)
+ FI .
+
+check data types of input vars : (* F8/F25/rr *)
+ FOR i FROM 1 UPTO number input vars
+ REP parameter (1, int type, const, input data type);
+ apply (1, 1, "checkinput");
+ apply (input lab, FALSE);
+ PER .
+
+input data type : (* F8/F25/rr *)
+ IF input var data (i) = int type THEN one value
+ ELIF input var data (i) = real type THEN two value
+ ELIF input var data (i) = text type THEN three value
+ ELSE zero value
+ FI .
+
+assign list of input var : (* F8/F25/rr *)
+ REP get var (var result);
+ parameter (1, var result. data, var, var result. adr);
+ apply (1, 1, "assigninput");
+
+ IF symb.type = del AND symb.no = comma
+ THEN next symbol
+ ELSE LEAVE assign list of input var FI
+ PER .
+
+kill statement:
+(*KILL <filename> *)
+ next symbol;
+ get expr (filename, text type);
+
+ parameter (1, text type, const, filename.adr);
+ parameter (2, quiet type, const, next local adr (int type));
+ apply (2, 0, "quiet");
+ apply (1, 2, "forget") .
+
+let statement:
+(*[LET] <var> = <expression> *)
+ IF symb.type = res word AND symb.no = let s
+ THEN next symbol FI;
+ get var (var result);
+ skip (equal, operator);
+ get expr (expr result, var result.data);
+ apply move (var result.adr, expr result.adr, var result.data).
+
+line statement: (* F9/rr *)
+(*1. LINE INPUT [;][<"prompt string">;]<string var result> *)
+ next symbol;
+ skip (input s, res word);
+ get semicolon;
+ get prompt string;
+ apply (1, 3, "readinput");
+ assign string var result .
+
+get semicolon:
+ IF symb.type = del AND symb.no = semicolon
+ THEN next symbol;
+ parameter (1, bool type, const, false value)
+ ELSE parameter (1, bool type, const, true value) FI .
+
+get prompt string:
+ IF symb.type = const AND symb.data = text type
+ THEN get const (question, text type);
+ parameter (2, text type, const, question.adr);
+ skip (semicolon, del);
+ ELSE parameter (2, text type, const, niltext value);
+ FI;
+ parameter (3, bool type, const, false value) .
+
+assign string var result :
+ get var (var result, text type);
+ parameter (1, text type, var, var result.adr);
+ apply (1, 1, "assigninputline") .
+
+lprint statement:
+(*LPRINT (cf. PRINT) *)
+ apply (1, 0, "switchtoprintoutfile");
+ print statement;
+ apply (1, 0, "switchbacktooldsysoutstate").
+
+l set statement:
+(*LSET <string var> = <string expression> *)
+ next symbol;
+ get var (var result, text type);
+ skip (equal, operator);
+ get expr (expr result, text type);
+ parameter (1, text type, var, var result.adr);
+ parameter (2, text type, const, expr result.adr);
+ apply (1, 2, "lset") .
+
+mid statement:
+(*MID$ (<string var>, from [,len]) = <string expression> *)
+ next symbol;
+ skip (open bracket, del);
+ get var (var result, text type);
+ skip (comma, del);
+ get expr (from, int type);
+ IF symb.type = del AND symb.no = comma
+ THEN next symbol;
+ get expr (len, int type)
+ ELSE len := nilsymbol FI;
+ skip (close bracket, del);
+ skip (equal, operator);
+ get expr (expr result, text type);
+
+ parameter (1, text type, var, var result.adr);
+ parameter (2, int type, const, from.adr);
+ parameter (3, text type, const, expr result.adr);
+ IF len.data = int type
+ THEN parameter (4, int type, const, one value);
+ parameter (5, int type, const, len.adr);
+ parameter (6, text type, var, next local adr (text type));
+ apply (3, 3, "subtext");
+ parameter (3, text type, const, local adr);
+ FI;
+ apply (1, 3, "replace") .
+
+name statement:
+(*NAME <old filename> AS <new filename> *)
+ next symbol;
+ get expr (old name, text type);
+ skip (as s, res word);
+ get expr (new name, text type);
+ parameter (1, text type, const, old name.adr);
+ parameter (2, text type, const, new name.adr);
+ apply (1, 2, "rename") .
+
+option statement:
+(*OPTION BASE 0|1 *)
+ next symbol;
+ skip (base s, res word);
+ get const (base size, int type);
+ IF new array base > 1
+ THEN basic error (105, NAME base size, "")
+ ELSE array base := new array base
+ FI.
+
+new array base:
+ base size.name ISUB 1.
+
+randomize statement:
+(*RANDOMIZE [<expression>] *)
+ next symbol;
+ IF symb.type = eos
+ THEN apply (1, 0, "initrnd")
+ ELSE get expr (expr result, real type);
+ parameter (1, real type, const, expr result.adr);
+ apply (1, 1, "initrnd")
+ FI .
+
+read statement:
+(*READ <list of var> *)
+ next symbol;
+ REP get var (var result);
+ parameter (1, text type, const, data text);
+ parameter (2, int type, var, data pos);
+ parameter (3, var result.data, var, var result.adr);
+ apply (1, 3, "read");
+
+ IF symb.type = eos
+ THEN LEAVE read statement
+ ELSE skip (comma, del) FI
+ PER .
+
+rem statement:
+(*REM <remark> *)
+ next statement;
+ symb := SYMBOL : ("", eol, eos, LOC 0, void type);
+ LEAVE get basic line .
+
+restore statement:
+(*RESTORE [<line number>] *)
+ next symbol;
+ IF symb.type = eos
+ THEN parameter (1, int type, var, data pos);
+ parameter (2, int type, const, one value);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, int move);
+ ELSE get const (label, int type);
+ parameter (1, text type, const, data text);
+ parameter (2, int type, var, data pos);
+ parameter (3, int type, const, label.adr);
+ apply (1, 3, "restore")
+ FI .
+
+return statement :
+(*RETURN *)
+ next symbol;
+ goret .
+
+r set statement:
+(*RSET <string var> = <string expression> *)
+ next symbol;
+ get var (var result, text type);
+ skip (equal, operator);
+ get expr (expr result, text type);
+ parameter (1, text type, var, var result.adr);
+ parameter (2, text type, const, expr result.adr);
+ apply (1, 2, "rset") .
+
+stop statement:
+(*STOP *)
+ next symbol;
+ expr result := SYMBOL: (nil, any, const, nil adr, int type);
+ expr result.name CAT act stat no;
+ declare const (expr result, int type);
+ parameter (1, int type, const, expr result.adr);
+ apply (1, 1, "basicstop");
+ parameter (1, void type, const, nil adr);
+ apply (1, 0, ret) .
+
+swap statement:
+(*SWAP <var>,<var> *)
+ next symbol;
+ get var (var result);
+ parameter (1, var result.data, var, var result.adr);
+ DTYPE CONST first var result data :: var result.data;
+ skip (comma, del);
+ get var (var result);
+ IF first var result data = var result.data
+ THEN parameter (2, var result.data, var, var result.adr);
+ apply (1, 2, "swap")
+ ELSE basic error (106, var result.name, "gefunden: "
+ + dump (first var result data) + ", " + dump (var result.data))
+ FI.
+
+troff statement:
+(*TROFF *)
+ next symbol;
+ basic trace := FALSE .
+
+tron statement:
+(*TRON *)
+ next symbol;
+ basic trace := TRUE .
+
+width statement:
+(*WIDTH Größe *)
+ next symbol;
+ get expr (expr result, int type);
+ parameter (1, int type, const, expr result.adr);
+ apply (1, 1, "width") .
+
+write statement:
+(*WRITE [<list of expr results>] *)
+ next symbol;
+
+ IF symb.type = eos
+ THEN apply (1, 0, "nextline")
+ ELSE write list of expr results FI .
+
+write list of expr results:
+ REP get expr (expr result);
+ parameter (1, expr result.data, const, expr result.adr);
+ apply (1, 1, "basicwrite");
+
+ IF symb.type = eos
+ THEN apply (1, 0, "nextline");
+ LEAVE write list of expr results
+ ELSE skip (comma, del);
+ parameter (1, text type, const, comma value);
+ apply (1, 1, "basicout")
+ FI
+ PER .
+
+END PROC get basic line;
+
+PROC gen stat no (INT CONST local stat no):
+(* Die Zeilennummer wird als Label definiert *)
+(* Die Prozedur 'stat no' wird mit der Statementnummer aufgerufen *)
+ act stat no := local stat no;
+ define (label list [label pos (act stat no)]);
+
+ declare (1, int type);
+ declare (1, const);
+ define (1, act stat no);
+ parameter (2, void type, const, nil adr);
+ apply (1, 1, ln op);
+
+ IF basic trace
+ THEN expr result := SYMBOL: (nil, any, const, nil adr, int type);
+ expr result.name CAT act stat no;
+ declare const (expr result, int type);
+ parameter (1, int type, const, expr result.adr);
+ apply (1, 1, trace op)
+ FI;
+ next symbol .
+
+END PROC gen stat no;
+
+PROC for statement:
+(*FOR <var> = x TO y [STEP z] *)
+ SYMBOL VAR local var result, init val, limit val, step val;
+ LABEL VAR start loop, end loop;
+ INT CONST for stat no := act stat no, (* F29/rr *)
+ for scan line no := scan line no;
+ TEXT CONST for symb name := symb.name;
+ declare (start loop);
+ declare (end loop);
+
+ next symbol;
+ get loop var;
+ skip (equal, operator);
+ get expr (init val, local var result.data);
+ skip (to s, res word);
+ get expr (limit val, local var result.data);
+ get step val;
+
+ init loop var;
+ define (start loop);
+ gen check of variable;
+ get statement group (next s);
+
+ IF symb.type = eos AND symb.no = -next s
+ THEN next var statement
+ ELSE define (end loop);
+ basic error ("Compiler", 26, for scan line no, for stat no, for symb name, "", TRUE); (* F29/rr *)
+ FI .
+
+get loop var:
+ get var (local var result);
+ IF NOT (local var result.data = int type OR local var result.data = real type)
+ THEN basic error (2, NAME local var result, "INT oder REAL erwartet, "
+ + dump (local var result.data) + " gefunden")
+ FI .
+
+get step val:
+ IF symb.type = res word AND symb.no = step s
+ THEN next symbol;
+ get expr (step val, local var result.data)
+ ELIF local var result.data = int type
+ THEN step val.data := int type;
+ step val.adr := int one value
+ ELSE step val.data := real type;
+ step val.adr := real one value
+ FI .
+
+init loop var:
+ IF local var result.data = int type
+ THEN init int loop
+ ELSE init real loop FI .
+
+init int loop:
+ IF limit val.type = var
+ THEN parameter (1, int type, var, next local adr (int type));
+ parameter (2, int type, const, limit val.adr);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, int move);
+ limit val.adr := local adr;
+ FI;
+ IF step val.type = var
+ THEN parameter (1, int type, var, next local adr (int type));
+ parameter (2, int type, const, step val.adr);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, int move);
+ step val.adr := local adr;
+ FI;
+ IF NOT (init val.no = local var result.no)
+ THEN parameter (1, int type, var, local var result.adr);
+ parameter (2, int type, const, init val.adr);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, int move)
+ FI .
+
+init real loop:
+ IF limit val.type = var
+ THEN parameter (1, real type, var, next local adr (real type));
+ parameter (2, real type, const, limit val.adr);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, real move);
+ limit val.adr := local adr;
+ FI;
+ IF step val.type = var
+ THEN parameter (1, real type, var, next local adr (real type));
+ parameter (2, real type, const, step val.adr);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, real move);
+ step val.adr := local adr;
+ FI;
+ IF NOT (init val.no = local var result.no)
+ THEN parameter (1, real type, var, local var result.adr);
+ parameter (2, real type, const, init val.adr);
+ parameter (3, void type, const, nil adr);
+ apply (1, 2, real move)
+ FI .
+
+gen check of variable:
+ parameter (1, local var result.data, const, local var result.adr);
+ parameter (2, limit val.data, const, limit val.adr);
+ parameter (3, step val.data, const, step val.adr);
+ parameter (4, bool type, const, nil adr); apply (4, nop);
+(* In der nächsten Coder-Version ist eine PUSH-Angabe nop nicht nötig *)
+ apply (1, 3, "loopend");
+ apply (end loop, TRUE) .
+
+next var statement:
+(*NEXT [<var>][,<var>...] *)
+ next symbol;
+ generate loop end;
+ IF symb.type <> eos
+ THEN check next var result FI .
+
+check next var result:
+ IF symb.no = local var result.no
+ THEN next symbol;
+ IF symb.type = del AND symb.no = comma
+ THEN next for loop FI
+ ELSE basic error (86, NAME symb, local var result.name + " erwartet") FI .
+
+next for loop:
+ IF end symbol = next s
+ THEN symb := SYMBOL:("", -next s, eos, nil adr, void type)
+ ELSE basic error (1, symb.name, "") (* mo *)
+ FI.
+
+generate loop end:
+ parameter (1, local var result.data, var, local var result.adr);
+ parameter (2, step val.data, const, step val.adr);
+ parameter (3, void type, const, nil adr);
+ IF local var result.data = int type
+ THEN apply (1, 2, int incr)
+ ELSE apply (1, 2, real incr) FI;
+
+ apply (start loop);
+ define (end loop) .
+
+END PROC for statement;
+
+PROC if statement : (* Änd. 11.08.87, mo *)
+(* IF <expression> THEN <statement(s)>|<line number> *)
+(* [ELSE <statement(s)>|<line number>] *)
+(* IF <expression> GOTO <line number> *)
+(* [ELSE <statement(s)>|<line number>] *)
+ SYMBOL VAR local expr result;
+ next symbol;
+ get expr (local expr result, int type);
+ skip comma if there;
+ IF symb.type = res word AND (symb.no = then s OR symb.no = goto s)
+ THEN test expr result;
+ IF symb.no = goto s
+ THEN next symbol;
+ if goto statement
+ ELIF next symbol is stat no
+ THEN if goto statement
+ ELSE if then statement
+ FI
+ ELSE basic error (2, NAME symb, "THEN oder GOTO erwartet") FI .
+
+skip comma if there:
+ IF symb.no = comma AND symb.type = del
+ THEN next symbol
+ FI.
+
+test expr result:
+ parameter (1, int type, const, local expr result.adr);
+ parameter (2, bool type, var, nil adr); apply (2, nop);
+ apply (1, 1, test) .
+
+next symbol is stat no:
+ next symbol;
+ symb.type = const AND symb.data = int type.
+
+if goto statement:
+ SYMBOL VAR stat label;
+ get const (stat label, int type);
+ expect else if comma found;
+ IF symb.type = res word AND symb.no = else s
+ THEN apply (this label, FALSE);
+ treat else case
+ ELIF symb.type <> eos OR symb.no <> eol
+ THEN declare (else label);
+ apply (this label, FALSE);
+ apply (else label);
+ get basic line (else s);
+ IF symb.type = eos AND symb.no = -else s
+ THEN else statement
+ ELSE define (else label)
+ FI
+ ELSE apply (this label, FALSE)
+ FI.
+
+this label: label list [label pos (label no)] .
+label no: stat label.name ISUB 1 .
+
+expect else if comma found:
+ IF symb.type = del AND symb.no = comma
+ THEN next symbol;
+ IF symb.no <> else s OR symb.type <> res word
+ THEN basic error (2, NAME symb, "ELSE erwartet")
+ FI
+ FI.
+
+treat else case:
+ IF next symbol is stat no
+ THEN get const (stat label, int type);
+ apply (this label)
+ ELSE get basic line
+ FI.
+
+if then statement:
+ LABEL VAR fi label;
+ declare (else label);
+ apply (else label, TRUE);
+ get basic line (else s);
+
+ IF symb.type = eos AND symb.no = -else s
+ THEN declare (fi label);
+ apply (fi label);
+ else statement;
+ define (fi label)
+ ELSE define (else label) FI .
+
+
+else statement:
+ LABEL VAR else label;
+ define (else label);
+ treat else case.
+
+
+END PROC if statement;
+
+PROC on statement:
+(*2. ON <expression> GOSUB <list of line numbers> *)
+(*3. ON <expression> GOTO <list of line numbers> *)
+ LABEL VAR before case, after case, return case;
+ declare (before case);
+ declare (after case);
+ declare (return case);
+
+ next symbol;
+ IF symb.type = res word AND symb.no = error s
+ THEN basic error (100, symb.name, "")
+ FI;
+ get expr (expr result, int type);
+ IF on gosub statement
+ THEN gosub (before case);
+ apply (after case)
+ ELIF NOT on goto statement
+ THEN basic error (2, symb.name, "GOTO oder GOSUB erwartet") FI;
+
+ get case stat no;
+ define (before case);
+ gen case branches;
+ gen return case;
+ define (after case) .
+
+on gosub statement:
+ BOOL CONST gosub found := symb.type = res word AND symb.no = gosub s;
+ gosub found .
+
+on goto statement:
+ symb.type = res word AND symb.no = goto s.
+
+get case stat no:
+ TEXT VAR case stat no :: nil;
+ INT VAR case no :: 0;
+ next symbol;
+ REP get const (label, int type);
+ case no INCR 1;
+ case stat no CAT label.name;
+
+ IF symb.type = eos
+ THEN LEAVE get case stat no
+ ELSE skip (comma, del) FI
+ PER .
+
+gen case branches:
+ computedbranch (expr result.adr, case no + 1, otherwise lab); (* F6/rr *)
+ apply (otherwise lab);
+ FOR i FROM 1 UPTO case no
+ REP apply (label i) PER .
+
+gen return case:
+ IF gosub found
+ THEN define (return case);
+ goret
+ FI .
+
+otherwise lab:
+ IF gosub found
+ THEN return case
+ ELSE after case FI .
+
+label i:
+ label list [label pos (case stat no ISUB i)] .
+
+END PROC on statement;
+
+PROC print statement:
+(*PRINT [<list of expr results>] *)
+(*PRINT USING <string exp>;<list of expression> *)
+(*PRINT #<file number>,<list of expr results> *)
+(*PRINT #<file number>, USING <string exp>;<list of expression> *)
+ next symbol;
+ IF symb.type = del AND symb.no = numbersign
+ THEN print file statement
+ ELSE print display statement FI .
+
+print file statement:
+ basic error (100, symb.name, "") .
+
+print display statement:
+ get format string;
+ print list of expr results;
+ reset format string .
+
+get format string:
+ IF symb.type = res word AND symb.no = using s
+ THEN next symbol;
+ get expr (image, text type);
+ skip (semicolon, del);
+ parameter (1, text type, const, image.adr);
+ apply (1, 1, "using");
+ ELSE image := nilsymbol FI .
+
+reset format string:
+ IF image.type <> any
+ THEN apply (1, 0, "clearusing") FI .
+
+print list of expr results:
+ REP IF symb.type = res word AND symb.no = tab s
+ THEN get tabulation
+ ELIF symb.type = del AND symb.no = comma
+ THEN get next zone
+ ELIF symb.type = del AND symb.no = semicolon
+ THEN get next pos
+ ELIF symb.type = eos
+ THEN apply (1, 0, "nextline");
+ LEAVE print list of expr results
+ ELSE get print expr result FI;
+ PER .
+
+get tabulation:
+ next symbol;
+ skip (open bracket, del);
+ get expr (tab pos, int type);
+ skip (close bracket, del);
+ parameter (1, int type, const, tab pos.adr);
+ apply (1, 1, "tab") .
+
+get next zone:
+ next symbol;
+ IF image.type = any
+ THEN apply (1, 0, "nextzone") FI;
+ IF symb.type = eos
+ THEN LEAVE print list of expr results FI .
+
+get next pos:
+ next symbol;
+ IF symb.type = eos
+ THEN LEAVE print list of expr results FI .
+
+get print expr result:
+ get expr (expr result);
+ parameter (1, expr result.data, const, expr result.adr);
+ apply (1, 1, "basicout") .
+
+END PROC print statement;
+
+PROC while statement:
+(*WHILE <expression> *)
+ LABEL VAR while lab, wend lab;
+ SYMBOL VAR while expr result;
+ INT CONST while stat no := act stat no, (* F29/rr *)
+ while scan line no := scan line no;
+ TEXT CONST while symb name := symb.name;
+ next symbol;
+ declare (while lab);
+ declare (wend lab);
+
+ define (while lab);
+ get expr (while expr result, int type);
+ parameter (1, int type, const, while expr result.adr);
+ parameter (2, bool type, const, nil adr); apply (2, nop);
+ apply (1, 1, test);
+ apply (wend lab, TRUE); (* 'test' vergleicht mit 0 *)
+
+ get statement group (wend s);
+ IF symb.type = eos AND symb.no = -wend s
+ THEN wend statement
+ ELSE basic error ("Compiler", 29, while scan line no, while stat no, while symb name, "", TRUE) FI. (* F29/rr *)
+
+wend statement:
+(*WEND *)
+ apply (while lab);
+ define (wend lab);
+ next symbol .
+
+END PROC while statement;
+
+END PACKET basic compiler
+
diff --git a/basic/BASIC.Runtime b/basic/BASIC.Runtime
new file mode 100644
index 0000000..854002a
--- /dev/null
+++ b/basic/BASIC.Runtime
@@ -0,0 +1,1571 @@
+(***************************************************************************)
+(* *)
+(* Erste von drei Dateien des EUMEL-BASIC-Systems *)
+(* *)
+(* Autor: Heiko Indenbirken *)
+(* Überarbeitet von: Rudolf Ruland und Michael Overdick *)
+(* *)
+(* Stand: 27.10.1987 *)
+(* *)
+(***************************************************************************)
+
+PACKET basic std DEFINES EQU, UEQ, (* Autor: Heiko Indenbirken *)
+ LES, LEQ, (* Stand: 23.10.1987/rr/mo *)
+ GRE, GEQ,
+ EQV, IMP,
+ ^, swap,
+ val, asc, cdbl, chr,
+ cint, cvi, cvd, fre,
+ hex, inchars,
+ instr, ent, left,
+ mid, mki, mkd,
+ oct, right,
+ rnd, init rnd,
+ space, string,
+ l set, r set,
+ int not, real not,
+ /, DIV, real mod,
+ time, timer,
+ arctan, cos, sin, tan,
+ exp, ln, floor,
+ sqrt:
+
+
+INT CONST true := -1,
+ false := 0;
+
+LET real overflow = 6;
+
+
+(*BASIC-Integervergleiche *)
+INT OP EQU (INT CONST a, b):
+ IF a=b
+ THEN true
+ ELSE false FI
+END OP EQU;
+
+INT OP UEQ (INT CONST a, b):
+ IF a=b
+ THEN false
+ ELSE true FI
+END OP UEQ;
+
+INT OP LES (INT CONST a, b):
+ IF a<b
+ THEN true
+ ELSE false FI
+END OP LES;
+
+INT OP LEQ (INT CONST a, b):
+ IF a<=b
+ THEN true
+ ELSE false FI
+END OP LEQ;
+
+INT OP GRE (INT CONST a, b):
+ IF a>b
+ THEN true
+ ELSE false FI
+END OP GRE;
+
+INT OP GEQ (INT CONST a, b):
+ IF a>=b
+ THEN true
+ ELSE false FI
+END OP GEQ;
+
+(*BASIC-Realvergleiche *)
+INT OP EQU (REAL CONST a, b):
+ IF a=b
+ THEN true
+ ELSE false FI
+END OP EQU;
+
+INT OP UEQ (REAL CONST a, b):
+ IF a=b
+ THEN false
+ ELSE true FI
+END OP UEQ;
+
+INT OP LES (REAL CONST a, b):
+ IF a<b
+ THEN true
+ ELSE false FI
+END OP LES;
+
+INT OP LEQ (REAL CONST a, b):
+ IF a<=b
+ THEN true
+ ELSE false FI
+END OP LEQ;
+
+INT OP GRE (REAL CONST a, b):
+ IF a>b
+ THEN true
+ ELSE false FI
+END OP GRE;
+
+INT OP GEQ (REAL CONST a, b):
+ IF a>=b
+ THEN true
+ ELSE false FI
+END OP GEQ;
+
+(*BASIC-Tesxtvergleiche *)
+INT OP EQU (TEXT CONST a, b):
+ IF a=b
+ THEN true
+ ELSE false FI
+END OP EQU;
+
+INT OP UEQ (TEXT CONST a, b):
+ IF a=b
+ THEN false
+ ELSE true FI
+END OP UEQ;
+
+INT OP LES (TEXT CONST a, b):
+ IF a<b
+ THEN true
+ ELSE false FI
+END OP LES;
+
+INT OP LEQ (TEXT CONST a, b):
+ IF a<=b
+ THEN true
+ ELSE false FI
+END OP LEQ;
+
+INT OP GRE (TEXT CONST a, b):
+ IF a>b
+ THEN true
+ ELSE false FI
+END OP GRE;
+
+INT OP GEQ (TEXT CONST a, b):
+ IF a>=b
+ THEN true
+ ELSE false FI
+END OP GEQ;
+
+
+(*BASIC INTEGER / BOOL Operatoren *)
+REAL PROC real not (REAL CONST a): (* mo *)
+ real (int (a) XOR -1)
+END PROC real not;
+
+INT PROC int not (INT CONST a): (* mo *)
+ a XOR -1
+END PROC int not;
+
+INT OP EQV (INT CONST l, r):
+ int not (l XOR r)
+END OP EQV;
+
+INT OP IMP (INT CONST l, r):
+ (l EQV r) OR r
+END OP IMP;
+
+LET smallest significant = 5.0e-12;
+REAL OP ^ (REAL CONST x, y): (* F22/rr *)
+ IF x > 0.0
+ THEN x ** y
+ ELIF x = 0.0
+ THEN IF y > 0.0
+ THEN 0.0
+ ELIF y = 0.0
+ THEN 1.0
+ ELSE errorstop (real overflow, "");
+ max real
+ FI
+ ELSE REAL VAR floor y := floor (y + round value);
+ IF (abs (y - floor y) > smallest significant)
+ COR (floor y = 0.0 AND y <> 0.0)
+ THEN errorstop (1005, "bei " + text (x) +
+ " ^ " + text (y, 19) +
+ " : neg. Basis, gebr. Exponent");
+ 0.0
+ ELIF (floor y MOD 2.0) = 0.0
+ THEN (-x) ** floor y
+ ELSE - ( (-x) ** floor y )
+ FI
+ FI .
+
+ round value : IF y >= 0.0 THEN 0.5 ELSE -0.5 FI .
+
+END OP ^;
+
+REAL OP ^ (INT CONST x, y):
+ real (x) ** y
+END OP ^;
+
+REAL OP / (INT CONST l, r): (* mo *)
+ real (l) / real (r)
+END OP /;
+
+INT OP DIV (REAL CONST l, r): (* mo *)
+ cint (l) DIV cint (r)
+END OP DIV;
+
+REAL PROC real mod (REAL CONST l, r): (* mo *)
+ round (l, 0) MOD round (r, 0)
+END PROC real mod;
+
+(* Basic Arithmetik *)
+REAL VAR r swap;
+PROC swap (REAL VAR left, right):
+ r swap := left;
+ left := right;
+ right := r swap
+END PROC swap;
+
+INT VAR i swap;
+PROC swap (INT VAR left, right):
+ i swap := left;
+ left := right;
+ right := i swap
+END PROC swap;
+
+TEXT VAR t swap;
+PROC swap (TEXT VAR left, right):
+ t swap := left;
+ left := right;
+ right := t swap
+END PROC swap;
+
+(*Internkonvertierungen *)
+INT PROC cvi (TEXT CONST v):
+ v ISUB 1
+END PROC cvi;
+
+REAL PROC cvd (TEXT CONST v):
+ v RSUB 1
+END PROC cvd;
+
+TEXT VAR i text :: 2*""0"", r text :: 8*""0"";
+TEXT PROC mki (REAL CONST x):
+ mki (cint (x))
+END PROC mki;
+
+TEXT PROC mki (INT CONST i):
+ replace (i text, 1, i);
+ i text
+END PROC mki;
+
+TEXT PROC mkd (INT CONST i):
+ mkd (real (i))
+END PROC mkd;
+
+TEXT PROC mkd (REAL CONST r):
+ replace (r text, 1, r);
+ r text
+END PROC mkd;
+
+(*Textoperationen *)
+PROC l set (TEXT VAR left, TEXT CONST right):
+ replace (left, 1, right)
+END PROC l set;
+
+PROC r set (TEXT VAR left, TEXT CONST right):
+ replace (left, length (left)-length (right)+1, right)
+END PROC r set;
+
+TEXT PROC left (TEXT CONST string, REAL CONST no):
+ left (string, cint (no))
+END PROC left;
+
+TEXT PROC left (TEXT CONST string, INT CONST no):
+ subtext (string, 1, no)
+END PROC left;
+
+TEXT PROC right (TEXT CONST string, REAL CONST no):
+ right (string, cint (no))
+END PROC right;
+
+TEXT PROC right (TEXT CONST string, INT CONST no):
+ subtext (string, length (string)-no+1)
+END PROC right;
+
+TEXT PROC mid (TEXT CONST source, REAL CONST from):
+ mid (source, cint (from))
+END PROC mid;
+
+TEXT PROC mid (TEXT CONST source, INT CONST from):
+ subtext (source, from)
+END PROC mid;
+
+TEXT PROC mid (TEXT CONST source, REAL CONST from, length):
+ mid (source, cint (from), cint (length))
+END PROC mid;
+
+TEXT PROC mid (TEXT CONST source, INT CONST from, length):
+ subtext (source, from, from+length-1)
+END PROC mid;
+
+TEXT PROC string (REAL CONST x, y):
+ string (cint (x), cint (y))
+END PROC string;
+
+TEXT PROC string (INT CONST x, REAL CONST y):
+ string (x, cint (y))
+END PROC string;
+
+TEXT PROC string (REAL CONST x, INT CONST y):
+ string (cint (x), y)
+END PROC string;
+
+TEXT PROC string (INT CONST i, j):
+ i * code (j)
+END PROC string;
+
+TEXT PROC string (REAL CONST i, TEXT CONST x):
+ string (cint (i), x)
+END PROC string;
+
+TEXT PROC string (INT CONST i, TEXT CONST x):
+ i * (x SUB 1)
+END PROC string;
+
+(*Konvertierungen *)
+
+REAL PROC val (TEXT CONST text) : (* F18/rr *)
+
+ TEXT VAR buffer := text;
+ change (buffer, "d", "e");
+ change (buffer, "D", "e");
+ change (buffer, "E", "e");
+ real (buffer)
+
+END PROC val;
+
+REAL PROC asc (TEXT CONST text):
+ real (code (text SUB 1))
+END PROC asc;
+
+TEXT PROC chr (INT CONST n):
+ code (n)
+END PROC chr;
+
+TEXT PROC chr (REAL CONST n):
+ code (cint (n))
+END PROC chr;
+
+TEXT PROC hex (REAL CONST x):
+ hex (cint (x))
+END PROC hex;
+
+TEXT PROC hex (INT CONST x):
+ TEXT VAR value :: "12";
+ replace (value, 1, x);
+ high byte + low byte .
+
+low byte:
+ hexdigit (code (value SUB 1) DIV 16) + hexdigit (code (value SUB 1) MOD 16) .
+
+high byte:
+ IF (value SUB 2) = ""0""
+ THEN ""
+ ELSE hexdigit (code (value SUB 2) DIV 16) +
+ hexdigit (code (value SUB 2) MOD 16)
+ FI .
+
+END PROC hex;
+
+TEXT PROC oct (REAL CONST x):
+ oct (cint (x))
+END PROC oct;
+
+TEXT PROC oct (INT CONST x):
+ INT VAR number :: x AND maxint;
+ generate oct number;
+ IF x < 0
+ THEN "1" + oct number
+ ELSE subtext (oct number, pos (oct number, "1", "7", 1))
+ FI.
+
+generate oct number:
+ TEXT VAR oct number :: "";
+ INT VAR digit;
+ FOR digit FROM 1 UPTO 5 REP
+ oct number := hexdigit (number MOD 8) + oct number;
+ number := number DIV 8
+ PER.
+
+END PROC oct;
+
+TEXT PROC hexdigit (INT CONST digit):
+ IF 0 <= digit AND digit <= 9
+ THEN code (digit + 48)
+ ELIF 10 <= digit AND digit <= 15
+ THEN code (digit + 55)
+ ELSE errorstop (1051, "Hexziffer außerhalb des gültigen Bereichs"); "" FI
+END PROC hexdigit;
+
+TEXT PROC inchars (REAL CONST n):
+ inchars (cint (n))
+END PROC inchars;
+
+TEXT PROC inchars (INT CONST n):
+ TEXT VAR buffer :: "", char;
+ INT VAR i;
+ FOR i FROM 1 UPTO n
+ REP inchar (char);
+ buffer CAT char
+ PER;
+ buffer
+
+END PROC inchars;
+
+(*Mathematische Prozeduren *)
+REAL PROC ent (INT CONST r):
+ real (r)
+END PROC ent;
+
+REAL PROC ent (REAL CONST r):
+ IF r >= 0.0 OR frac (r) = 0.0
+ THEN floor (r)
+ ELSE floor (r-1.0) FI
+END PROC ent;
+
+REAL PROC cdbl (INT CONST r):
+ real (r)
+END PROC cdbl;
+
+REAL PROC cdbl (REAL CONST r):
+ r
+END PROC cdbl;
+
+INT PROC cint (INT CONST r):
+ r
+END PROC cint;
+
+INT PROC cint (REAL CONST r):
+ IF r >= 0.0
+ THEN int (r+0.5)
+ ELSE int (r-0.5) FI
+END PROC cint;
+
+REAL VAR last rnd :: rnd (1.0);
+REAL PROC rnd (INT CONST x):
+ rnd (real (x))
+END PROC rnd;
+
+REAL PROC rnd (REAL CONST x):
+ IF x > 0.0
+ THEN last rnd := random;
+ last rnd
+ ELIF x = 0.0
+ THEN last rnd
+ ELSE init rnd (x);
+ last rnd := random;
+ last rnd
+ FI
+
+END PROC rnd;
+
+REAL PROC rnd:
+ rnd (1.0)
+END PROC rnd;
+
+PROC init rnd (REAL CONST init value) :
+
+ REAL VAR init := init value;
+ IF init <= -1.0 OR 1.0 <= init
+ THEN set exp (- decimal exponent (init) - 1, init) FI;
+ initialize random (init)
+
+END PROC init rnd;
+
+
+REAL PROC fre (TEXT CONST dummy):
+ INT VAR f, u;
+ collect heap garbage;
+ storage (f, u);
+
+ real (f - u) * 1024.0
+END PROC fre;
+
+REAL PROC fre (REAL CONST dummy):
+ fre ("")
+END PROC fre;
+
+REAL PROC fre (INT CONST dummy):
+ fre ("")
+END PROC fre;
+
+(*Inputroutinenen *)
+INT PROC instr (TEXT CONST source, pattern):
+ pos (source, pattern)
+END PROC instr;
+
+INT PROC instr (REAL CONST from, TEXT CONST source, pattern):
+ instr (cint (from), source, pattern)
+END PROC instr;
+
+INT PROC instr (INT CONST from, TEXT CONST source, pattern):
+ pos (source, pattern, from)
+END PROC instr;
+
+TEXT PROC space (REAL CONST len):
+ space (cint (len))
+END PROC space;
+
+TEXT PROC space (INT CONST len):
+ len * " "
+END PROC space;
+
+TEXT PROC time: (* mo *)
+ subtext (time (clock (1) MOD day), 1, 8) (* hh:mm:ss *)
+END PROC time;
+
+REAL PROC timer:
+ clock (0)
+END PROC timer;
+
+REAL PROC arctan (INT CONST x):
+ arctan (real (x))
+END PROC arctan;
+
+REAL PROC cos (INT CONST x):
+ cos (real (x))
+END PROC cos;
+
+REAL PROC sin (INT CONST x):
+ sin (real (x))
+END PROC sin;
+
+REAL PROC tan (INT CONST x):
+ tan (real (x))
+END PROC tan;
+
+REAL PROC exp (INT CONST x):
+ exp (real (x))
+END PROC exp;
+
+REAL PROC ln (INT CONST x):
+ ln (real (x))
+END PROC ln;
+
+REAL PROC floor (INT CONST x):
+ real (x)
+END PROC floor;
+
+REAL PROC sqrt (INT CONST x):
+ sqrt (real (x))
+END PROC sqrt;
+
+END PACKET basic std;
+
+PACKET basic using DEFINES using, (* Autor: Heiko Indenbirken *)
+ clear using, (* Stand: 05.08.1987/rr/mo *)
+ basic text:
+
+
+LET exclamation point = "!",
+ backslash = "\",
+ comercial and = "&",
+ numbersign = "#",
+ plus = "+",
+ minus = "-",
+ asterisk dollar = "**$",
+ asterisk = "**",
+ dollarsign = "$$",
+ comma = ",",
+ point = ".",
+ caret = "^^^^",
+ underscore = "_",
+ blank = " ",
+ nil = "",
+
+ number format chars = "#+-*$.^",
+ format chars = "!\&#+-$*.";
+
+TEXT VAR result, using format :: "", pre format :: "";
+INT VAR using pos :: 0;
+BOOL VAR image used :: FALSE;
+
+PROC using (TEXT CONST format):
+ using format := format;
+ using pos := 0;
+ result := "";
+ image used := TRUE
+
+END PROC using;
+
+PROC clear using:
+ using format := "";
+ image used := FALSE
+END PROC clear using;
+
+TEXT PROC next format:
+ pre format := "";
+ IF using pos = 0
+ THEN ""
+ ELSE search rest of format FI .
+
+search rest of format:
+ WHILE using pos <= length (using format)
+ REP IF at underscore
+ THEN using pos INCR 1;
+ pre format CAT akt char
+ ELIF at format char
+ THEN LEAVE next format WITH pre format
+ ELSE pre format CAT akt char FI;
+ using pos INCR 1
+ PER;
+ using pos := 0;
+ pre format .
+
+at underscore:
+ akt char = underscore .
+
+at format char:
+ pos (format chars, akt char) > 0 CAND
+ evtl double asterisk CAND
+ evtl point with numbersign .
+
+evtl double asterisk:
+ akt char <> asterisk COR next char = asterisk .
+
+evtl point with numbersign:
+ akt char <> point COR next char = numbersign .
+
+akt char: using format SUB using pos .
+next char: using format SUB using pos+1 .
+END PROC next format;
+
+PROC init (TEXT VAR l result):
+ IF using pos = 0
+ THEN using pos := 1;
+ l result := next format;
+ IF using pos = 0
+ THEN errorstop (1005, "USING: kein Format gefunden") FI
+ ELSE l result := "" FI
+
+END PROC init;
+
+TEXT PROC basic text (TEXT CONST string):
+ IF image used
+ THEN using text
+ ELSE string FI .
+
+using text:
+ init (result);
+ result CAT format string;
+ using pos INCR 1;
+ result CAT next format;
+ result .
+
+format string:
+ IF akt char = exclamation point
+ THEN string SUB 1
+ ELIF akt char = backslash
+ THEN given length string
+ ELIF akt char = comercial and
+ THEN string
+ ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI .
+
+given length string:
+ INT VAR len :: 2;
+ FOR using pos FROM using pos+1 UPTO length (using format)
+ REP IF akt char = "\"
+ THEN LEAVE given length string WITH text (string, len) FI;
+ len INCR 1
+ UNTIL akt char <> " "PER;
+ errorstop (1005, "USING-Format fehlerhaft: " + using format);
+ "" .
+
+akt char: using format SUB using pos
+END PROC basic text;
+
+TEXT PROC basic text (INT CONST number):
+ IF image used
+ THEN basic text (real (number))
+ ELSE sign + text (number) FI .
+
+sign:
+ IF number >= 0
+ THEN " "
+ ELSE "" FI .
+
+END PROC basic text;
+
+TEXT PROC basic text (REAL CONST number):
+ IF image used
+ THEN using text
+ ELSE normal text FI .
+
+normal text:
+(* Bei Real Zahlen werden maximal 7 signifikante Stellen ausgegeben, *)
+(* führende und nachfolgende Nullen werden unterdrückt, *)
+(* der Dezimalpunkt wird im Normalformat unterdrückt *)
+ calculate sign;
+ REAL VAR mantissa := round (abs (number), 6-decimal exponent (number));
+ INT CONST exp :: decimal exponent (mantissa);
+
+ IF mantissa = 0.0
+ THEN result := " 0"
+ ELIF exp > 6 OR exp < -7 OR (exp < 0 AND more than 7 signifikant digits)
+ THEN scientific notation
+ ELIF exp < 0
+ THEN short negative notation
+ ELSE short positive notation FI;
+ result .
+
+more than 7 signifikant digits:
+ REAL VAR signifikant := mantissa;
+ set exp (7+exp, signifikant);
+ frac (signifikant) <> 0.0 .
+
+calculate sign:
+ IF number >= 0.0
+ THEN result := " "
+ ELSE result := "-" FI .
+
+scientific notation:
+ set exp (0, mantissa);
+ result CAT non zero (text (mantissa, 8, 6));
+
+ IF exp < 0
+ THEN result CAT "E-"
+ ELSE result CAT "E+" FI;
+
+ IF abs (exp) > 9
+ THEN result CAT text (abs (exp))
+ ELSE result CAT "0";
+ result CAT text (abs (exp))
+ FI .
+
+short positive notation:
+ result CAT non zero (text (mantissa, 8, 6-exp));
+ IF (result SUB LENGTH result) = "."
+ THEN delete char (result, LENGTH result) FI .
+
+short negative notation:
+ result CAT non zero (subtext (text (abs (mantissa), 9, 7), 2)).(* F13/rr *)
+
+using text:
+ init (result);
+ result CAT format number (subformat, number);
+ result CAT next format;
+ result .
+
+subformat:
+ INT VAR from :: using pos, to :: last format char;
+ subtext (using format, from, to) .
+
+last format char:
+ FOR using pos FROM using pos+1 UPTO length (using format)
+ REP IF non format char
+ THEN LEAVE last format char WITH using pos-1 FI
+ PER;
+ using pos := 0;
+ length (using format) .
+
+non format char:
+ IF (using format SUB using pos) = comma
+ THEN (using format SUB (using pos+1)) <> point
+ ELSE pos (numberformat chars, using format SUB using pos) = 0 FI .
+
+END PROC basic text;
+
+TEXT PROC non zero (TEXT CONST text):
+ INT VAR i;
+ FOR i FROM length (text) DOWNTO 2
+ REP UNTIL (text SUB i) <> "0" PER;
+ subtext (text, 1, i)
+END PROC non zero;
+
+TEXT PROC format number (TEXT CONST format, REAL CONST number):
+ IF no digit char
+ THEN errorstop (1005, "USING-Format fehlerhaft: " + using format); ""
+ ELIF exponent found
+ THEN exponent format
+ ELSE normal format FI .
+
+no digit char:
+ pos (format, numbersign) = 0 AND
+ pos (format, asterisk) = 0 AND
+ pos (format, dollarsign) = 0 .
+
+exponent found:
+ INT CONST exponent pos := pos (format, caret);
+ exponent pos > 0 .
+
+exponent format:
+ IF leading plus
+ THEN plus or minus + exponent field (subtext (format, 2), number, exponent pos-1)
+ ELIF trailing plus
+ THEN exponent field (format, number, exponent pos) + plus or minus
+ ELIF trailing minus
+ THEN exponent field (format, number, exponent pos) + nil or minus
+ ELSE blank or minus + exponent field (subtext (format, 2), number, exponent pos-1) FI .
+
+normal format:
+ IF leading numbersign
+ THEN number field (format, number, "", " ")
+ ELIF leading point
+ THEN number field (format, number, "", " ")
+ ELIF leading plus
+ THEN number field (format, abs (number), plus or minus, " ")
+ ELIF leading asterisk dollar
+ THEN number field (format, number, "$", "*")
+ ELIF leading asterisk
+ THEN number field (format, number, "", "*")
+ ELIF leading dollarsign
+ THEN number field (format, number, "$", " ")
+ ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI .
+
+leading numbersign: (format SUB 1) = numbersign .
+leading point: (format SUB 1) = point .
+leading plus: (format SUB 1) = plus .
+leading asterisk dollar: subtext (format, 1, 3) = asterisk dollar .
+leading asterisk: subtext (format, 1, 2) = asterisk .
+leading dollarsign: subtext (format, 1, 2) = dollarsign .
+
+trailing minus: (format SUB LENGTH format) = minus .
+trailing plus: (format SUB LENGTH format) = plus .
+
+plus or minus: IF number < 0.0 THEN minus ELSE plus FI .
+nil or minus: IF number < 0.0 THEN minus ELSE nil FI .
+blank or minus: IF number < 0.0 THEN minus ELSE blank FI .
+
+END PROC format number;
+
+TEXT PROC exponent field (TEXT CONST format, REAL CONST value, INT CONST exponent pos):
+ REAL VAR number := abs (value);
+ INT CONST point pos := pos (format, point);
+ calc leading and trailing;
+ INT CONST new exponent :: decimal exponent (value) - leading + 1;
+ IF abs (new exponent) >= 100
+ THEN "%" + mantissa + "E" + null text (new exponent, 4)
+ ELSE mantissa + exponent
+ FI.
+
+calc leading and trailing:
+ INT VAR leading, trailing;
+ IF point pos = 0
+ THEN leading := exponent pos-1;
+ trailing := 0
+ ELSE leading := point pos-1;
+ trailing := exponent pos-point pos-1
+ FI .
+
+mantissa:
+ set exp (leading - 1, number);
+ IF point pos = 0
+ THEN subtext (text (number, leading+1, 0), 1, leading)
+ ELSE subtext (text (number, leading+trailing+2, trailing), 2) FI .
+
+exponent:
+ "E" + null text (new exponent, 3) .
+
+END PROC exponent field;
+
+TEXT PROC number field (TEXT CONST format, REAL CONST value,
+ TEXT CONST pretext, lead char):
+ INT CONST point pos :: pos (format, point);
+ calc fraction;
+ calc digits;
+ calc commata if necessary;
+ fill with lead chars and sign .
+
+calc fraction:
+ INT VAR fraction :: 0, i;
+ FOR i FROM point pos+1 UPTO length (format)
+ WHILE (format SUB i) = numbersign
+ REP fraction INCR 1 PER .
+
+calc digits:
+ TEXT VAR valuetext;
+ IF point pos = 0
+ THEN valuetext := digits (abs (value), 0, TRUE);
+ delete char (valuetext, length (valuetext))
+ ELSE valuetext := digits (abs (value), fraction, point pos <> 1) FI .
+
+calc commata if necessary:
+ IF comma before point
+ THEN insert commata FI .
+
+comma before point:
+ point pos > 0 CAND (format SUB point pos-1) = comma .
+
+insert commata:
+ i := pos (valuetext, point)-3;
+ WHILE i > 1 CAND (valuetext SUB i) <> " "
+ REP insert char (valuetext, ",", i);
+ i DECR 3
+ PER .
+
+fill with lead chars and sign:
+ IF trailing minus
+ THEN fillby (pretext + valuetext, length (format)-1, lead char) + nil or minus
+ ELIF trailing plus
+ THEN fillby (pretext + valuetext, length (format)-1, lead char) + plus or minus
+ ELIF value < 0.0
+ THEN fillby (pretext + minus + valuetext, length (format), lead char)
+ ELSE fillby (pretext + valuetext, length (format), lead char) FI .
+
+
+plus or minus: IF value < 0.0 THEN minus ELSE plus FI .
+nil or minus: IF value < 0.0 THEN minus ELSE nil FI .
+trailing minus: (format SUB LENGTH format) = minus .
+trailing plus: (format SUB LENGTH format) = plus .
+END PROC numberfield;
+
+TEXT PROC null text (INT CONST n, digits):
+ TEXT VAR l result := text (abs (n), digits);
+ IF n < 0
+ THEN replace (l result, 1, "-")
+ ELSE replace (l result, 1, "+") FI;
+ change all (l result, " ", "0");
+ l result .
+END PROC null text;
+
+TEXT PROC fillby (TEXT CONST source, INT CONST format, TEXT CONST with):
+ IF differenz >= 0
+ THEN differenz * with + source
+ ELSE "%" + source FI .
+
+differenz: format - length (source) .
+END PROC fillby;
+
+TEXT PROC digits (REAL CONST value, INT CONST frac, BOOL CONST null):
+ IF decimal exponent (value) < 0
+ THEN TEXT VAR l result := text (value, frac+2, frac);
+
+ IF null AND first char <> "0"
+ THEN replace (l result, 1, "0");
+ l result
+ ELIF (NOT null AND first char = "0") OR first char = " "
+ THEN subtext (l result, 2)
+ ELSE l result FI
+ ELSE text (value, decimal exponent (value)+frac+2, frac) FI .
+
+first char:
+ (l result SUB 1) .
+
+END PROC digits;
+
+TEXT PROC right (TEXT CONST msg, INT CONST len):
+ IF length (msg) >= len
+ THEN subtext (msg, 1, len)
+ ELSE (len - length (msg)) * " " + msg FI
+
+END PROC right;
+
+END PACKET basic using;
+
+PACKET basic output (* Autor: R. Ruland *)
+ (* Stand: 28.08.1987/rr/mo *)
+ DEFINES basic page,
+ width,
+ init output,
+ basic out,
+ basic write,
+ tab,
+ next zone,
+ next line,
+ next page,
+ cursor x pos,
+ pos,
+ csrlin,
+ l pos,
+ switch to printout file,
+ switch back to old sysout state:
+
+LET zone width = 16; (* sd.ddddddEsdddb (s = sign, d = digit, b = blank) *)
+LET printfile name = "BASIC LPRINT OUTPUT";
+
+INT VAR screen width, x cursor, y cursor, line no;
+BOOL VAR paging := FALSE, first time,
+ in lprint; (* mo *)
+TEXT VAR buffer, output line, last sysout file, old sysout, char;
+
+PROC basic page (BOOL CONST status):
+
+ paging := status
+
+END PROC basic page;
+
+BOOL PROC basic page: paging END PROC basic page;
+
+
+PROC width (INT CONST max):
+
+ IF max < 0
+ THEN errorstop (1005, "WIDTH: negatives Angabe: " + text (max))
+ ELIF max = 0
+ THEN screen width := 1
+ ELSE screen width := max
+ FI;
+ last sysout file := "";
+
+END PROC width;
+
+INT PROC width : screen width END PROC width;
+
+
+PROC init output:
+
+ clear using;
+ width (max (1, x size));
+ line no := 1;
+ output line := "";
+ first time := TRUE;
+ in lprint := FALSE
+
+END PROC init output;
+
+
+PROC basic out (INT CONST i): bas out (basic text (i) + " ") END PROC basic out;
+
+PROC basic out (REAL CONST r): bas out (basic text (r) + " ") END PROC basic out;
+
+PROC basic out (TEXT CONST t): bas out (basic text (t)) END PROC basic out;
+
+PROC basic write (INT CONST i): bas out (basic text (i)) END PROC basic write;
+
+PROC basic write (REAL CONST r): bas out (basic text (r)) END PROC basic write;
+
+PROC basic write (TEXT CONST t): bas out (basic text ("""" + t + """")) END PROC basic write;
+
+
+PROC bas out (TEXT CONST msg):
+
+ get cursor;
+ IF length (msg) > free
+ THEN IF first time
+ THEN first time := FALSE;
+ next line;
+ bas out (msg);
+ ELSE buffer := subtext (msg, 1, free);
+ IF sysout = ""
+ THEN out (buffer)
+ ELSE sysout write (buffer)
+ FI;
+ next line;
+ buffer := subtext (msg, free + 1);
+ bas out (buffer);
+ FI;
+ ELSE first time := TRUE;
+ IF sysout = ""
+ THEN out (msg)
+ ELSE sysout write (msg)
+ FI;
+ FI;
+
+ . free : screen width - x cursor + 1
+
+END PROC bas out;
+
+
+PROC tab (INT CONST n):
+
+ get cursor;
+ IF n <= 0
+ THEN tab position out of range
+ ELIF n > screen width
+ THEN tab (n MOD screen width);
+ ELIF x cursor > n
+ THEN next line;
+ tab (n);
+ ELIF sysout = ""
+ THEN cursor (n, y cursor);
+ ELSE buffer := (n - x cursor) * " ";
+ sysout write (buffer)
+ FI;
+
+ . tab position out of range :
+ IF x cursor <> 1 THEN next line FI;
+ write ("WARNUNG : TAB-Position <= 0");
+ next line;
+
+END PROC tab;
+
+
+PROC next zone:
+
+ get cursor;
+ IF x cursor > screen width - zone width
+ THEN next line;
+ ELIF sysout = ""
+ THEN free TIMESOUT " ";
+ ELSE buffer := free * " ";
+ sysout write (buffer)
+ FI;
+
+ . free : ((x cursor - 1) DIV zone width + 1) * zone width - x cursor + 1
+
+END PROC next zone;
+
+
+PROC next line :
+
+ IF sysout = ""
+ THEN next line on screen
+ ELSE line;
+ write (""); (* generates new record *)
+ output line := "";
+ FI;
+
+ . next line on screen:
+ line no INCR 1;
+ IF paging CAND line no > y size
+ THEN IF in last line
+ THEN warte;
+ ELSE out (""13""10"");
+ line no := y cursor + 1;
+ FI;
+ ELIF NOT paging
+ THEN char := incharety;
+ IF char <> ""
+ THEN IF char = "+"
+ THEN paging := TRUE
+ ELSE type (char)
+ FI
+ FI;
+ out (""13""10"")
+ ELSE out (""13""10"")
+ FI
+
+ . in last line :
+ get cursor;
+ y cursor = y size
+
+ . warte :
+ cursor (x size - 2, y size);
+ out (">>");
+ inchar (char);
+ IF char = ""13""
+ THEN next page
+ ELIF char = ""10""
+ THEN out (""8""8" "13""10"")
+ ELIF char = ""27""
+ THEN clear editor buffer;
+ errorstop (1, "")
+ ELIF char = "-"
+ THEN out (""8""8" "13""10"");
+ line no := 1;
+ paging := FALSE;
+ ELSE out (""8""8" "13""10"");
+ line no := 1;
+ FI;
+
+ . clear editor buffer:
+ REP UNTIL get charety = "" PER;
+
+END PROC next line;
+
+
+PROC next page:
+
+ IF sysout = ""
+ THEN out (""1""4"")
+ ELSE line
+ FI;
+ clear using;
+ line no := 1;
+ output line := "";
+
+END PROC next page;
+
+
+INT PROC pos (REAL CONST dummy): (* mo *)
+
+ cursor x pos
+
+END PROC pos;
+
+
+INT PROC pos (INT CONST dummy): (* mo *)
+
+ cursor x pos
+
+END PROC pos;
+
+
+INT PROC cursor x pos :
+
+ get cursor;
+ x cursor
+
+END PROC cursor x pos;
+
+
+INT PROC csrlin: (* mo *)
+
+ get cursor;
+ y cursor
+
+END PROC csrlin;
+
+
+PROC get cursor :
+
+ IF sysout = ""
+ THEN get cursor (x cursor, y cursor);
+ ELSE x cursor := LENGTH output line + 1;
+ FI;
+
+END PROC get cursor;
+
+
+INT PROC l pos (REAL CONST dummy): (* mo *)
+
+ l pos (0)
+
+END PROC l pos;
+
+
+INT PROC l pos (INT CONST dummy): (* mo *)
+
+ INT VAR lprint position :: 1;
+ IF exists (printfile name)
+ THEN disable stop;
+ FILE VAR printfile :: sequential file (modify, printfile name);
+ IF lines (printfile) > 0
+ THEN to line (printfile, lines (printfile));
+ lprint position := len (printfile) + 1
+ FI;
+ output (printfile)
+ FI;
+ lprint position
+
+END PROC l pos;
+
+
+PROC switch to printout file: (* mo *)
+
+ in lprint := TRUE;
+ old sysout := sysout;
+ careful sysout (printfile name);
+
+END PROC switch to printout file;
+
+
+PROC switch back to old sysout state: (* mo *)
+
+ IF in lprint
+ THEN careful sysout (old sysout);
+ in lprint := FALSE
+ FI
+
+END PROC switch back to old sysout state;
+
+
+PROC sysout write (TEXT CONST string):
+ check sysout;
+ write (string);
+ output line CAT string.
+
+check sysout:
+ IF sysout <> last sysout file
+ THEN careful sysout (sysout)
+ FI.
+
+END PROC sysout write;
+
+
+PROC careful sysout (TEXT CONST new sysout): (* mo *)
+
+IF new sysout <> ""
+ THEN disable stop;
+ FILE VAR outfile :: sequential file (modify, new sysout);
+ max line length (outfile, screen width);
+ last sysout file := sysout;
+ IF lines (outfile) > 0
+ THEN to line (outfile, lines (outfile));
+ read record (outfile, output line);
+ delete record (outfile)
+ ELSE output line := ""
+ FI;
+ sysout (new sysout);
+ write (output line);
+ ELSE sysout ("")
+FI
+
+END PROC careful sysout;
+
+END PACKET basic output;
+
+
+PACKET basic input (* Autor: R. Ruland *)
+ (* Stand: 27.10.1987/rr/mo *)
+
+ DEFINES init input,
+ read input,
+ check input,
+ assign input,
+ assign input line,
+ input ok,
+ input eof:
+
+
+LET comma = ",",
+ quote = """",
+
+ wrong type = 1,
+ insufficient data = 2,
+ too much data = 3,
+ overflow = 4,
+
+ int overflow = 4,
+ real overflow = 6;
+
+INT VAR input line pos, input error no;
+BOOL VAR on terminal;
+TEXT VAR input line :: "", previous input line := "", input value;
+
+. first quote found : (input value SUB 1) = quote
+.;
+
+PROC init input :
+
+ input error no := 0;
+ input line pos := 0;
+ input line := "";
+ previous input line := "";
+
+END PROC init input;
+
+
+PROC read input (BOOL CONST cr lf, TEXT CONST msg, BOOL CONST question mark):
+
+ on terminal := sysout <> "" AND sysin = "";
+ check input error;
+ out string (msg);
+ IF question mark THEN out string ("? ") FI;
+ IF sysin <> ""
+ THEN getline (input line);
+ ELSE editget input line;
+ FI;
+ out string (input line);
+ IF crlf THEN out line FI;
+ input line pos := 0;
+ input error no := 0;
+
+ . check input error :
+ IF input error no = 0
+ THEN input line := "";
+ ELSE IF sysin = ""
+ THEN BOOL CONST old basic page := basic page;
+ basic page (FALSE);
+ IF cursor x pos <> 1 THEN next line FI;
+ basic out ("?Eingabe wiederholen ! (" + error text + ")");
+ next line;
+ basic page (old basic page);
+ ELSE errorstop (1080,"INPUT-Fehler (" + error text +
+ ") : >" + input line + "<");
+ FI;
+ FI;
+
+ . error text :
+ SELECT input error no OF
+ CASE wrong type : "falscher Typ"
+ CASE insufficient data : "zu wenig Daten"
+ CASE too much data : "zu viele Daten"
+ CASE overflow : "Überlauf"
+ OTHERWISE : ""
+ END SELECT
+
+ . editget input line :
+ TEXT VAR exit char;
+ INT VAR x, y;
+ get cursor (x, y);
+ REP IF width - x < 1
+ THEN out (""13""10"");
+ get cursor (x, y)
+ FI;
+ editget (input line, max text length, width - x, "", "k", exit char);
+ cursor (x, y);
+ IF exit char = ""27"k"
+ THEN input line := previous input line;
+ ELSE previous input line := input line;
+ LEAVE editget input line;
+ FI;
+ PER;
+
+END PROC read input;
+
+
+PROC out string (TEXT CONST string) :
+
+ basic out (string);
+ IF on terminal THEN out (string) FI;
+
+END PROC out string;
+
+
+PROC out line :
+
+ next line;
+ IF on terminal THEN out (""13""10"") FI;
+
+END PROC out line;
+
+
+BOOL PROC check input (INT CONST type) :
+
+ get next input value;
+ input value := compress (input value);
+ set conversion (TRUE);
+ SELECT type OF
+ CASE 1 : check int input
+ CASE 2 : check real input
+ CASE 3 : check text input
+ END SELECT;
+ IF NOT last conversion ok THEN input error no := wrong type FI;
+ input error no = 0
+
+ . check int input :
+ IF input value <> ""
+ THEN disable stop;
+ INT VAR help int value;
+ help int value := int (input value);
+ IF is error CAND error code = int overflow
+ THEN clear error;
+ input error no := overflow;
+ FI;
+ enable stop;
+ FI;
+
+ . check real input :
+ IF input value <> ""
+ THEN disable stop;
+ REAL VAR help real value;
+ help real value := val (input value);
+ IF is error CAND (error code = real overflow
+ OR error code = int overflow) (* <-- Aufgrund eines Fehlers in 'real' *)
+ THEN clear error;
+ input error no := overflow;
+ FI;
+ enable stop;
+ FI;
+
+ . check text input :
+ (* IF input value = "" THEN input error no := wrong type FI; *)
+ IF NOT is quoted string CAND quote found
+ THEN input error no := wrong type
+ FI;
+
+ . is quoted string :
+ first quote found CAND last quote found
+
+ . last quote found :
+ (input value SUB LENGTH input value) = quote
+
+ . quote found :
+ pos (input value, quote) > 0
+
+END PROC check input;
+
+
+PROC assign input (INT VAR int value) :
+
+ get next input value;
+ int value := int (input value);
+
+END PROC assign input;
+
+PROC assign input (REAL VAR real value) :
+
+ get next input value;
+ real value := val (input value);
+
+END PROC assign input;
+
+PROC assign input (TEXT VAR string value) :
+
+ get next input value;
+ input value := compress (input value);
+ IF first quote found
+ THEN string value := subtext (input value, 2, LENGTH input value -1)
+ ELSE string value := input value
+ FI;
+
+END PROC assign input;
+
+PROC assign input line (TEXT VAR string line) :
+
+ string line := input line;
+
+END PROC assign input line;
+
+
+PROC get next input value : (* F27/rr *)
+
+ IF input line pos > LENGTH input line
+ THEN input value := "";
+ input error no := insufficient data;
+ ELSE IF next non blank char = quote
+ THEN get quoted string
+ ELSE get unquoted string
+ FI;
+ FI;
+
+ . next non blank char :
+ INT CONST next non blank char pos := pos (input line, ""33"", ""255"", input line pos + 1);
+ input line SUB next non blank char pos
+
+ . get quoted string :
+ INT CONST quote pos := pos (input line, quote, next non blank char pos + 1);
+ IF quote pos = 0
+ THEN input value := subtext (input line, next non blank char pos);
+ input line pos := LENGTH input line + 1;
+ input error no := wrong type;
+ ELSE input value := subtext (input line, next non blank char pos, quote pos);
+ input line pos := pos (input line, ""33"", ""255"", quote pos + 1);
+ IF input line pos = 0
+ THEN input line pos := LENGTH input line + 1;
+ ELIF (input line SUB input line pos) <> comma
+ THEN input error no := wrong type;
+ input line pos DECR 1;
+ FI;
+ FI;
+
+ . get unquoted string :
+ INT VAR comma pos := pos (input line, comma, input line pos + 1);
+ IF comma pos = 0
+ THEN input value := subtext (input line, input line pos + 1);
+ input line pos := LENGTH input line + 1;
+ ELSE input value := subtext (input line, input line pos + 1, comma pos - 1);
+ input line pos := comma pos;
+ FI;
+
+END PROC get next input value;
+
+
+BOOL PROC input ok:
+
+ IF input line pos <= LENGTH input line
+ THEN input error no := too much data FI;
+ input line pos := 0;
+ input error no = 0
+
+END PROC input ok;
+
+BOOL PROC input eof: input line = "" END PROC input eof;
+
+
+END PACKET basic input;
+
+PACKET basic std using io (* Autor: R. Ruland *)
+ (* Stand: 26.10.87/rr/mo *)
+
+ DEFINES init rnd:
+
+
+PROC init rnd:
+
+ REAL VAR init;
+ REP read input (TRUE, "Startwert des Zufallszahlengenerators ? ", FALSE);
+ UNTIL check input (2) CAND input ok PER; (* F24/rr *)
+ assign input (init);
+ init rnd (init);
+
+END PROC init rnd;
+
+
+END PACKET basic std using io;
+
diff --git a/basic/eumel coder 1.8.1 b/basic/eumel coder 1.8.1
new file mode 100644
index 0000000..0047067
--- /dev/null
+++ b/basic/eumel coder 1.8.1
@@ -0,0 +1,3086 @@
+PACKET eumel coder (* Autor: U. Bartling *)
+ DEFINES coder on, coder off,
+ declare, define, apply, identify,
+ :=, =,
+ dump,
+
+ LIB,
+
+ LABEL,
+ gosub, goret,
+ computed branch,
+ complement condition code,
+
+ ADDRESS ,
+ GLOB, LOC, REF, DEREF,
+ ref length,
+ +,
+ adjust,
+ get base,
+ is global, is local, is ref,
+
+ DTYPE,
+ type class, type name,
+ void type, int type, real type, text type, bool type,
+ bool result type, dataspace type, undefined type,
+ row type, struct type, proc type, end type,
+
+ OPN,
+ set length of local storage,
+ begin module, end module,
+ is proc, is eumel 0 instruction,
+ address, operation,
+ nop,
+ mnemonic,
+
+ parameter,
+ next param,
+ NEXTPARAM,
+ access ,
+ dtype ,
+ param address,
+ same type ,
+
+ reserve storage,
+ allocate denoter ,
+ allocate variable,
+ data allocation by coder ,
+ data allocation by user,
+
+ run, run again,
+ insert,
+ prot, prot off,
+ check, check on, check off,
+
+ help, bulletin, packets,
+
+(**************************************************************************)
+(* *)
+(* E U M E L - C O D E R *)
+(* *)
+(* *)
+(* Zur Beschreibung des Coders siehe *)
+(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
+(* *)
+(* Stand der Dokumentation : 29.10.1986 *)
+(* Stand der Implementation : 03.09.1986 *)
+(* *)
+(* *)
+(**************************************************************************)
+
+#page#
+(**************************************************************************)
+(* *)
+(* 0. Datentyp DINT 03.09.1987 *)
+(* *)
+(* Definition des Datentyps *)
+(* arithmetischer Operationen *)
+(* und Konvertierungsprozeduren *)
+(* *)
+(**************************************************************************)
+
+
+ DINT,
+ -, *, DIV, MOD, <, <=,
+ AND, OR, XOR,
+ dput, dget, dmov,
+ ddec1, dinc1, dinc, ddec,
+ dadd, dsub,
+ dequ, dlseq,
+ INCR, DECR,
+ put, get, cout,
+ text, real, int, dint,
+ replace, DSUB :
+
+
+TYPE DINT = STRUCT (INT low, high) ;
+
+
+REAL VAR real value ; (* auch fuer Ausrichtung ! *)
+TEXT VAR convertion buffer ;
+
+DINT CONST dint0 :: dint(0) ;
+DINT VAR result :: dint 0 ;
+
+
+DINT PROC dint (INT CONST number) :
+ EXTERNAL 144
+ENDPROC dint ;
+
+INT PROC int (DINT CONST i) :
+ EXTERNAL 143
+ENDPROC int;
+
+REAL PROC real (DINT CONST number) :
+ real value := 65536.0 * real (number.high) ;
+
+ IF number.low >= 0
+ THEN real value INCR real (number.low)
+ ELSE real value INCR (real (number.low AND maxint) + 32768.0)
+ FI ;
+ real value
+ENDPROC real ;
+
+DINT PROC dint (REAL CONST number) :
+ real value := abs (number) ;
+ REAL CONST low := real value MOD 65536.0 ;
+
+ result.high := int(real value / 65536.0) ;
+ IF low < 32768.0
+ THEN result.low := int (low)
+ ELSE result.low := int (low-32768.0) OR minint
+ FI ;
+ IF number < 0.0 THEN dsub (dint0, result, result) FI ;
+ result
+ENDPROC dint ;
+
+TEXT PROC text (DINT CONST number) :
+ IF number.high = 0 THEN convert low part only
+ ELSE convert number
+ FI ;
+ convertion buffer .
+
+convert low part only :
+ IF number.low >= 0 THEN convertion buffer := text (number.low)
+ ELSE convertion buffer := text (real of low) ;
+ erase decimal point
+ FI .
+
+real of low :
+ real (number.low AND maxint) + 32768.0 .
+
+convert number :
+ convertion buffer := text (real(number)) ;
+ erase decimal point .
+
+erase decimal point :
+ convertion buffer := subtext (convertion buffer, 1, LENGTH convertion buffer-2)
+ENDPROC text;
+
+DINT PROC dint (TEXT CONST dint txt) :
+ convertion buffer := dint txt ;
+ INT CONST dot pos :: pos (convertion buffer, ".") ;
+ IF dot pos = 0 THEN convertion buffer CAT ".0" FI ;
+ dint (real(convertion buffer))
+ENDPROC dint ;
+
+PROC get (DINT VAR dest) :
+ REAL VAR number ;
+ get (number) ;
+ dest := dint (number)
+ENDPROC get ;
+
+PROC put (DINT CONST number) :
+ put (text (number));
+ENDPROC put ;
+
+PROC cout (DINT CONST number) :
+ EXTERNAL 61
+ENDPROC cout;
+
+OP := (DINT VAR a, DINT CONST b) :
+# INLINE ; #
+ dmov (b, a);
+ENDOP :=;
+
+OP INCR (DINT VAR a, DINT CONST b) :
+# INLINE ; #
+ dinc (b, a);
+ENDOP INCR;
+
+OP DECR (DINT VAR a, DINT CONST b) :
+# INLINE ; #
+ ddec (b, a);
+ENDOP DECR;
+
+BOOL OP = (DINT CONST a, b) :
+ EXTERNAL 137
+ENDOP =;
+
+BOOL OP <= (DINT CONST a, b) :
+ EXTERNAL 138
+ENDOP <=;
+
+BOOL OP < (DINT CONST a, b) :
+# INLINE ; #
+ NOT (b <= a)
+ENDOP <;
+
+BOOL PROC dequ (DINT CONST a, b) :
+ EXTERNAL 137
+ENDPROC dequ ;
+
+BOOL PROC dlseq (DINT CONST a, b) :
+ EXTERNAL 138
+ENDPROC dlseq ;
+
+PROC replace (TEXT VAR text, INT CONST index of dint, DINT CONST value) :
+ INT VAR subscript := index of dint * 2 ;
+ replace (text, subscript - 1,value.low);
+ replace (text, subscript, value.high);
+ENDPROC replace;
+
+DINT OP DSUB (TEXT CONST text, INT CONST index of dint) :
+ INT VAR subscript := index of dint * 2 ;
+ result.low := text ISUB subscript - 1;
+ result.high := text ISUB subscript;
+ result
+ENDOP DSUB;
+
+DINT OP + (DINT CONST a, b) :
+ EXTERNAL 135
+ENDOP + ;
+
+DINT OP - (DINT CONST a, b) :
+ EXTERNAL 136
+ENDOP - ;
+
+PROC dadd (DINT CONST a, b, DINT VAR res) :
+ EXTERNAL 135
+ENDPROC dadd ;
+
+PROC dsub (DINT CONST a, b, DINT VAR res) :
+ EXTERNAL 136
+ENDPROC dsub ;
+
+PROC dinc (DINT CONST source, DINT VAR dest) :
+ EXTERNAL 133
+ENDPROC dinc ;
+
+PROC ddec (DINT CONST source, DINT VAR dest) :
+ EXTERNAL 134
+ENDPROC ddec ;
+
+PROC dmov (DINT CONST source, DINT VAR dest) :
+ EXTERNAL 130
+ENDPROC dmov;
+
+DINT OP DIV (DINT CONST a,b) :
+ EXTERNAL 152
+ENDOP DIV ;
+
+DINT OP MOD (DINT CONST a,b) :
+ EXTERNAL 153
+ENDOP MOD ;
+
+DINT OP AND (DINT CONST a,b) :
+ result.low := a.low AND b.low ;
+ result.high := a.high AND b.high ;
+ result
+ENDOP AND ;
+
+DINT OP OR (DINT CONST a,b) :
+ result.low := a.low OR b.low ;
+ result.high := a.high OR b.high ;
+ result
+ENDOP OR ;
+
+DINT OP XOR (DINT CONST a,b) :
+ result.low := a.low XOR b.low ;
+ result.high := a.high XOR b.high ;
+ result
+ENDOP XOR ;
+
+PROC dput (ROW 32000 DINT VAR array, DINT CONST index, value) :
+ EXTERNAL 139
+ENDPROC dput ;
+
+PROC dget (ROW 32000 DINT VAR array, DINT CONST index, DINT VAR dest) :
+ EXTERNAL 140
+ENDPROC dget ;
+
+PROC dinc1 (DINT VAR dest) :
+ EXTERNAL 131
+ENDPROC dinc1 ;
+
+PROC ddec1 (DINT VAR dest) :
+ EXTERNAL 132
+ENDPROC ddec1 ;
+
+DINT OP * (DINT CONST a,b) :
+ EXTERNAL 151
+ENDOP * ;
+
+#page#
+ (***** Globale Variable *****)
+
+TEXT VAR object name;
+
+FILE VAR bulletin file;
+
+INT VAR memory management mode, global address offset, packet base,
+ hash table pointer, nt link, permanent pointer, param link,
+ packet link, index, mode, field pointer, word,
+ number of errors := 0 ;
+
+BOOL VAR found, end of params;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 1. Interface zum ELAN-Compiler 13.11.1986 *)
+(* 1.8.1 *)
+(* *)
+(* Beschreibung der Tabellen (-groessen), *)
+(* internen Vercodung von Typen *)
+(* und Kennungen . *)
+(* Initialisieren und Beenden des Compilers, *)
+(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+TYPE LIB = STRUCT (TEXT name, INT nt link, pt link, ADDRESS base) ;
+
+LET begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of permanent table = 22784 ,
+ before first pt entry = 22784 ,
+ first permanent entry = 22785 ,
+ end of permanent table = 32767 ,
+
+ wordlength = 1 , (* compile u n d run time *)
+ two word length = 2 ,
+ three word length = 3 ,
+ four word length = 4 ,
+
+ permanent param const = 10000 ,
+ permanent param var = 20000 ,
+ permanent proc op = 30000 ,
+ permanent type = 30000 ,
+ permanent row = 10 ,
+ permanent struct = 11 ,
+ permanent param proc = 12 ,
+ permanent param proc end marker = 0 ,
+ permanent type field = 0 ,
+
+ ptt limit = 10000 ,
+ begin of pt minus ptt limit = 12784 ,
+ begin of pt minus ptt limit 1 = 12785 , (* plus wordlength *)
+
+ void id = 0 ,
+ int id = 1 ,
+ real id = 2 ,
+ string id = 3 ,
+ bool id = 5 ,
+ bool result id = 6 ,
+ dataspace id = 7 ,
+ undefined id = 9 ,
+ row id = 10 ,
+ struct id = 11 ,
+ end id = 0 ,
+
+ const = 1 ,
+ var = 2 ,
+ proc id = 3 ,
+(* denoter = 5 , *)
+ bold = 2 ,
+
+ ins = TRUE ,
+ no ins = FALSE ,
+ no lst = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+ prep coder mode = 5 ,
+
+ warning message = 2 ,
+ error message = 4 ,
+
+ point line = "..............." ;
+
+INT CONST permanent packet := -2 ,
+ permanent end := -3 ;
+
+BOOL VAR coder active := FALSE ;
+
+INT VAR run again mod nr := 0 ;
+
+
+ (***** Start/Ende *****)
+
+LET coder not active = "CODER not active" ,
+ illegal define packet = "illegal define packet" ;
+
+PROC coder on (INT CONST data allocation mode) :
+ mark coder on ;
+ init opn section ;
+ init compiler ;
+ init memory management .
+
+mark coder on :
+ coder active := TRUE .
+
+init memory management :
+ memory management mode := data allocation mode .
+
+init compiler :
+ no do again ;
+ elan (prep coder mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+
+ENDPROC coder on;
+
+PROC coder off (BOOL CONST insert, sermon, OPN CONST start proc) :
+ IF coder active
+ THEN mark coder off ;
+ end coder (insert, sermon, start mod nr if no insert)
+ ELSE errorstop (coder not active)
+ FI .
+
+start mod nr if no insert :
+ IF insert THEN run again mod nr := 0
+ ELSE run again mod nr := start proc.mod nr
+ FI ;
+ run again mod nr .
+
+mark coder off :
+ reset memory management mode ;
+ init opn section ;
+ coder active := FALSE
+ENDPROC coder off ;
+
+PROC end coder (BOOL CONST insert wanted, sermon wanted, INT CONST mod) :
+ EXTERNAL 10021
+ENDPROC end coder ;
+
+PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
+ INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+PROC unsigned arithmetic :
+ EXTERNAL 92
+ENDPROC unsigned arithmetic ;
+
+
+ (***** Paket-Rahmen *****)
+
+PROC declare (TEXT CONST name, LIB VAR packet) :
+ packet.name := name
+ENDPROC declare ;
+
+PROC define (LIB VAR packet) :
+ check if definition possible ;
+ declare object (packet.name, packet.nt link, packet.pt link) ;
+ open packet (packet.nt link, global address offset, packet base) ;
+ set to actual base (packet) .
+
+check if definition possible :
+ IF NOT coder active THEN errorstop (coder not active) FI ;
+ IF module open THEN errorstop (illegal define packet) FI
+ENDPROC define ;
+
+PROC open packet (INT CONST nt link of packet name, INT VAR offset, base) :
+ EXTERNAL 10032
+ENDPROC open packet ;
+
+PROC identify (TEXT CONST name, LIB VAR packet, BOOL VAR packet exists) :
+ to packet (name) ;
+ packet exists := found ;
+ IF found THEN packet.name := name ;
+ packet.nt link := nt link ;
+ packet.pt link := packet link ;
+ get pbas (packet.base)
+ FI
+ENDPROC identify ;
+
+
+ (***** Hash/Namenstabelle *****)
+.
+next hash entry :
+ hash table pointer INCR wordlength .
+
+end of hash table reached :
+ hash table pointer > end of hash table .
+
+yet another nt entry :
+ nt link := cdb int (nt link) ;
+ nt link <> 0 . ;
+
+PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
+ EXTERNAL 10031
+ENDPROC declare object ;
+
+PROC to object (TEXT CONST searched object) :
+ hash ;
+ search nt entry .
+
+hash :
+ hash code := 0 ;
+ FOR index FROM 1 UPTO LENGTH searched object REP
+ addmult cyclic
+ ENDREP .
+
+addmult cyclic :
+ hash code INCR hash code ;
+ IF hash code > end of hash table THEN wrap around FI ;
+ hash code := (hash code + code (searched object SUB index)) MOD 1024 .
+
+wrap around :
+ hash code DECR end of hash table .
+
+hash code : nt link .
+
+search nt entry :
+ found := FALSE ;
+ WHILE yet another nt entry REP
+ read current entry ;
+ IF object name = searched object
+ THEN found := TRUE ;
+ LEAVE to object
+ FI
+ PER .
+
+read current entry :
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length)
+ENDPROC to object ;
+
+
+ (***** Permanent Tabelle *****)
+.
+next procedure :
+ permanent pointer := cdb int (permanent pointer) . ;
+
+PROC next pt param :
+ mode := cdb int (param link) MOD ptt limit ;
+ param link INCR wordlength ;
+ IF mode = permanent row THEN skip over permanent row
+ ELIF mode = permanent struct THEN skip over permanent struct
+ FI ;
+ set end marker if end of list .
+
+skip over permanent row :
+ param link INCR wordlength ;
+ next pt param .
+
+skip over permanent struct :
+ REP
+ mode := cdb int (param link) ;
+ IF mode = permanent type field
+ THEN param link INCR wordlength ;
+ LEAVE skip over permanent struct
+ FI ;
+ next pt param
+ PER
+ENDPROC next pt param ;
+
+PROC set end marker if end of list :
+ mode := cdb int (param link) ;
+ end of params := mode >= permanent proc op OR mode <= 0
+ENDPROC set end marker if end of list ;
+
+PROC get type and mode (INT VAR type) :
+ mode := cdb int (param link) ;
+ IF mode < 0 THEN type := 2769 + (32767 + mode) ;
+ mode := 0
+ ELIF mode = permanent param proc THEN translate type
+ ELSE type := mode MOD ptt limit ;
+ mode DECR type ;
+ translate type if necessary ;
+ translate mode if necessary
+ FI .
+
+translate type if necessary :
+ IF permanent row or struct THEN translate type FI .
+
+translate type :
+ type := param link - begin of pt minus ptt limit .
+
+translate mode if necessary :
+ IF mode = permanent param const THEN mode := const
+ ELIF mode = permanent param var THEN mode := var
+ FI .
+
+permanent row or struct :
+ type = permanent row OR type = permanent struct
+ENDPROC get type and mode ;
+
+PROC put next permanent (INT CONST permanent value) :
+ EXTERNAL 10020
+ENDPROC put next permanent ;
+
+
+ (***** Allgemeine Zugriffsprozeduren *****)
+
+INT PROC cdb int (INT CONST index) :
+ EXTERNAL 116
+ENDPROC cdb int ;
+
+TEXT PROC cdb text (INT CONST index) :
+ EXTERNAL 117
+ENDPROC cdb text ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 2. Spruenge und Marken 07.10.1986 *)
+(* *)
+(* Definition des Datentyps LABEL *)
+(* *)
+(* Deklaration, Definition und Applikation von Marken *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE LABEL = INT ;
+
+BOOL VAR invers :: FALSE ;
+
+PROC declare (LABEL VAR label) :
+ CONCR (label) := 0
+ENDPROC declare ;
+
+PROC define (LABEL VAR label) :
+ EXTERNAL 10085
+ENDPROC define ;
+
+PROC complement condition code :
+ invers := NOT invers
+ENDPROC complement condition code ;
+
+PROC apply (LABEL VAR label) :
+ EXTERNAL 10151
+ENDPROC apply ;
+
+PROC apply (LABEL VAR label, BOOL CONST condition) :
+ IF condition xor invers THEN branch true (label)
+ ELSE branch false (label)
+ FI ;
+ invers := FALSE .
+
+condition xor invers :
+ IF condition THEN NOT invers
+ ELSE invers
+ FI
+ENDPROC apply ;
+
+OP := (LABEL VAR global label, local label) : (* EQUATE ! *)
+ EXTERNAL 10014
+ENDOP := ;
+
+TEXT PROC dump (LABEL CONST label) :
+ "LAB " + text (CONCR (label))
+ENDPROC dump ;
+
+PROC gosub (LABEL VAR label) :
+ EXTERNAL 10015
+ENDPROC gosub ;
+
+PROC goret :
+ s0 (q goret code)
+ENDPROC goret ;
+
+PROC branch true (LABEL VAR label) :
+ EXTERNAL 10028
+ENDPROC branch true ;
+
+PROC branch false (LABEL VAR label) :
+ EXTERNAL 10029
+ENDPROC branch false ;
+
+PROC computed branch (ADDRESS CONST switch, INT CONST limit, LABEL VAR out) :
+ s1 (q esc case, REPR switch) ;
+ s0 (limit) ;
+ branch false (out)
+ENDPROC computed branch ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 3. Datenaddressen 13.11.1986 *)
+(* *)
+(* Definition des Datentyps ADDRESS *)
+(* *)
+(* Aufbau von Datenaddressen (Vercodung) *)
+(* Fortschalten und Ausrichten von Adressen *)
+(* Behandlung von Paketbasis-Adressen *)
+(* Bereitstellen der Fehlermeldung "address overflow" (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE ADDRESS = STRUCT (INT kind, value) ;
+
+LET global = 0 ,
+ local = 1 ,
+ ref mask = 2 ,
+ global ref = 2 ,
+ local ref = 3 ,
+ module nr = 4 ,
+ immediate value = 5 ,
+ p base = 6 ,
+
+ eumel0 stack offset = 4 ,
+ local address limit = 16 384 ,
+ global address zero = 0 ,
+
+ illegal ref operation = "REF not allowed" ,
+ deref on non ref = "DEREF on non-ref address" ,
+ global ref not allowed = "GLOBAL REF not allowed" ,
+ unknown kind = "Unknown address kind" ,
+ address overflow = "Address Overflow" ,
+ illegal plus operation = "+ not allowed" ;
+
+ADDRESS VAR result addr;
+
+INT CONST ref length :: 2 ;
+
+OP := (ADDRESS VAR l, ADDRESS CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+ADDRESS OP GLOB (INT CONST address level) :
+ result addr.kind := global ;
+ result addr.value := address level ;
+ IF memory management mode = data allocation by user
+ THEN result addr.value INCR global address offset
+ FI ;
+ result addr
+ENDOP GLOB ;
+
+ADDRESS OP LOC (INT CONST address level) :
+ result addr.kind := local ;
+ result addr.value := address level + eumel0 stack offset ;
+ result addr
+ENDOP LOC ;
+
+ADDRESS OP REF (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ IF result addr.kind = local THEN result addr.kind INCR ref mask
+ ELIF result addr.kind = global THEN errorstop (global ref not allowed)
+ ELSE errorstop (illegal ref operation)
+ FI ;
+ result addr
+ENDOP REF ;
+
+ADDRESS OP DEREF (ADDRESS CONST ref address) :
+ CONCR (result addr) := CONCR (ref address) ;
+ IF is not local ref THEN errorstop (deref on non ref) FI ;
+ result addr.kind DECR ref mask ;
+ result addr .
+
+is not local ref :
+ result addr.kind <> local ref
+ENDOP DEREF ;
+
+INT OP REPR (ADDRESS CONST addr) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global :
+ CASE local : set bit (result addr.value, 15)
+ CASE global ref : errorstop (global ref not allowed)
+ CASE local ref : prep local ref
+ OTHERWISE errorstop (unknown kind)
+ ENDSELECT ;
+ result addr.value .
+
+prep local ref :
+ IF address limit exceeded THEN errorstop (address overflow) FI ;
+ set bit (result addr.value, 14) ;
+ set bit (result addr.value, 15) .
+
+address limit exceeded :
+ result addr.value < eumel0 stack offset OR
+ result addr.value > local address limit
+ENDOP REPR ;
+
+PROC get base (LIB CONST packet, ADDRESS VAR base) :
+ CONCR (base) := CONCR (packet.base)
+ENDPROC get base ;
+
+PROC set to actual base (LIB VAR packet) :
+ packet.base.kind := p base ;
+ packet.base.value := packet base
+ENDPROC set to actual base ;
+
+PROC get pbas (ADDRESS VAR base) :
+ base.kind := p base ;
+ base.value := cdbint (packet link + 2)
+ENDPROC get pbas ;
+
+BOOL OP = (ADDRESS CONST l,r) :
+ l.kind = r.kind AND l.value = r.value
+ENDOP = ;
+
+BOOL PROC is ref (ADDRESS CONST addr) :
+ addr.kind = local ref
+ENDPROC is ref ;
+
+BOOL PROC is global (ADDRESS CONST addr) :
+ addr.kind = global
+ENDPROC is global ;
+
+BOOL PROC is local (ADDRESS CONST addr) :
+ addr.kind = local
+ENDPROC is local ;
+
+ADDRESS OP + (ADDRESS CONST addr, INT CONST offset) :
+ CONCR (result addr) := CONCR (addr) ;
+ SELECT result addr.kind OF
+ CASE global : inc global
+ CASE local : inc local
+ OTHERWISE errorstop (illegal plus operation)
+ ENDSELECT ;
+ result addr .
+
+inc global :
+ result addr.value INCR offset ;
+ IF result addr.value < 0 THEN errorstop (address overflow) FI .
+
+inc local :
+ result addr.value INCR offset ;
+ IF result addr.value < eumel 0 stack offset OR
+ result addr.value > local address limit
+ THEN errorstop (address overflow)
+ FI
+ENDOP + ;
+
+PROC adjust (ADDRESS VAR addr, INT CONST adjust length) :
+ IF is local or global THEN adjust to length FI .
+
+is local or global :
+ addr.kind <= local .
+
+adjust to length :
+ mode := addr.value MOD adjust length ;
+ IF mode <> 0 THEN addr.value INCR (adjust length-mode) FI
+ENDPROC adjust ;
+
+TEXT PROC dump (ADDRESS CONST addr) :
+ kind + text (addr.value) .
+
+kind :
+ SELECT addr.kind OF
+ CASE global : "GLOBAL "
+ CASE local : "LOCAL "
+ CASE immediate value : "IMMEDIATE "
+ CASE module nr : "PARAM PROC "
+ CASE global ref : "GLOBAL REF "
+ CASE local ref : "LOCAL REF "
+ CASE p base : "PBAS "
+ OTHERWISE "undef. Addr: "
+ ENDSELECT
+ENDPROC dump;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 4. Datentypen Teil I 08.09.1986 *)
+(* *)
+(* Definition des Datentyps DTYPE *)
+(* *)
+(* Interne Repraesentation der primitiven Datentypen *)
+(* Identifikation von DTYPEs *)
+(* *)
+(**************************************************************************)
+
+
+
+TYPE DTYPE = INT ;
+
+OP := (DTYPE VAR l, DTYPE CONST r) :
+ CONCR (l) := CONCR (r)
+ENDOP := ;
+
+BOOL OP = (DTYPE CONST l, r) :
+ CONCR (l) = CONCR (r)
+ENDOP = ;
+
+DTYPE PROC void type : DTYPE :(void id) ENDPROC void type ;
+
+DTYPE PROC int type : DTYPE :(int id) ENDPROC int type ;
+
+DTYPE PROC real type : DTYPE :(real id) ENDPROC real type ;
+
+DTYPE PROC text type : DTYPE :(string id) ENDPROC text type ;
+
+DTYPE PROC bool type : DTYPE :(bool id) ENDPROC bool type ;
+
+DTYPE PROC bool result type : DTYPE :(bool result id) ENDPROC bool result type;
+
+DTYPE PROC dataspace type : DTYPE :(dataspace id) ENDPROC dataspace type ;
+
+DTYPE PROC undefined type : DTYPE :(undefined id) ENDPROC undefined type ;
+
+DTYPE PROC row type : DTYPE :(row id) ENDPROC row type ;
+
+DTYPE PROC struct type : DTYPE :(struct id) ENDPROC struct type ;
+
+DTYPE PROC proc type : DTYPE :(permanent param proc) ENDPROC proc type ;
+
+DTYPE PROC end type : DTYPE :(end id) ENDPROC end type ;
+
+INT PROC type class (DTYPE CONST type) :
+ SELECT type id OF
+ CASE int id, real id, bool id, bool result id, string id,
+ dataspace id, undefined id : 1
+ CASE void id : 0
+ CASE row id : 3
+ CASE struct id : 4
+ CASE permanent param proc : 5
+ OTHERWISE pt type
+ ENDSELECT .
+
+pt type :
+ IF type id > ptt limit THEN permanent row or struct
+ ELSE abstract type
+ FI .
+
+abstract type : 2 .
+
+permanent row or struct :
+ unsigned arithmetic ;
+ mode := cdbint (type link into pt) MOD ptt limit ;
+ IF mode = struct id THEN 4
+ ELIF mode = row id THEN 3
+ ELIF mode = permanent param proc THEN 5
+ ELSE 2
+ FI .
+
+type link into pt :
+ type id + begin of pt minus ptt limit .
+
+type id : CONCR (type)
+ENDPROC type class ;
+
+PROC identify (TEXT CONST name,INT VAR size, align, DTYPE VAR type) :
+ SELECT type pos OF
+ CASE 1 : size := 0; align := 0; type id := void id
+ CASE 6 : size := 1; align := 1; type id := int id
+ CASE 10 : size := 4; align := 4; type id := real id
+ CASE 15 : size := 8; align := 4; type id := string id
+ CASE 20 : size := 1; align := 1; type id := bool id
+ CASE 25 : size := 1; align := 1; type id := dataspace id
+ OTHERWISE search for type in permanent table
+ ENDSELECT .
+
+type pos :
+ enclose in delimiters ;
+ pos (".VOID.INT.REAL.TEXT.BOOL.DATASPACE.", object name) .
+
+enclose in delimiters :
+ object name := "." ;
+ object name CAT name ;
+ object name CAT "." .
+
+search for type in permanent table :
+ to object (name) ;
+ IF not found THEN size := 0; align := 0; type id := undefined id
+ ELSE size := cdbint (permanent pointer + two wordlength) ;
+ type id := permanent pointer - begin of permanent table ;
+ IF size < two wordlength THEN align := 1
+ ELIF size < four wordlength THEN align := 2
+ ELSE align := 4
+ FI
+ FI .
+
+not found :
+ NOT found OR invalid entry .
+
+invalid entry :
+ permanent pointer = 0 OR
+ cdb int (permanent pointer + wordlength) <> permanent type .
+
+type id : CONCR (type)
+ENDPROC identify ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 5. Operationen Teil I 30.09.1986 *)
+(* *)
+(* Definition des Datentyps OPN *)
+(* Primitive Operationen (:= etc.) *)
+(* Initialisieren mit den externen Namen der EUMEL-0-Codes *)
+(* Bereitstellen dee Fehlermeldung 'proc op expected' (coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+TYPE OPN = STRUCT (INT kind, mod nr, top of stack) ;
+
+LET proc op = 0 ,
+ param proc = 1 ,
+ eumel 0 = 2 ,
+ nil = 3 ,
+
+ param proc at non ref = "PARAM PROC at non-ref address" ,
+ proc op expected = "PROC expected" ;
+
+OPN VAR eumel0 opn;
+eumel0 opn.kind := eumel0 ;
+eumel0 opn.top of stack := 0 ;
+
+eumel0 opn.mod nr := q pp ;
+OPN CONST pp :: eumel0 opn ,
+ nop code :: OPN :(nil, 0, 0) ;
+
+IF NOT exists ("eumel0 codes")
+ THEN IF yes ("Archive 'eumel coder' eingelegt")
+ THEN archive ("eumel coder") ;
+ fetch ("eumel0 codes", archive) ;
+ release (archive)
+ ELSE errorstop ("""eumel0 codes"" gibt es nicht")
+ FI
+FI ;
+BOUND THESAURUS VAR initial opcodes :: old ("eumel0 codes") ;
+THESAURUS VAR eumel 0 opcodes :: initial opcodes ;
+forget ("eumel0 codes") ;
+
+ADDRESS PROC address (OPN CONST opn) :
+ IF opn.kind <> proc op THEN errorstop (proc op expected) FI ;
+ result addr.kind := module nr ;
+ result addr.value := opn.mod nr ;
+ result addr
+ENDPROC address ;
+
+OPN PROC operation (ADDRESS CONST addr) :
+ IF addr.kind <> local ref THEN errorstop (param proc at non ref) FI ;
+ OPN VAR opn ;
+ opn.kind := param proc ;
+ opn.mod nr :=addr.value ;
+ opn.top of stack := 0 ;
+ opn
+ENDPROC operation ;
+
+TEXT PROC mnemonic (OPN CONST op code) :
+ name (eumel 0 opcodes, op code.mod nr)
+ENDPROC mnemonic ;
+
+OPN PROC nop :
+ nop code
+ENDPROC nop ;
+
+OP := (OPN VAR r, OPN CONST l) :
+ CONCR (r) := CONCR (l)
+ENDOP := ;
+
+BOOL PROC is proc (OPN CONST operation) :
+ operation.kind = proc op
+ENDPROC is proc ;
+
+BOOL PROC is eumel 0 instruction (TEXT CONST op code name) :
+ link (eumel 0 opcodes, op code name) <> 0
+ENDPROC is eumel 0 instruction ;
+
+BOOL PROC is eumel 0 instruction (OPN CONST operation) :
+ operation.kind = eumel0
+ENDPROC is eumel 0 instruction ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 6. Parameterfeld 10.04.1986 *)
+(* *)
+(* Bereitstellen des Parameterfeldes *)
+(* Schreiben und Lesen von Eintraegen im Parameterfeld *)
+(* Fortschalten von Zeigern in das Parameterfeld *)
+(* Bereitstellen der Konstanten 'size of param field' (Coder-intern) *)
+(* *)
+(**************************************************************************)
+
+
+
+LET PARAMDESCRIPTOR = STRUCT (DTYPE type, INT access,
+ ADDRESS addr, OPN push opn) ,
+
+ size of param field = 100 ,
+ param field exceeded = "Param Field Overflow",
+ param nr out of range = "Illegal Param Number" ;
+
+ROW size of param field PARAMDESCRIPTOR VAR param field ;
+
+
+ (***** Schreiben *****)
+
+PROC test param pos (INT CONST param nr) :
+ IF param nr < 1 OR param nr > size of param field
+ THEN errorstop (param nr out of range)
+ FI
+ENDPROC test param pos ;
+
+PROC declare (INT CONST param nr, DTYPE CONST type) :
+ test param pos (param nr) ;
+ enter type .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type)
+ENDPROC declare ;
+
+PROC declare (INT CONST param nr, access) :
+ test param pos (param nr) ;
+ enter access .
+
+enter access :
+ param field [param nr].access := access
+ENDPROC declare ;
+
+PROC define (INT CONST param nr, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter address .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr)
+ENDPROC define ;
+
+PROC define (INT CONST param nr, value) :
+ result addr.kind := immediate value ;
+ result addr.value := value ;
+ define (param nr, result addr)
+ENDPROC define ;
+
+PROC apply (INT CONST param nr, OPN CONST opn) :
+ test param pos (param nr) ;
+ enter push opn .
+
+enter push opn :
+ CONCR (param field [param nr].push opn) := CONCR (opn)
+ENDPROC apply ;
+
+PROC parameter (INT CONST param nr, DTYPE CONST type,
+ INT CONST access, ADDRESS CONST addr) :
+ test param pos (param nr) ;
+ enter type ;
+ enter access ;
+ enter address ;
+ enter pp as default .
+
+enter type :
+ CONCR (param field [param nr].type) := CONCR (type) .
+
+enter access :
+ param field [param nr].access := access .
+
+enter address :
+ CONCR (param field [param nr].addr) := CONCR (addr) .
+
+enter pp as default :
+ CONCR (param field [param nr].push opn) := CONCR (pp)
+ENDPROC parameter ;
+
+
+ (***** Lesen *****)
+
+ADDRESS PROC param address (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].addr
+ENDPROC param address ;
+
+DTYPE PROC dtype (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].type
+ENDPROC dtype ;
+
+INT PROC access (INT CONST param nr) :
+ test param pos (param nr) ;
+ param field [param nr].access
+ENDPROC access ;
+
+
+ (***** Fortschalten *****)
+
+OP NEXTPARAM (INT VAR param nr) :
+ test param pos (param nr) ;
+ INT CONST class :: type class (param field [param nr].type) ;
+ param nr INCR 1 ;
+ SELECT class OF
+ CASE 3 : NEXTPARAM param nr
+ CASE 4,5 : read until end
+ ENDSELECT .
+
+read until end :
+ WHILE NOT end marker read or end of field REP
+ NEXTPARAM param nr
+ PER ;
+ param nr INCR 1 .
+
+end marker read or end of field :
+ param nr > size of param field OR
+ CONCR (param field [param nr].type) = end id
+ENDOP NEXTPARAM ;
+
+INT PROC next param (INT CONST p) :
+ INT VAR index := p ;
+ NEXTPARAM index ;
+ index
+ENDPROC next param ;
+
+TEXT PROC dump (INT CONST p) :
+ IF p > 0 AND p <= 100 THEN dump entry (param field (p))
+ ELSE param nr out of range
+ FI
+ENDPROC dump ;
+
+TEXT PROC dump entry (PARAMDESCRIPTOR CONST id) :
+(* object name := dump (id.type) ; *)
+ object name := "TYPE " ; (* siehe *)
+ object name CAT dump (id.type) ; (* TEXT PROC dump (DTYPE d) *)
+ object name CAT text (id.access) ;
+ object name CAT dump (id.addr) ;
+ object name CAT dump (id.push opn) ;
+ object name
+ENDPROC dump entry ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 7. Datentypen Teil II 08.09.1986 *)
+(* *)
+(* Deklaration neuer Datentypen *)
+(* Vergleich von DTYPEs im Parameterfeld und in der Permanent-Tabelle *)
+(* *)
+(**************************************************************************)
+
+
+
+DTYPE VAR pt type ;
+
+PROC declare (TEXT CONST name, INT CONST size, align, DTYPE VAR type) :
+ entry into name table ;
+ put next permanent (permanent type) ;
+ put next permanent (size) ;
+ put next permanent (nt link) ;
+ mark no offsets of text elements .
+
+entry into name table :
+ declare object (name, nt link, CONCR (type)) ;
+ CONCR (type) DECR begin of permanent table .
+
+mark no offsets of text elements :
+ put next permanent (0)
+ENDPROC declare ;
+
+BOOL PROC same type (INT CONST param 1, param 2) :
+ INT CONST left type :: CONCR (param field [param 1].type) ;
+ IF left type = right type
+ THEN same fine structure if there is one
+ ELSE left type = undefined id OR right type = undefined id
+ FI .
+
+right type : CONCR (param field [param 2].type) .
+
+same fine structure if there is one :
+ IF left type = row id THEN compare row
+ ELIF left is struct or proc THEN compare struct
+ ELSE TRUE
+ FI .
+
+left is struct or proc :
+ left type = struct id OR left type = proc id .
+
+compare row :
+ equal sizes AND same type (param1 + 1, param2 + 1) .
+
+equal sizes :
+ param field [param1+1].access = param field [param2+1].access .
+
+compare struct :
+ INT VAR p1 :: param1+1, p2 :: param2+1 ;
+ WHILE same type (p1, p2) AND NOT end type found REP
+ NEXTPARAM p1 ;
+ NEXTPARAM p2
+ UNTIL end of field PER ;
+ FALSE .
+
+end type found :
+ CONCR (param field [p1].type) = end id .
+
+end of field :
+ p1 > size of param field OR p2 > size of param field
+ENDPROC same type ;
+
+BOOL PROC same type (INT CONST param nr, DTYPE CONST type) :
+ field pointer := param nr ;
+ CONCR (pt type) := CONCR (type) ;
+ equal types
+ENDPROC same type ;
+
+BOOL PROC equal types :
+ identical types OR one type is undefined .
+
+one type is undefined :
+ type of actual field = undefined id OR CONCR(pt type) = undefined id .
+
+identical types :
+ SELECT type class (pt type) OF
+ CASE 0, 1, 2 : type of actual field = CONCR (pt type)
+ CASE 3 : perhaps equal rows
+ CASE 4 : perhaps equal structs
+ CASE 5 : perhaps equal param procs
+ OTHERWISE FALSE
+ ENDSELECT .
+
+perhaps equal rows :
+ param link := CONCR (pt type) + begin of pt minus ptt limit ;
+ is row AND equal row sizes AND equal row types .
+
+is row :
+ type of actual field = row id .
+
+perhaps equal structs :
+ param link := CONCR (pt type) + begin of pt minus ptt limit ;
+ is struct AND same type fields .
+
+is struct :
+ type of actual field = struct id .
+
+equal row sizes :
+ pt row size = row size within param field .
+
+equal row types :
+ field pointer INCR 1 ;
+ param link INCR 2 ;
+ get type and mode (CONCR(pt type)) ;
+ equal types .
+
+pt row size :
+ cdb int (param link + 1) .
+
+row size within param field :
+ param field [field pointer + 1].access .
+
+same type fields :
+ REP
+ field pointer INCR 1 ;
+ param link INCR 1 ;
+ IF type of actual field = end id
+ THEN LEAVE same type fields WITH pt struct end reached
+ FI ;
+ get type and mode (CONCR(pt type)) ;
+ IF NOT equal types THEN LEAVE same type fields WITH FALSE FI
+ UNTIL end of field PER ;
+ FALSE .
+
+pt struct end reached :
+ cdbint (param link) = permanent type field .
+
+end of field :
+ field pointer > size of param field .
+
+type of actual field :
+ CONCR (param field [field pointer].type) .
+
+perhaps equal param procs :
+ param link := CONCR (pt type) + begin of pt minus ptt limit ;
+ is proc AND same param list .
+
+is proc : cdbint (param link) = permanent param proc .
+
+same param list :
+ param link INCR wordlength ;
+ DTYPE VAR proc result type ;
+ get type and mode (CONCR (proc result type)) ;
+ compare param list ;
+ check results .
+
+compare param list :
+ INT VAR last param := field pointer + 1 ;
+ REP
+ field pointer INCR 1 ;
+ param link INCR wordlength ;
+ IF pt param list exhausted THEN LEAVE compare param list FI ;
+ IF type of actual field = end id
+ THEN LEAVE equal types WITH FALSE
+ FI ;
+ get type and mode (CONCR(pt type)) ;
+ last param := field pointer ;
+ UNTIL NOT equal types OR end of field PER .
+
+check results :
+ pt param list exhausted AND equal result types .
+
+equal result types :
+ save param link ;
+ IF same type (last param, proc result type)
+ THEN restore ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+pt param list exhausted :
+ cdbint (param link) = permanent param proc end marker .
+
+save param link :
+ INT CONST p :: param link .
+
+restore :
+ field pointer INCR 1 ;
+ param link := p
+
+ENDPROC equal types ;
+
+BOOL PROC is not void bool or undefined (DTYPE CONST dtype) :
+ type <> void id AND type <> bool result id AND type <> undefined id .
+
+type : CONCR (dtype)
+ENDPROC is not void bool or undefined ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 8. Operationen Teil II 08.09.1986 *)
+(* *)
+(* Definition der Opcodes *)
+(* Deklaration, Definition, Identifikation und Applikation *)
+(* Eroeffnen und Schliessen eines Moduls *)
+(* *)
+(**************************************************************************)
+
+
+
+LET module not opened = "Module not opened" ,
+ define missing = "DEFINE missing" ,
+ wrong nr of params = "Wrong Nr. of Params:" ,
+ illegal kind = "Opcode expected" ,
+ nested module = "Nested Modules" ,
+ no mod nr = "Param Proc expected" ,
+ no immediate value = "Value expected" ,
+ type error = "Type Error" ,
+
+ q ln = 1 ,
+ q move = 2 , q move code = 2 048 ,
+ q inc1 = 3 , q inc1 code = 3 072 ,
+ q dec1 = 4 , q dec1 code = 4 096 ,
+ q inc = 5 , q inc code = 5 120 ,
+ q dec = 6 , q dec code = 6 144 ,
+ q add = 7 , q add code = 7 168 ,
+ q sub = 8 , q sub code = 8 192 ,
+ q clear = 9 , q clear code = 9 216 ,
+ q test = 10 ,
+ q equ = 11 , q equ code = 11 264 ,
+ q lsequ = 12 , q lsequ code = 12 288 ,
+ q fmove = 13 , q fmove code = 13 312 ,
+ q fadd = 14 , q fadd code = 14 336 ,
+ q fsub = 15 , q fsub code = 15 360 ,
+ q fmult = 16 , q fmult code = 16 384 ,
+ q fdiv = 17 , q fdiv code = 17 408 ,
+ q flsequ = 18 , q flsequ code = 18 432 ,
+ q tmove = 19 , q tmove code = 19 456 ,
+ q tequ = 20 , q tequ code = 20 480 ,
+ q accds = 21 , q access ds code = 22 528 ,
+ q ref = 22 , q ref code = 23 552 ,
+ q subscript = 23 , q subscript code = 24 576 ,
+ q select = 24 , q select code = 25 600 ,
+ q ppv = 25 , q ppv code = 26 624 ,
+ q pp = 26 ,
+ q make false = 27 , (* q make false code = 65 513 *)
+ q movex = 28 ,
+(* q longa subs q longa subs code = 65 376 *)
+ q return = 29 , q return code = 32 512 ,
+ q true return = 30 , q true return code = 32 513 ,
+ q false return = 31 , q false return code = 32 514 ,
+ q goret code = 32 519 ,
+ q esc mult = 32 , q esc mult code = 32 553 ,
+ q esc div = 33 , q esc div code = 32 554 ,
+ q esc mod = 34 , q esc mod code = 32 555 ,
+ q pproc = 35 ,
+ q compl int = 36 , q compl int code = 32 551 ,
+ q compl real = 37 , q compl real code = 32 550 ,
+ q alias ds = 38 , q alias ds code = 32 546 ,
+ q movim = 39 , q esc movim code = 32 547 ,
+ q fequ = 40 , q fequ code = 32 548 ,
+ q tlsequ = 41 , q tlsequ code = 32 549 ,
+(* q case = 42 , *) q esc case = 32 544 ,
+ q plus = 43 ,
+ q minus = 44 ,
+ q mult = 45 ,
+ q int div = 46 ,
+ q real div = 47 ,
+ q equal = 48 ,
+ q lessequal = 49 ,
+ q ulseq = 50 , q ulseq code = 21 504 ,
+ q pdadd = 51 , q pdadd code = 32 653 ,
+ q ppsub = 52 , q ppsub code = 32 654 ,
+ q dimov = 53 , q dimov code = 32 655 ,
+ q idmov = 54 , q idmov code = 32 656 ;
+
+INT CONST q make false code :: - 1 022 ,
+ q longa subs code :: - 159 ,
+ q penter code :: - 511 ;
+
+
+ (***** Deklaration *****)
+
+PROC declare (OPN VAR operation) :
+ operation.kind := proc op ;
+ get module nr (operation.mod nr) ;
+ operation.top of stack := 0
+ENDPROC declare ;
+
+PROC declare (TEXT CONST name, INT CONST first, params, OPN VAR operation) :
+ declare (operation) ;
+ entry into name and pt table if necessary ;
+ enter params ;
+ enter result ;
+ enter module number .
+
+entry into name and pt table if necessary :
+ declare object (name, nt link, permanent pointer) .
+
+enter params :
+ field pointer := first ;
+ FOR index FROM 1 UPTO params REP
+ enter param (param field [field pointer]) ;
+ NEXTPARAM field pointer
+ PER .
+
+enter result :
+ enter param (param field[field pointer].type, permanent proc op) .
+
+enter module number :
+ put next permanent (operation.mod nr)
+ENDPROC declare ;
+
+PROC enter param (PARAMDESCRIPTOR CONST param) :
+ IF param.access = const
+ THEN enter param (param.type, permanent param const)
+ ELIF param.access = var
+ THEN enter param (param.type, permanent param var)
+ ELSE errorstop ("Unknown Access")
+ FI
+ENDPROC enter param ;
+
+PROC enter param (DTYPE CONST type, INT CONST permanent mode) :
+ unsigned arithmetic ;
+ SELECT type class (type) OF
+ CASE 0, 1, 2 : put next permanent (CONCR(type) + permanent mode)
+ OTHERWISE errorstop ("Illegal Type")
+ ENDSELECT
+ENDPROC enter param ;
+
+
+ (***** Definition *****)
+
+PROC define (OPN VAR opn) :
+ IF NOT module open THEN errorstop (module not opened)
+ ELSE proc head (opn.mod nr, opn.top of stack)
+ FI
+ENDPROC define ;
+
+PROC set length of local storage (OPN VAR opn, INT CONST size) :
+ IF size < 0 OR size > local address limit
+ THEN errorstop (address overflow)
+ ELIF opn.top of stack = 0
+ THEN errorstop (define missing)
+ ELIF opn.kind <> proc op
+ THEN errorstop (proc op expected)
+ FI ;
+ set length (opn.top of stack, size + eumel0 stack offset)
+ENDPROC set length of local storage ;
+
+PROC define (OPN VAR operation, INT CONST size) :
+ define (operation) ;
+ set length of local storage (operation, size)
+ENDPROC define ;
+
+
+ (***** Identifikation *****)
+
+INT VAR counter, result index, result type repr;
+
+PROC identify (TEXT CONST name, INT CONST first, params, OPN VAR operation,
+ BOOL VAR object exists) :
+ find result entry ;
+ to object (name) ;
+ IF found THEN first fit and leave if found FI ;
+ IF eumel0 THEN identify eumel0 instruction
+ ELSE yield undefined operation
+ FI .
+
+find result entry :
+ result index := first;
+ counter := 0 ;
+ WHILE counter < params REP
+ NEXTPARAM result index ;
+ counter INCR 1
+ PER ;
+ check on param field exceeded .
+
+check on param field exceeded :
+ IF result index > size of param field
+ THEN errorstop (param field exceeded)
+ FI .
+
+yield undefined operation :
+ declare (result index, undefined type) ;
+ apply (result index, nop) ;
+ object exists := FALSE .
+
+first fit and leave if found :
+ WHILE yet another procedure exists REP
+ check one procedure and leave if match ;
+ next procedure
+ PER .
+
+yet another procedure exists :
+ permanent pointer <> 0 .
+
+check one procedure and leave if match:
+ param link := permanent pointer + wordlength ;
+ set end marker if end of list ;
+ counter := params ;
+ field pointer := first ;
+ REP
+ IF end of params AND counter = 0
+ THEN procedure found
+ ELIF end of params OR counter = 0
+ THEN LEAVE check one procedure and leave if match
+ ELSE check next param
+ FI
+ PER .
+
+check next param :
+ get type and mode (CONCR(pt type)) ;
+ IF same types THEN set param mode ;
+ field pointer INCR 1 ;
+ param link INCR 1 ;
+ set end marker if end of list ;
+ counter DECR 1 ;
+ ELSE LEAVE check one procedure and leave if match
+ FI .
+
+same types : (* inline version ! *)
+ equal types .
+
+set param mode :
+ param field [field pointer].access := mode .
+
+procedure found :
+ get result ;
+ operation.kind := proc op ;
+ operation.mod nr := module number ;
+ operation.top of stack := 0 ;
+ object exists := TRUE ;
+ LEAVE identify .
+
+get result :
+ get type and mode (result type) ;
+ declare (result index, mode) .
+
+module number :
+ cdbint (param link + 1) .
+
+result type :
+ CONCR (param field [result index].type) .
+
+eumel0 :
+ eumel0 opn.mod nr := link (eumel 0 opcodes, name) ;
+ eumel0 opn.mod nr <> 0 .
+
+identify eumel 0 instruction :
+ init result type with void ;
+ CONCR (operation) := CONCR (eumel0 opn) ;
+ object exists := check params and set result ;
+ declare (result index, DTYPE:(result type repr)) ;
+ declare (result index, const) .
+
+init result type with void :
+ result type repr := void id .
+
+check params and set result :
+ SELECT operation.mod nr OF
+ CASE q return, q false return, q true return : no params
+ CASE q inc1, q dec1 : one int param yielding void
+ CASE q pproc, q pp, q ln : one param yielding void
+ CASE q test : one param yielding bool
+ CASE q clear, q ppv : one int or bool param yielding void
+ CASE q make false : one bool param yielding void
+ CASE q move : two int or bool params yielding void
+ CASE q compl int, q inc, q dec : two int params yielding void
+ CASE q compl real, q fmove : two real params yielding void
+ CASE q equ, q lsequ, q ulseq : two int params yielding bool
+ CASE q fequ, q flsequ : two real params yielding bool
+ CASE q tequ, q tlsequ : two text params yielding bool
+ CASE q tmove : two text params yielding void
+ CASE q accds, q ref, q movim,
+ q dimov, q idmov : two params yielding void
+ CASE q add, q sub, q esc mult,
+ q esc div, q esc mod : three int params yielding void
+ CASE q fadd, q fsub, q fmult, q fdiv : three real params yielding void
+ CASE q select, q movex, q alias ds,
+ q pdadd, q ppsub : three params
+ CASE q subscript : five params
+ CASE q plus, q mult : two intreals yielding intreal
+ CASE q minus : monadic or dyadic minus
+ CASE q int div : two int params yielding int
+ CASE q real div : two real params yielding real
+ CASE q equal, q lessequal : two intrealtexts yielding bool
+ OTHERWISE FALSE
+ ENDSELECT .
+
+no params :
+ params = 0 .
+
+one int param yielding void :
+ p1 void (int type, first, params) .
+
+one param yielding void :
+ params = 1 .
+
+one param yielding bool :
+ IF params = 1 THEN result type repr := bool id ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+one int or bool param yielding void :
+ p1 void (int type, first, params) OR p1 void (bool type, first, params) .
+
+one bool param yielding void :
+ p1 void (bool type, first, params) .
+
+two int or bool params yielding void :
+ p2 (int type, first, params, void id) OR
+ p2 (bool type, first, params, void id) .
+
+two int params yielding void :
+ p2 (int type, first, params, void id) .
+
+two real params yielding void :
+ p2 (real type, first, params, void id) .
+
+two text params yielding void :
+ p2 (text type, first, params, void id) .
+
+two int params yielding bool :
+ p2 (int type, first, params, bool id) .
+
+two real params yielding bool :
+ p2 (real type, first, params, bool id) .
+
+two text params yielding bool :
+ p2 (text type, first, params, bool id) .
+
+two params yielding void :
+ params = 2 .
+
+three int params yielding void :
+ p3 void (int type, first, params) .
+
+three real params yielding void :
+ p3 void (real type, first, params) .
+
+three params :
+ params = 3 .
+
+five params :
+ params = 5 .
+
+two intreals yielding intreal :
+ two int params yielding int OR two real params yielding real .
+
+monadic or dyadic minus :
+ IF params = 2 THEN two intreals yielding intreal
+ ELIF params = 1 THEN monadic minus
+ ELSE FALSE
+ FI .
+
+monadic minus :
+ result type repr := CONCR (param field[first].type) ;
+ result type repr = int id OR result type repr = real id .
+
+two intrealtexts yielding bool :
+ two int params yielding bool OR two real params yielding bool OR
+ two text params yielding bool .
+
+two int params yielding int :
+ p2 (int type, first, params, int id) .
+
+two real params yielding real :
+ p2 (real type, first, params, real id)
+ENDPROC identify ;
+
+BOOL PROC p1 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 1 AND param type is requested plain type .
+
+param type is requested plain type :
+ CONCR (param field [first].type) = CONCR (requested type)
+
+ENDPROC p1 void ;
+
+BOOL PROC p2 (DTYPE CONST requested type, INT CONST first, param nr,
+ INT CONST result type) :
+ IF param nr = 2 AND param types equal requested plain type
+ THEN result type repr := result type ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+param types equal requested plain type :
+ CONCR (param field [first] .type) = CONCR (requested type) AND
+ CONCR (param field [first+1].type) = CONCR (requested type)
+
+ENDPROC p2 ;
+
+BOOL PROC p3 void (DTYPE CONST requested type, INT CONST first, param nr) :
+ param nr = 3 AND param types ok .
+
+param types ok :
+ FOR index FROM first UPTO first+2 REP
+ IF different param types THEN LEAVE p3 void WITH FALSE FI
+ PER ;
+ TRUE .
+
+different param types :
+ CONCR (param field [index].type) <> CONCR (requested type)
+ENDPROC p3 void;
+
+
+ (***** Applikation *****)
+
+INT VAR address representation, left repr, right repr, result repr;
+
+PROC apply (INT CONST first, nr of params, OPN CONST opn) :
+ IF NOT module open THEN errorstop (module not opened) FI ;
+ SELECT opn.kind OF
+ CASE eumel 0 : generate eumel0 instruction
+ CASE proc op : call operation
+ CASE param proc : call param proc
+ CASE nil :
+ OTHERWISE errorstop (illegal kind)
+ ENDSELECT .
+
+call operation :
+ push params if necessary (first, nr of params, opn.mod nr) ;
+ call (opn.mod nr) .
+
+call param proc :
+ result addr.kind := local ref ;
+ result addr.value := opn.mod nr ;
+ INT CONST module nr := REPR result addr ;
+ push params if necessary (first, nr of params, module nr) ;
+ call param (module nr) .
+
+generate eumel0 instruction :
+ SELECT real nr of params OF
+ CASE 0 : p0 instruction
+ CASE 1 : apply p1 (opn, first addr)
+ CASE 2 : apply p2 (opn, first addr, second addr)
+ CASE 3 : apply p3 (opn, left type, first addr, second addr, third addr)
+ CASE 5 : subscript operation
+ OTHERWISE errorstop (wrong nr of params + text (nr of params))
+ ENDSELECT .
+
+real nr of params :
+ IF operator denotation THEN nr of params + 1
+ ELSE nr of params
+ FI .
+
+operator denotation :
+ opn.mod nr >= q plus AND opn.mod nr < q ulseq .
+
+p0 instruction :
+ IF opn.mod nr = q return THEN s0 (q return code)
+ ELIF opn.mod nr = q true return THEN s0 (q true return code)
+ ELIF opn.mod nr = q false return THEN s0 (q false return code)
+ ELSE errorstop (wrong nr of params +
+ mnemonic (opn))
+ FI .
+
+subscript operation :
+ IF opn.mod nr = q subscript
+ THEN subscription
+ ELSE errorstop (wrong nr of params + text (nr of params))
+ FI .
+
+subscription :
+ ADDRESS CONST element length :: param field [first+2].addr ,
+ limit :: param field [first+3].addr ;
+ check on immediates ;
+ IF element length.value < 1024
+ THEN s0 (q subscript code + element length.value)
+ ELSE s0 (q longa subs code) ;
+ s0 (element length.value)
+ FI ;
+ s3 (limit.value - 1, subs index, base addr, subs result) .
+
+check on immediates :
+ IF element length.kind <> immediate value OR
+ limit.kind <> immediate value
+ THEN errorstop (no immediate value)
+ FI .
+
+subs index : REPR param field [first+1].addr .
+
+base addr : REPR param field [first].addr .
+
+subs result : REPR param field [first+4].addr .
+
+first addr :
+ param field [first].addr .
+
+left type :
+ param field [first].type .
+
+second addr :
+ param field [nextparam (first)].addr .
+
+third addr :
+ param field [nextparam(nextparam(first))].addr
+ENDPROC apply ;
+
+PROC push params if necessary (INT CONST first, nr of params, mod nr) :
+ init param push (mod nr) ;
+ field pointer := first ;
+ IF nr of params > 0 THEN push params FI ;
+ push result if there is one .
+
+push params :
+ FOR index FROM 1 UPTO nr of params REP
+ apply p1 (push code, param addr) ;
+ NEXTPARAM field pointer
+ PER .
+
+push code :
+ param field [field pointer].push opn .
+
+param addr :
+ param field [field pointer].addr .
+
+push result if there is one :
+ IF push result necessary
+ THEN push result address (REPR param field [field pointer].addr)
+ FI .
+
+push result necessary :
+ param field [field pointer].push opn.kind <> nil AND
+ is not void bool or undefined (param field [field pointer].type)
+ENDPROC push params if necessary ;
+
+PROC apply p1 (OPN CONST opn, ADDRESS CONST addr) :
+ IF opn.mod nr = q ln THEN generate line number
+ ELIF opn.mod nr = q pproc THEN push module nr
+ ELSE gen p1 instruction
+ FI .
+
+gen p1 instruction :
+ address representation := REPR addr ;
+ SELECT opn.mod nr OF
+ CASE q inc1 : t1 (q inc1 code, address representation)
+ CASE q dec1 : t1 (q dec1 code, address representation)
+ CASE q clear : t1 (q clear code,address representation)
+ CASE q test : test bool object (address representation)
+ CASE q pp : push param (address representation)
+ CASE q ppv : s1 (q ppv code, address representation)
+ CASE q make false : s1 (q make false code, address representation)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+generate line number :
+ IF addr.kind = immediate value THEN mark line (addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+push module nr :
+ IF addr.kind = module nr THEN push param proc (addr.value)
+ ELSE errorstop (no mod nr)
+ FI
+ENDPROC apply p1;
+
+PROC apply p2 (OPN CONST opn, ADDRESS CONST left addr, right addr):
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movim THEN move immediate
+ ELSE gen p2 instruction
+ FI .
+
+gen p2 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q move : t2 (q move code, right repr, left repr)
+ CASE q inc : t2 (q inc code, right repr, left repr)
+ CASE q dec : t2 (q dec code, right repr, left repr)
+ CASE q equ : compare (q equ code, left repr, right repr)
+ CASE q lsequ : compare (q lsequ code, left repr, right repr)
+ CASE q ulseq : compare (q ulseq code, left repr, right repr)
+ CASE q fmove : t2 (q fmove code, right repr, left repr)
+ CASE q flsequ : compare (q flsequ code, left repr, right repr)
+ CASE q tmove : t2 (q tmove code, right repr, left repr)
+ CASE q tequ : compare (q tequ code, left repr, right repr)
+ CASE q compl int : s2 (q compl int code, left repr, right repr)
+ CASE q compl real : s2 (q compl real code, left repr, right repr)
+ CASE q fequ : compare (q fequ code, left repr, right repr)
+ CASE q tlsequ : compare (q tlsequ code, left repr, right repr)
+ CASE q accds : t2 (q access ds code, left repr, right repr)
+ CASE q ref : t2 (q ref code, left repr, right repr)
+ CASE q dimov : s2 (q dimov code, left repr, right repr)
+ CASE q idmov : s2 (q idmov code, left repr, right repr)
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+move immediate :
+ IF right addr.kind = immediate value
+ THEN s0 (q esc movim code) ;
+ s1 (right addr.value, left repr)
+ ELSE errorstop (no immediate value)
+ FI
+ENDPROC apply p2;
+
+PROC apply p3 (OPN CONST opn, DTYPE CONST left dtype,
+ ADDRESS CONST left addr, right addr, result addr ):
+ result repr := REPR result addr ;
+ IF opn.mod nr = q pdadd THEN select with dint; LEAVE apply p3
+ ELIF opn.mod nr = q select THEN gen select instruction; LEAVE apply p3 FI ;
+ left repr := REPR left addr ;
+ IF opn.mod nr = q movex THEN gen long move
+ ELIF opn.mod nr = q alias ds THEN alias dataspace
+ ELSE gen p3 instruction
+ FI .
+
+gen long move :
+ IF right addr.kind = immediate value
+ THEN long move (left repr, result repr, right addr.value)
+ ELSE errorstop (no immediate value)
+ FI .
+
+alias dataspace :
+ IF right addr.value = immediate value
+ THEN s0 (q alias ds code) ;
+ s2 (right addr.value, result repr, left repr)
+ ELSE errorstop (no immediate value)
+ FI .
+
+gen select instruction :
+ IF right addr.kind = immediate value
+ THEN IF different bases
+ THEN access external (left addr.value, right addr.value)
+ ELSE t1 (q select code, REPR left addr) ;
+ s1 (right addr.value, result repr)
+ FI
+ ELSE errorstop (no immediate value)
+ FI .
+
+select with dint :
+ right repr := REPR right addr ;
+ IF different bases THEN access external packet
+ ELSE simple access
+ FI .
+
+different bases :
+ left addr.kind = p base AND left addr.value <> packet base .
+
+simple access :
+ s3 (q pdadd code, REPR left addr, right repr, result repr) .
+
+access external packet :
+ access external (left addr.value, global address zero) ;
+ s3 (q pdadd code, REPR REF result addr, right repr, result repr) .
+
+gen p3 instruction :
+ right repr := REPR right addr ;
+ SELECT opn.mod nr OF
+ CASE q add : int add
+ CASE q sub : int sub
+ CASE q fadd : real add
+ CASE q fsub : real sub
+ CASE q fmult : real mult
+ CASE q fdiv, q real div : real div
+ CASE q esc mult : int mult
+ CASE q esc div, q int div : int div
+ CASE q esc mod : int mod
+ CASE q plus : int real add
+ CASE q minus : int real sub
+ CASE q mult : int real mult
+ CASE q equal, q lessequal : compare (comp code, left repr, right repr)
+ CASE q ppsub : distance between two objects
+ OTHERWISE errorstop (wrong nr of params + mnemonic (opn))
+ ENDSELECT .
+
+int add : compute (q add code, left repr, right repr, result repr) .
+
+int sub : compute (q sub code, left repr, right repr, result repr) .
+
+real add : compute (q fadd code, left repr, right repr, result repr) .
+
+real sub : compute (q fsub code, left repr, right repr, result repr) .
+
+real mult : compute (q fmult code, left repr, right repr, result repr) .
+
+real div : compute (q fdiv code, left repr, right repr, result repr) .
+
+int mult : s3 (q esc mult code, left repr, right repr, result repr) .
+
+int div : s3 (q esc div code, left repr, right repr, result repr) .
+
+int mod : s3 (q esc mod code, left repr, right repr, result repr) .
+
+int real add :
+ IF left type = int id THEN int add
+ ELSE real add
+ FI .
+
+int real sub :
+ IF left type = int id THEN int sub
+ ELSE real sub
+ FI .
+
+int real mult :
+ IF left type = int id THEN int mult
+ ELSE real mult
+ FI .
+
+comp code :
+ SELECT left type OF
+ CASE int id : IF opn.mod nr = q equal THEN q equ ELSE q lsequ FI
+ CASE real id : IF opn.mod nr = q equal THEN q fequ ELSE q flsequ FI
+ CASE string id : IF opn.mod nr = q equal THEN q tequ ELSE q tlsequ FI
+ OTHERWISE errorstop (type error); q equ
+ ENDSELECT .
+
+left type : CONCR (left dtype) .
+
+distance between two objects :
+ s3 (q ppsub code, left repr, right repr, result repr)
+
+ENDPROC apply p3;
+
+PROC access external (INT CONST old base, offset) :
+ s0 (q penter code + old base) ;
+ t2 (q ref code, offset, result repr) ;
+ s0 (q penter code + packet base)
+ENDPROC access external ;
+
+
+ (***** Modul *****)
+
+BOOL VAR module open ;
+
+.init opn section :
+ module open := FALSE .;
+
+PROC begin module :
+ IF module open THEN errorstop (nested module)
+ ELSE begin modul ;
+ module open := TRUE
+ FI
+ENDPROC begin module ;
+
+PROC end module :
+ IF NOT module open
+ THEN errorstop (module not opened)
+ ELSE end modul ;
+ module open := FALSE
+ FI
+ENDPROC end module ;
+
+TEXT PROC dump (OPN CONST operation) :
+ IF operation.kind = proc op THEN " PROC" + text (operation.mod nr, 5)
+ ELIF operation.kind = eumel 0 THEN " EUMEL0: " + mnemonic (operation)
+ ELSE " undef. Opn"
+ FI
+ENDPROC dump ;
+
+PROC begin modul :
+ EXTERNAL 10073
+ENDPROC begin modul ;
+
+PROC end modul :
+ EXTERNAL 10011
+ENDPROC end modul ;
+
+PROC proc head (INT VAR mod nr, top of stack) :
+ EXTERNAL 10012
+ENDPROC proc head ;
+
+PROC set length (INT CONST top of stack, size) :
+ EXTERNAL 10013
+ENDPROC set length ;
+
+PROC get module nr (INT VAR module nr) :
+ EXTERNAL 10016
+ENDPROC get module nr ;
+
+PROC compute (INT CONST op code, l addr, r addr, result address) :
+ EXTERNAL 10017
+ENDPROC compute ;
+
+PROC compare (INT CONST op code, l addr, r addr) :
+ EXTERNAL 10018
+ENDPROC compare ;
+
+PROC long move (INT CONST to, from, length) :
+ EXTERNAL 10019
+ENDPROC long move ;
+
+PROC call (INT CONST mod nr) :
+ EXTERNAL 10022
+ENDPROC call ;
+
+PROC call param (INT CONST mod nr) :
+ EXTERNAL 10023
+ENDPROC call param ;
+
+PROC push param (INT CONST addr) :
+ EXTERNAL 10024
+ENDPROC push param ;
+
+PROC push param proc (INT CONST mod nr) :
+ EXTERNAL 10025
+ENDPROC push param proc ;
+
+PROC init param push (INT CONST mod nr) :
+ EXTERNAL 10026
+ENDPROC init param push ;
+
+PROC push result address (INT CONST addr) :
+ EXTERNAL 10027
+ENDPROC push result address ;
+
+PROC test bool object (INT CONST addr) :
+ EXTERNAL 10192
+ENDPROC test bool object ;
+
+PROC mark line (INT CONST line number) :
+ EXTERNAL 10030
+ENDPROC mark line ;
+
+PROC s0 (INT CONST op code) :
+ EXTERNAL 10038
+ENDPROC s0 ;
+
+PROC s1 (INT CONST op code, addr) :
+ EXTERNAL 10039
+ENDPROC s1 ;
+
+PROC s2 (INT CONST op code , addr1, addr2) :
+ EXTERNAL 10040
+ENDPROC s2 ;
+
+PROC s3 (INT CONST op code, addr1, addr2, addr3) :
+ EXTERNAL 10041
+ENDPROC s3 ;
+
+PROC t1 (INT CONST op code, addr) :
+ EXTERNAL 10042
+ENDPROC t1 ;
+
+PROC t2 (INT CONST op code, addr1, addr2) :
+ EXTERNAL 10043
+ENDPROC t2 ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 9. Speicherverwaltung 03.06.1986 *)
+(* *)
+(* Ablage der Paketdaten *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR address value;
+
+INT CONST data allocation by coder := 1 ,
+ data allocation by user := 2 ;
+
+LET not initialized = 0 ,
+ wrong mm mode = "Wrong MM Mode" ,
+ define on non global = "Define for GLOB only" ,
+ text too long = "TEXT too long" ;
+
+TEXT VAR const buffer :: point line ;
+
+.reset memory management mode :
+ memory management mode := not initialized . ;
+
+PROC reserve storage (INT CONST size) :
+ IF memory management mode <> data allocation by user
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (address value, size) ;
+ memory management mode := not initialized
+ENDPROC reserve storage ;
+
+PROC allocate variable (ADDRESS VAR addr, INT CONST size) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate var (addr.value, size) ;
+ addr.kind := global
+ENDPROC allocate variable ;
+
+PROC allocate denoter (ADDRESS VAR addr, INT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate int denoter (addr.value) ;
+ put data word (value, addr.value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, REAL CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate real denoter (addr.value) ;
+ addr.kind := global ;
+ define (addr, value)
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, TEXT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate text denoter (addr.value, (LENGTH value+1) DIV 2 + 2) ;
+ addr.kind := global ;
+ skip heaplink;
+ define (addr, value) ;
+ reset heaplink .
+
+skip heaplink :
+ addr.value INCR 1 .
+
+reset heaplink :
+ addr.value DECR 1
+ENDPROC allocate denoter ;
+
+PROC allocate denoter (ADDRESS VAR addr, DINT CONST value) :
+ IF memory management mode <> data allocation by coder
+ THEN errorstop (wrong mm mode)
+ FI ;
+ allocate dint denoter (addr.value, value) ;
+ addr.kind := global
+ENDPROC allocate denoter ;
+
+PROC allocate dint denoter (INT VAR addr offset, DINT CONST value) :
+ adjust to an even address if necessary ;
+ put data word (value.low, addr offset) ;
+ allocate int denoter (address value) ;
+ put data word (value.high, address value) .
+
+adjust to an even address if necessary :
+ allocate int denoter (addr offset) ;
+ IF (addr offset AND 1) <> 0 THEN allocate int denoter (addr offset) FI
+ENDPROC allocate dint denoter ;
+
+PROC define (ADDRESS CONST addr, INT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value, addr.value)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, DINT CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ put data word (value.low , addr.value);
+ put data word (value.high, addr.value + 1)
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, REAL CONST value) :
+ IF addr.kind <> global
+ THEN errorstop (define on non global)
+ FI ;
+ replace (const buffer, 1, value) ;
+ address value := addr.value ;
+ FOR index FROM 1 UPTO 4 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER
+ENDPROC define ;
+
+PROC define (ADDRESS CONST addr, TEXT CONST value) :
+ IF addr.kind <> global THEN errorstop (define on non global)
+ ELIF LENGTH value > 255 THEN errorstop (text too long)
+ FI ;
+ address value := addr.value ;
+ const buffer := code (LENGTH value) ;
+ const buffer CAT value ;
+ const buffer CAT ""0"" ;
+ FOR index FROM 1 UPTO LENGTH const buffer DIV 2 REP
+ put data word (const buffer ISUB index, address value) ;
+ address value INCR 1
+ PER ;
+ const buffer := point line
+ENDPROC define ;
+
+PROC allocate var (INT VAR addr, INT CONST length) :
+ EXTERNAL 10033
+ENDPROC allocate var ;
+
+PROC allocate int denoter (INT VAR addr) :
+ EXTERNAL 10034
+ENDPROC allocate int denoter ;
+
+PROC allocate real denoter (INT VAR addr) :
+ EXTERNAL 10035
+ENDPROC allocate real denoter ;
+
+PROC allocate text denoter (INT VAR addr, INT CONST length) :
+ EXTERNAL 10036
+ENDPROC allocate text denoter ;
+
+PROC put data word (INT CONST value, INT CONST addr) :
+ EXTERNAL 10037
+ENDPROC put data word ;
+
+
+#page#
+(**************************************************************************)
+(* *)
+(* 10. Inspector 28.10.1987 *)
+(* *)
+(**************************************************************************)
+
+
+
+INT VAR line number, pattern length, begin of packet,
+ last packet entry, indentation;
+
+TEXT VAR bulletin name, type and mode, pattern, buffer, dummy name;
+
+DATASPACE VAR bulletin ds :: nilspace ;
+
+.packet name :
+ cdb text (cdb int(packet link + wordlength) + two word length) .
+
+.packet entry :
+ permanent pointer = 0 OR
+ cdbint (permanent pointer) = permanent packet OR
+ cdbint (permanent pointer + wordlength) = permanent packet .
+
+.within editor :
+ aktueller editor > 0 . ;
+
+TEXT PROC type name (DTYPE CONST type) :
+ type and mode := "" ;
+ IF CONCR (type) = void id THEN type and mode CAT "VOID"
+ ELSE name of type (CONCR (type))
+ FI ;
+ type and mode
+ENDPROC type name ;
+
+TEXT PROC dump (DTYPE CONST type) :
+(* type and mode := "TYPE " ;
+ name of type (CONCR (type)) ;
+ type and mode
+*)
+ type name (type) (* aus Kompatibilitätsgründen zum 1.9.2 Coder / rr *)
+ENDPROC dump ;
+
+PROC name of type (INT CONST type) :
+ SELECT type OF
+ CASE void id :
+ CASE int id : type and mode CAT "INT"
+ CASE real id : type and mode CAT "REAL"
+ CASE string id : type and mode CAT "TEXT"
+ CASE bool id, bool result id : type and mode CAT "BOOL"
+ CASE dataspace id : type and mode CAT "DATASPACE"
+ CASE row id : type and mode CAT "ROW "
+ CASE struct id : type and mode CAT "STRUCT"
+ OTHERWISE : complex type
+ ENDSELECT .
+
+complex type :
+ unsigned arithmetic ;
+ IF type > ptt limit THEN perhaps permanent struct or row
+ ELSE get complex type
+ FI .
+
+perhaps permanent struct or row :
+ index := type + begin of pt minus ptt limit ;
+ mode := cdb int (index) MOD ptt limit ;
+ IF mode = permanent row THEN get permanent row
+ ELIF mode = permanent struct THEN get permanent struct
+ ELSE type and mode CAT "-"
+ FI .
+
+get complex type :
+ index := type + begin of permanent table ;
+ IF is complex type THEN get name
+ ELSE type and mode CAT "-"
+ FI .
+
+is complex type :
+ permanent type definition mode = permanent type .
+
+get name :
+ type and mode CAT cdb text (link to type name + two word length) .
+
+link to type name :
+ cdb int (index + three word length) .
+
+permanent type definition mode :
+ cdb int (index + wordlength) .
+
+get permanent row :
+ INT VAR t;
+ type and mode CAT "ROW " ;
+ type and mode CAT text (cdb int (index + wordlength)) ;
+ type and mode CAT " " ;
+ param link := index + two wordlength ;
+ get type and mode (t) ;
+ name of type (t) .
+
+get permanent struct :
+ type and mode CAT "STRUCT ( ... )"
+ENDPROC name of type ;
+
+PROC help (TEXT CONST proc name) :
+ prep bulletin ;
+ prep help ;
+ scan (object name) ;
+ next symbol (pattern) ;
+ packet link := end of permanent table ;
+ IF function = 0 THEN standard help
+ ELSE asterisk help
+ FI .
+
+prep help :
+ object name := compress (proc name) ;
+ INT VAR function :: 0 ;
+ INT CONST l :: LENGTH object name ;
+ IF l > 1 AND object name <> "**"
+ THEN IF (object name SUB l) = "*"
+ THEN function INCR 2 ;
+ delete char (object name, l)
+ FI ;
+ IF (object name SUB 1) = "*"
+ THEN function INCR 1 ;
+ delete char (object name, 1)
+ FI ;
+ IF another asterisk THEN wrong function FI
+ FI.
+
+another asterisk :
+ pos (object name, "*") <> 0 .
+
+wrong function :
+ errorstop ("unzulaessige Sternfunktion") .
+
+standard help :
+ to object (pattern) ;
+ IF found THEN display
+ ELSE error stop ("unbekannt: " + proc name)
+ FI .
+
+display :
+ IF NOT packet entry
+ THEN WHILE permanent pointer <> 0 REP
+ put name of packet if necessary ;
+ put specifications (pattern) ;
+ next procedure
+ ENDREP ;
+ show bulletin file
+ FI .
+
+put name of packet if necessary :
+ IF new packet THEN packet link := permanent pointer ;
+ find begin of packet ;
+ writeline (2) ;
+ write packet name
+ FI .
+
+find begin of packet :
+ REP
+ packet link DECR wordlength
+ UNTIL begin of packet found PER .
+
+begin of packet found :
+ cdb int (packet link) = permanent packet .
+
+new packet :
+ permanent pointer < packet link .
+
+asterisk help :
+ hash table pointer := begin of hash table ;
+ pattern length := LENGTH pattern - 1 ;
+ REP
+ list all objects in current hash table chain ;
+ next hash entry
+ UNTIL end of hash table reached ENDREP ;
+ show bulletin file .
+
+list all objects in current hash table chain :
+ nt link := hash table pointer ;
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ object name := cdb text (nt link + two word length) ;
+ IF matching THEN into bulletin FI
+ PER .
+
+matching :
+ INT CONST p :: pos (object name, pattern) ;
+ SELECT function OF
+ CASE 1 : p <> 0 AND p = LENGTH object name - pattern length
+ CASE 2 : p = 1
+ CASE 3 : p <> 0
+ OTHERWISE FALSE
+ ENDSELECT .
+
+into bulletin :
+ object names into bulletin (BOOL PROC not end of chain)
+ENDPROC help ;
+
+BOOL PROC not end of chain :
+ permanent pointer <> 0
+ENDPROC not end of chain ;
+
+PROC write packet name :
+ indentation := 0 ;
+ write line ;
+ write bulletin line ("PACKET ") ;
+ indentation := 7 ;
+ object name := packet name ;
+ write bulletin line (object name) ;
+ write bulletin line (":") ;
+ writeline (2)
+ENDPROC write packet name ;
+
+PROC put specifications (TEXT CONST proc name) :
+ put obj name (proc name) ;
+ to first param ;
+ IF NOT end of params THEN put param list FI ;
+ put result ;
+ writeline .
+
+to first param :
+ param link := permanent pointer + word length ;
+ set end marker if end of list .
+
+put result :
+ INT VAR type;
+ get type and mode (type) ;
+ IF type <> void id THEN type and mode := " --> " ;
+ name of type (type) ;
+ write bulletin line (type and mode)
+ FI
+ENDPROC put specifications ;
+
+PROC put param list :
+ write bulletin line (" (") ;
+ REP
+ INT VAR type, param mode;
+ get type and mode (type) ;
+ param mode := mode ;
+ put type and mode ;
+ maybe param proc ;
+ next pt param ;
+ IF end of params THEN write bulletin line (")") ;
+ LEAVE put param list
+ FI ;
+ write bulletin line (", ") ;
+ PER .
+
+put type and mode :
+ type and mode := "" ;
+ name of type (type) ;
+ type and mode CAT name of mode ;
+ write bulletin line (type and mode) .
+
+name of mode :
+ IF param mode = const THEN " CONST"
+ ELIF param mode = var THEN " VAR"
+ ELSE " PROC"
+ FI .
+
+maybe param proc :
+ IF mode = permanent param proc THEN put virtual params FI .
+
+put virtual params :
+ skip over result type if complex type ;
+ IF NOT end of virtual params THEN put param list FI.
+
+skip over result type if complex type :
+ next pt param .
+
+end of virtual params :
+ end of params
+ENDPROC put param list ;
+
+PROC to packet (TEXT CONST packet name) :
+ to object ( packet name) ;
+ IF found THEN find start of packet objects FI .
+
+find start of packet objects :
+ last packet entry := 0 ;
+ packet link := before first pt entry ;
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word < 0 THEN IF word = permanent packet THEN packet found
+ ELIF word = permanent end THEN return
+ FI
+ FI
+ ENDREP .
+
+packet found :
+ IF cdb int (packet link + wordlength) = nt link
+ THEN last packet entry := packet link FI .
+
+return :
+ IF last packet entry <> 0 THEN found := TRUE ;
+ packet link := last packet entry
+ ELSE found := FALSE
+ FI ;
+ LEAVE to packet
+ENDPROC to packet ;
+
+PROC next packet :
+ REP
+ packet link INCR wordlength ;
+ word := cdb int (packet link) ;
+ IF word = permanent packet THEN true return
+ ELIF end of permanents THEN false return
+ FI ;
+ ENDREP .
+
+true return :
+ found := TRUE ;
+ LEAVE next packet .
+
+false return :
+ found := FALSE ;
+ LEAVE next packet .
+
+end of permanents :
+ word = permanent end OR packet link > end of permanent table
+ENDPROC next packet ;
+
+PROC prep bulletin :
+ forget (bulletin ds) ;
+ bulletin ds := nilspace ;
+ bulletin file := sequential file (output, bulletin ds) ;
+ line number := 0 ;
+ buffer := ""
+ENDPROC prep bulletin ;
+
+PROC show bulletin file :
+ IF within editor THEN ueberschrift neu FI ;
+ DATASPACE VAR local ds :: bulletin ds ;
+ FILE VAR local file :: sequential file (modify, local ds) ;
+ show (local file) ;
+ forget (local ds)
+ENDPROC show bulletin file ;
+
+PROC write bulletin line (TEXT CONST line) :
+ IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ;
+ buffer CAT line
+ENDPROC write bulletin line ;
+
+PROC writeline :
+ write (bulletin file, buffer) ;
+ line (bulletin file) ;
+ line number INCR 1 ;
+ cout (line number) ;
+ buffer := indentation * " "
+ENDPROC writeline ;
+
+PROC writeline (INT CONST times) :
+ IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
+ writeline
+ ELSE index := times
+ FI ;
+ line (bulletin file, index) ;
+ line number INCR index;
+ indentation := 0 ;
+ cout (line number)
+ENDPROC writeline ;
+
+PROC bulletin (TEXT CONST packet name) :
+ prep bulletin ;
+ scan (packet name) ;
+ next symbol (pattern) ;
+ to packet (pattern) ;
+ IF found THEN list packet ;
+ show bulletin file
+ ELSE error stop (packet name + " ist kein Paketname")
+ FI .
+
+ENDPROC bulletin ;
+
+PROC list packet :
+ begin of packet := packet link + word length ;
+ write packet name ;
+ find end of packet ;
+ run through nametab and list all packet objects .
+
+find end of packet :
+ last packet entry := begin of packet ;
+ REP
+ last packet entry INCR wordlength ;
+ word := cdb int (last packet entry) ;
+ UNTIL end of packet entries PER .
+
+end of packet entries :
+ word = permanent packet OR word = permanent end .
+
+run through nametab and list all packet objects :
+ hashtable pointer := begin of hashtable ;
+ REP
+ nt link := hashtable pointer ;
+ list objects of current packet in this chain ;
+ next hash entry
+ UNTIL end of hashtable reached ENDREP .
+
+list objects of current packet in this chain :
+ WHILE yet another nt entry REP
+ permanent pointer := cdb int (nt link + wordlength) ;
+ put objects of this name
+ PER .
+
+put objects of this name :
+ IF there is an entry THEN into bulletin FI .
+
+there is an entry :
+ NOT packet entry AND
+ there is at least one object of this name in the current packet .
+
+there is at least one object of this name in the current packet :
+ REP
+ IF permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ THEN LEAVE there is at least one object of this name
+ in the current packet WITH TRUE FI ;
+ next procedure
+ UNTIL permanent pointer = 0 PER ;
+ FALSE .
+
+into bulletin :
+ object name := cdb text (nt link + two word length) ;
+ object names into bulletin (BOOL PROC within packet)
+ENDPROC list packet ;
+
+BOOL PROC within packet :
+ permanent pointer >= begin of packet AND
+ permanent pointer < last packet entry
+ENDPROC within packet ;
+
+PROC object names into bulletin (BOOL PROC link ok) :
+ scan (object name) ;
+ next symbol (dummy name, mode) ;
+ IF type definition THEN put type definition
+ ELSE put object definitions
+ FI .
+
+type definition :
+ mode = bold AND no params .
+
+no params :
+ cdb int (permanent pointer + word length) >= permanent type .
+
+put type definition :
+ put obj name (object name) ;
+ write bulletin line ("TYPE ") ;
+ writeline (1) .
+
+put object definitions :
+ WHILE link ok REP
+ put specifications (object name) ;
+ next procedure
+ ENDREP
+ENDPROC object names into bulletin ;
+
+PROC bulletin :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ list packet ;
+ write line (4) ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC bulletin ;
+
+PROC put obj name (TEXT CONST name) :
+ buffer := " " ;
+ bulletin name := point line ;
+ change (bulletin name, 1, end of line or name, name) ;
+ buffer CAT bulletin name ;
+ indentation := LENGTH buffer + 1 .
+
+end of line or name :
+ min (LENGTH name, LENGTH bulletin name)
+ENDPROC put obj name ;
+
+PROC packets :
+ prep bulletin ;
+ packet link := first permanent entry ;
+ REP
+ object name := packet name ;
+ put obj name (object name) ;
+ write line ;
+ next packet
+ UNTIL NOT found PER ;
+ show bulletin file
+ENDPROC packets ;
+
+#page#
+(**************************************************************************)
+(* *)
+(* 11. ELAN Run-Interface 04.08.1986 *)
+(* *)
+(* Uebersetzen von ELAN-Programmen *)
+(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *)
+(* *)
+(**************************************************************************)
+
+
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ warning option := FALSE ,
+ listing enabled := FALSE ;
+
+FILE VAR listing file ;
+
+TEXT VAR listing file name := "" ;
+
+
+PROC run (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, no ins)
+END PROC run;
+
+PROC run :
+ run (last param)
+ENDPROC run ;
+
+PROC run again :
+ IF run again mod nr <> 0
+ THEN elan (run again mode, bulletin file, "", run again mod nr,
+ no ins, no lst, check option, no sermon)
+ ELSE errorstop ("'run again' nicht moeglich")
+ FI
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+ enable stop ;
+ IF NOT exists (file name)
+ THEN errorstop ("""" + file name + """ gibt es nicht")
+ FI ;
+ last param (file name) ;
+ run elan (file name, ins)
+ENDPROC insert ;
+
+PROC insert :
+ insert (last param)
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+ FILE VAR source := sequential file (modify, file name) ;
+ IF listing enabled
+ THEN open listing file
+ FI ;
+
+ disable stop ;
+ no do again ;
+ elan (compile file mode, source, "" , run again mod nr,
+ insert option, list option, check option, sermon) ;
+
+ IF anything noted AND command dialogue
+ THEN ignore halt during compiling ;
+ note edit (source) ;
+ last param (file name) ;
+ errorstop ("")
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+open listing file :
+ listing file := sequential file (output, listing file name) ;
+ max line length (listing file, 130)
+
+ENDPROC run elan ;
+(*
+PROC out text (TEXT CONST text, INT CONST out type) :
+ INTERNAL 257 ;
+ IF online
+ THEN out (text)
+ FI ;
+ IF out type = error message OR (warning option AND out type = warning message)
+ THEN note (text) ;
+ FI ;
+ IF listing enabled
+ THEN write (listing file, text)
+ FI
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+ INTERNAL 258 ;
+ IF online
+ THEN out (""13""10"")
+ FI ;
+ IF out type = error message
+ OR (warning option AND out type = warning message)
+ THEN note line
+ ELIF listing enabled
+ THEN line (listing file)
+ FI
+ENDPROC out line ;
+*)
+PROC prot (TEXT CONST file name) :
+ list option := TRUE ;
+ listing file name := file name ;
+ listing enabled := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE ;
+ listing enabled := FALSE
+ENDPROC prot off ;
+
+BOOL PROC prot :
+ list option
+ENDPROC prot ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+BOOL PROC check :
+ check option
+ENDPROC check ;
+
+PROC warnings on :
+ warning option := TRUE
+ENDPROC warnings on ;
+
+PROC warnings off :
+ warning option := FALSE
+ENDPROC warnings off ;
+
+BOOL PROC warnings :
+ warning option
+ENDPROC warnings ;
+
+ENDPACKET eumel coder ;
+
+PACKET dint2 DEFINES dint type :
+
+INT VAR dummy ;
+DTYPE VAR d ;
+identify ("DINT", dummy, dummy, d) ;
+
+DTYPE CONST dint type := d
+
+ENDPACKET dint2 ;
+
diff --git a/basic/eumel0 codes b/basic/eumel0 codes
new file mode 100644
index 0000000..226014c
--- /dev/null
+++ b/basic/eumel0 codes
Binary files differ
diff --git a/basic/gen.BASIC b/basic/gen.BASIC
new file mode 100644
index 0000000..9690ae6
--- /dev/null
+++ b/basic/gen.BASIC
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(* *)
+(* Generatorprogramm zur Installation des EUMEL-BASIC-Systems *)
+(* *)
+(* Autor: Heiko Indenbirken *)
+(* Überarbeitet von: Michael Overdick *)
+(* *)
+(* Stand: 27.08.1987 *)
+(* *)
+(**************************************************************************)
+
+LET coder name = "eumel coder 1.8.1";
+
+show headline;
+from archive ("BASIC.1", (coder name & "eumel0 codes") - all);
+from archive ("BASIC.2",
+ ("BASIC.Runtime" & "BASIC.Administration" & "BASIC.Compiler") - all);
+set status;
+insert ("eumel coder 1.8.1");
+insert ("BASIC.Runtime");
+insert ("BASIC.Administration");
+insert ("BASIC.Compiler");
+forget (coder name & "BASIC.Runtime"
+ & "BASIC.Administration" & "BASIC.Compiler" & "gen.BASIC");
+restore status;
+show end .
+
+show headline:
+ page;
+ putline (" "15"Einrichten des EUMEL-BASIC-Systems "14"");
+ line .
+
+set status:
+ BOOL VAR old check := check,
+ old warnings := warnings,
+ old command dialogue := command dialogue;
+ check off;
+ warnings off;
+ command dialogue (FALSE).
+
+restore status:
+ IF old check THEN do ("check on") ELSE do ("check off") FI;
+ IF old warnings THEN warnings on FI;
+ command dialogue (old command dialogue).
+
+show end:
+ line (2);
+ putline (" "15"BASIC-System installiert "14"");
+ line .
+
+PROC from archive (TEXT CONST name, THESAURUS CONST files):
+ IF highest entry (files) > 0
+ THEN ask for archive;
+ archive (name);
+ fetch (files, archive);
+ release (archive);
+ putline ("Archiv abgemeldet !")
+ FI .
+
+ask for archive:
+ line;
+ IF no ("Archiv """ + name + """ eingelegt")
+ THEN errorstop ("Archive nicht bereit") FI .
+
+END PROC from archive;
+
+THESAURUS OP & (TEXT CONST left, right):
+ THESAURUS VAR result := empty thesaurus;
+ insert (result, left);
+ insert (result, right);
+ result
+END OP &;
+
+THESAURUS OP & (THESAURUS CONST left, TEXT CONST right):
+ THESAURUS VAR result := left;
+ insert (result, right);
+ result
+END OP &;
+
+
diff --git a/datatype/complex b/datatype/complex
new file mode 100644
index 0000000..e2139d0
--- /dev/null
+++ b/datatype/complex
@@ -0,0 +1,115 @@
+
+PACKET complex DEFINES COMPLEX,:=,complex zero,complex one,complex i,
+ complex,realpart,imagpart,CONJ,+,-,*,/,=,<>,
+ put,get, ABS, sqrt, phi, dphi :
+
+TYPE COMPLEX = STRUCT(REAL re,im);
+COMPLEX PROC complex zero: COMPLEX :(0.0,0.0). END PROC complex zero;
+COMPLEX PROC complex one : COMPLEX :(1.0,0.0). END PROC complex one;
+COMPLEX PROC complex i : COMPLEX :(0.0,1.0). END PROC complex i;
+
+OP := (COMPLEX VAR dest, COMPLEX CONST source) :
+
+ CONCR (dest) := CONCR (source)
+
+ENDOP := ;
+
+COMPLEX PROC complex(REAL CONST re,im):
+ COMPLEX :(re,im).
+END PROC complex;
+
+REAL PROC realpart(COMPLEX CONST number):
+ number.re.
+END PROC realpart;
+
+REAL PROC imagpart(COMPLEX CONST number):
+ number.im.
+END PROC imagpart ;
+
+COMPLEX OP CONJ(COMPLEX CONST number):
+ COMPLEX :( number.re,- number.im).
+END OP CONJ;
+
+BOOL OP =(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im=b.im
+ ELSE FALSE
+ FI.
+END OP =;
+
+BOOL OP <>(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im<>b.im
+ ELSE TRUE
+ FI.
+END OP <>;
+
+COMPLEX OP +(COMPLEX CONST a,b):
+ COMPLEX :(a.re+b.re,a.im+b.im).
+END OP +;
+
+COMPLEX OP -(COMPLEX CONST a,b):
+ COMPLEX :(a.re-b.re,a.im-b.im).
+END OP -;
+
+COMPLEX OP *(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a ::a.im,
+ re of b::b.re,im of b ::b.im;
+ COMPLEX :(re of a*re of b- im of a *im of b,
+ re of a*im of b+ im of a*re of b).
+END OP *;
+
+COMPLEX OP /(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a::a.im,
+ re of b::b.re,im of b::b.im;
+ REAL VAR sqare sum of re and im ::b.re*b.re+b.im*b.im;
+ COMPLEX :( (re of a * re of b + im of a * im of b)/sqare sum of re and im,
+ (im of a *re of b - re of a*im of b)/sqare sum of re and im).
+END OP /;
+
+PROC get(COMPLEX VAR a):
+ REAL VAR realpart,imagpart;
+ get(realpart);get(imagpart);
+ a:= COMPLEX :(realpart,imagpart);
+END PROC get;
+
+PROC put(COMPLEX CONST a):
+ put(a.re);put(" ");put(a.im);
+END PROC put;
+
+REAL PROC dphi(COMPLEX CONST x):
+ IF imagpart(x)=0.0 THEN reell
+ ELIF realpart(x)=0.0 THEN imag
+ ELIF realpart(x)>0.0 THEN realpositiv
+ ELSE realnegativ
+ FI.
+reell: IF sign(realpart(x)) < 0 THEN 180.0 ELSE 0.0 FI.
+imag: IF imagpart(x)>0.0 THEN 90.0 ELSE 270.0 FI.
+realpositiv:IF imagpart(x)>0.0 THEN arctand(realpart(x)/imagpart(x))
+ ELSE
+arctand(realpart(x)/imagpart(x))+360.0 FI.
+realnegativ: arctand(realpart(x)/imagpart(x))+180.0.
+END PROC dphi;
+
+REAL PROC phi(COMPLEX CONST x):
+dphi(x)*3.141592653689793/180.0.
+END PROC phi;
+
+COMPLEX PROC sqrt(COMPLEX CONST x):
+IF x=complex zero THEN x
+ELIF realpart(x)<0.0 THEN
+complex(imagpart(x)/(2.0*real(sign(imagpart(x)))
+ *sqrt((ABSx-realpart(x))/2.0)),
+ real(sign(imagpart(x)))*sqrt((ABS x-realpart(x))/2.0))
+ELSE complex(sqrt((ABS x+realpart(x))/2.0),
+ imagpart(x)/(2.0*sqrt((ABS x+realpart(x))/2.0)))
+FI.
+
+END PROC sqrt;
+
+REAL OP ABS(COMPLEX CONST x):
+ sqrt(realpart(x)*realpart(x)+imagpart(x)*imagpart(x)).
+END OP ABS;
+
+END PACKET complex;
+
diff --git a/datatype/longint b/datatype/longint
new file mode 100644
index 0000000..e78bb52
--- /dev/null
+++ b/datatype/longint
@@ -0,0 +1,423 @@
+PACKET longint DEFINES LONGINT, (* Autoren: S.Baumann,A.Bentrup *)
+ :=, (* T.Sillke *)
+ <, (* Stand: 17.03.81 *)
+ >,
+ <=,
+ >=,
+ <>,
+ =,
+ -,
+ +,
+ *,
+ **,
+ ABS,
+ abs,
+ DECR,
+ DIV,
+ get,
+ INCR,
+ int,
+ (*last rest,*)
+ longint,
+ max,
+ max longint,
+ min,
+ MOD,
+ put,
+ random,
+ SIGN,
+ sign,
+ text,
+ zero:
+
+TYPE LONGINT = TEXT;
+
+LONGINT VAR result,aleft,aright;
+TEXT VAR ergebnis,x,y,z,h;
+INT VAR v byte,slr,sll;
+INT CONST snull :: code("0"), mtl :: 300 ;
+TEXT CONST negativ :: code(127),max digit :: code(99),null :: code(0),
+ overflow :: "LONGINT overflow",eins :: code(1);
+BOOL VAR vorl,vorr,vleft,vright;
+
+OP := (LONGINT VAR left, LONGINT CONST right) :
+ CONCR(left) := CONCR(right)
+END OP :=;
+
+BOOL OP < (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr > sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) < CONCR(right)
+ ELSE CONCR(left) > CONCR(right) FI
+ FI
+END OP < ;
+
+BOOL OP > (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr < sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) > CONCR(right)
+ ELSE CONCR(left) < CONCR(right) FI
+ FI
+END OP > ;
+
+BOOL OP <= (LONGINT CONST left,right) :
+ NOT (left > right)
+END OP <=;
+
+BOOL OP >= (LONGINT CONST left,right) :
+ NOT (left < right)
+END OP >=;
+
+BOOL OP <> (LONGINT CONST left,right) :
+ CONCR (left) <> CONCR (right)
+END OP <>;
+
+BOOL OP = (LONGINT CONST left,right) :
+ CONCR (left) = CONCR (right)
+END OP = ;
+
+LONGINT OP - (LONGINT CONST arg) :
+ SELECT code(CONCR(arg)SUB1) OF
+ CASE 0 : zero
+ CASE 127: LONGINT : (subtext(CONCR(arg),2))
+ OTHERWISE LONGINT : (negativ + CONCR(arg))
+ END SELECT
+END OP -;
+
+LONGINT OP + (LONGINT CONST arg) : arg END OP +;
+
+LONGINT OP - (LONGINT CONST left,right) :
+ IF CONCR(left ) = null THEN LEAVE - WITH -right
+ ELIF CONCR(right) = null THEN LEAVE - WITH left
+ ELIF sign(left) <> sign(right) THEN LEAVE - WITH left + (-right) FI;
+ betrag(left,right);
+ BOOL CONST betrag max :: aleft > aright;
+ IF betrag max
+ THEN result := LONGINT : (CONCR(aleft ) SUB CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) SUB CONCR(aleft )) FI;
+ kuerze fuehrende nullen(CONCR(result),null);
+ IF vleft XOR betrag max THEN -result ELSE result FI
+END OP -;
+
+LONGINT OP + (LONGINT CONST left,right) :
+ IF sign(left) <> sign(right) THEN LEAVE + WITH left - (-right) FI;
+ betrag(left,right);
+ IF aleft > aright
+ THEN result := LONGINT : (CONCR(aleft ) ADD CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) ADD CONCR(aleft )) FI;
+ IF vleft THEN result ELSE -result FI
+END OP +;
+
+LONGINT OP * (LONGINT CONST left,right) :
+ IF CONCR(left) = null OR CONCR(right) = null THEN LEAVE * WITH zero
+ ELIF length(left) + length(right) > mtl THEN errorstop (overflow) FI;
+ betrag(left,right);
+ IF aleft < aright
+ THEN result := LONGINT : (CONCR(aright) MUL CONCR(aleft ))
+ ELSE result := LONGINT : (CONCR(aleft ) MUL CONCR(aright)) FI;
+ IF length(CONCR(result)) = mtl THEN errorstop(overflow) FI;
+ IF vleft XOR vright THEN -result ELSE result FI
+END OP *;
+
+LONGINT OP ** (LONGINT CONST arg,exp) :
+ IF exp > longint(max int) THEN errorstop (overflow) FI;
+ arg ** int(exp)
+END OP **;
+
+LONGINT OP ** (LONGINT CONST arg,INT CONST exp) :
+ IF exp < 0 THEN errorstop ("LONGINT OP ** : negativ exp")
+ ELIF CONCR(arg)=null AND exp=0 THEN errorstop(text(0 ** 0)) FI;
+ IF exp = 0 THEN one
+ ELIF exp = 1 THEN arg
+ ELIF sign(arg) = -1 AND exp MOD 2 <> 0
+ THEN -LONGINT:(CONCR(abs(arg))EXPexp)
+ ELSE LONGINT:(CONCR(abs(arg))EXPexp) FI
+END OP **;
+
+LONGINT OP ABS (LONGINT CONST arg) : abs(arg) END OP ABS;
+
+LONGINT PROC abs (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN LONGINT:(subtext(CONCR(a),2)) ELSE a FI
+END PROC abs;
+
+OP DECR (LONGINT VAR result,LONGINT CONST ab) :
+ result := result - ab;
+END OP DECR;
+
+LONGINT OP DIV (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN error stop("LONGINT OP DIV by zero") FI;
+ betrag(left,right); h := CONCR(aright);
+ y := null + CONCR(aleft ); vorl := vleft;
+ z := null + CONCR(aright); vorr := vright;
+ IF aleft < aright THEN y:=CONCR(aleft); LEAVE DIV WITH zero FI;
+ INT VAR try,i,cr1 :: code(z SUB 2),cr2,cr3,zw;
+ BOOL VAR sh :: length(z) <> 2;
+ IF sh THEN cr3:=code(zSUB3); cr2:=10*cr1+cr3DIV10; cr3:=100*cr1+cr3 FI;
+ CONCR(result) := "";
+ FOR i FROM 0 UPTO length(y)-length(z) REP
+ laufe eine abschaetzung durch;
+ CONCR (result) CAT code(try)
+ PER; kuerze fuehrende nullen(y,null);
+ IF(CONCR(result)SUB1)=nullTHEN CONCR(result):=subtext(CONCR(result),2)FI;
+ IF vleft XOR vright THEN -result ELSE result FI.
+
+ laufe eine abschaetzung durch :
+ zw := 100*code(y SUB i+1) + code(y SUB i+2);
+ IF zw < 3276 AND sh THEN IF zw < 327
+ THEN try := min((100*zw + code(ySUBi+3)) DIV cr3, 99)
+ ELSE try := min(( 10*zw + code(ySUBi+3)DIV10)DIV cr2, 99) FI
+ ELSE try := min( zw DIV cr1, 99) FI;
+ x := z MUL code(try);
+ WHILE x > subtext(y,i+1,i+length(x)) REP
+ try DECR 1; x := x SUB z PER;
+ replace(y,i + 1,subtext(y,i + 1,i + length(x)) SUB x)
+END OP DIV;
+
+PROC get (LONGINT VAR result) :
+ get (ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+PROC get (FILE VAR file,LONGINT VAR result) :
+ get(file,ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+OP INCR (LONGINT VAR result,LONGINT CONST dazu) :
+ result := result + dazu;
+END OP INCR;
+
+INT PROC int (LONGINT CONST longint) :
+ IF length(longint) > 3
+ THEN max int + 1
+ ELSE ergebnis := (3-length(longint))*null + CONCR(abs(longint));
+ (code(ergebnis SUB 1) * 10000 +
+ code(ergebnis SUB 2) * 100 +
+ code(ergebnis SUB 3)) * sign(longint)
+ FI
+END PROC int;
+
+LONGINT PROC longint (INT CONST int) :
+ CONCR(result) := code( abs(int) DIV 10000) +
+ code((abs(int) MOD 10000) DIV 100) +
+ code( abs(int) MOD 100);
+ kuerze fuehrende nullen (CONCR(result),null);
+ IF int < 1 THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC longint (TEXT CONST text) :
+ INT VAR i;
+ ergebnis := compress(text);
+ BOOL VAR minus :: (ergebnisSUB1) = "-";
+ IF (ergebnisSUB1)="+" OR minus THEN ergebnis:=subtext(ergebnis,2) FI;
+ kuerze fuehrende nullen(ergebnis,"0");
+ kuerze die unzulaessigen zeichen aus ergebnis;
+ schreibe ergebnis im hundertersystem in result;
+ result mit vorzeichen.
+
+ kuerze die unzulaessigen zeichen aus ergebnis :
+ ergebnis := subtext(ergebnis,1,letztes zulaessiges zeichen).
+ letztes zulaessiges zeichen :
+ FOR i FROM 1 UPTO length(ergebnis) REP
+ UNTIL pos("0123456789", ergebnis SUB i) = 0 PER;
+ i - 1.
+ schreibe ergebnis im hundertersystem in result :
+ sll := length(ergebnis);
+ IF sll MOD 2 <> 0 THEN ergebnis := "0"+ergebnis; sll INCR 1 FI;
+ i := 1; CONCR(result) := "";
+ REP schreibe ein zeichen im hundertersystem in result;
+ i INCR 2
+ UNTIL i >= sll PER.
+ schreibe ein zeichen im hundertersystem in result :
+ CONCR(result) CAT code((code(ergebnis SUB i ) - snull) * 10 +
+ code(ergebnis SUB i + 1) - snull).
+ result mit vorzeichen :
+ IF ergebnis="" THEN zero ELIF minus THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC max (LONGINT CONST left,right) :
+ IF left > right THEN left ELSE right FI
+END PROC max;
+
+LONGINT PROC max longint :
+ LONGINT : ((mtl - 1) * max digit)
+END PROC max longint;
+
+LONGINT PROC min (LONGINT CONST left,right) :
+ IF left < right THEN left ELSE right FI
+END PROC min;
+
+LONGINT OP MOD (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN errorstop("LONGINT OP MOD by zero") FI;
+ result := left DIV right; last rest
+END OP MOD;
+
+PROC put (LONGINT CONST longint) :
+ INT VAR i :: 1,zwei ziffern;
+ IF sign(longint) = -1 THEN out("-"); i:=2 FI;
+ out(text(code(CONCR(longint) SUB i)));
+ FOR i FROM i + 1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ out(code(zwei ziffern DIV 10 + snull));
+ out(code(zwei ziffern MOD 10 + snull));
+ PER;out(" ")
+END PROC put;
+
+PROC put (FILE VAR file,LONGINT CONST longint) :
+ put(file,text(longint));
+END PROC put;
+
+LONGINT PROC random (LONGINT CONST lower bound,upper bound) :
+ INT VAR i; x := CONCR(upper bound - lower bound - one); y := "";
+ FOR i FROM 1 UPTO length(x) REP y CAT code(random(0,99)) PER;
+ upper bound - (LONGINT : (y) MOD LONGINT : (x))
+END PROC random;
+
+INT OP SIGN (LONGINT CONST arg) : sign(arg) END OP SIGN;
+
+INT PROC sign (LONGINT CONST arg) :
+ SELECT code(CONCR(arg) SUB 1) OF
+ CASE 0 : 0
+ CASE 127 : -1
+ OTHERWISE 1
+ END SELECT
+END PROC sign;
+
+TEXT PROC text (LONGINT CONST longint) :
+ INT VAR i::1,zwei ziffern; ergebnis := "";
+ IF sign(longint) = -1 THEN ergebnis := "-"; i:=2 FI;
+ ergebnis CAT text (code (CONCR (longint) SUB i ) ) ;
+ FOR i FROM i+1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ ergebnis CAT code(zwei ziffern DIV 10 + snull);
+ ergebnis CAT code(zwei ziffern MOD 10 + snull)
+ PER; ergebnis
+END PROC text;
+
+TEXT PROC text (LONGINT CONST longint,INT CONST length) :
+ x := text(longint); sll := LENGTH x;
+ IF sll > length THEN length * "*" ELSE (length - sll)*" " + x FI
+END PROC text;
+
+LONGINT PROC last rest :
+ IF y=null THEN LEAVE last rest WITH zero FI;
+ IF vorl XOR vorr THEN y := h SUB y; kuerze fuehrende nullen(y,null);
+ vorl := TRUE FI;
+ IF NOTvorr THEN y:=negativ+y; vorr := TRUE FI; LONGINT:(y)
+END PROC last rest;
+
+LONGINT PROC zero : LONGINT : (null) END PROC zero;
+LONGINT PROC one : LONGINT : (""1"") END PROC one;
+
+
+(* ----------------------- INTERNE HILFSPROZEDUREN ----------------------- *)
+
+TEXT OP ADD (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der addition)
+ PER;
+ IF carrybit = 1 THEN addiere den uebertrag FI;
+ ergebnis.
+
+ das result der addition :
+ v byte := (code(left SUB i) + code(right SUB i - dif) + carrybit);
+ IF v byte > 99
+ THEN carrybit := 1; code(v byte - 100)
+ ELSE carrybit := 0; code(v byte)
+ FI.
+ addiere den uebertrag :
+ FOR i FROM i DOWNTO 1
+ WHILE (ergebnis SUB i) >= max digit REP
+ replace(ergebnis,i,null)
+ PER;
+ IF (ergebnis SUB 1) = null OR dif = 0
+ THEN pruefe auf longint overflow
+ ELSE replace(ergebnis,i,code(code(ergebnis SUB i) + 1))
+ FI.
+ pruefe auf longint overflow :
+ IF length(ergebnis) = mtl - 1 THEN errorstop(overflow) FI;
+ ergebnis := eins + ergebnis
+END OP ADD;
+
+PROC betrag (LONGINT CONST a, b) :
+ vleft := (CONCR(a)SUB1)<>negativ; vright := (CONCR(b)SUB1)<>negativ;
+ IF vleft THEN aleft :=a ELSE CONCR(aleft ):=subtext(CONCR(a),2) FI;
+ IF vright THEN aright:=b ELSE CONCR(aright):=subtext(CONCR(b),2) FI
+END PROC betrag;
+
+TEXT OP EXP (TEXT CONST arg,INT CONST exp) :
+ INT VAR zaehler :: exp;
+ x := arg; z := eins;
+ REP IF zaehler MOD 2 = 1 THEN z := z MUL x FI;
+ zaehler := zaehler DIV 2; x := x MUL x
+ UNTIL zaehler = 1 PER;
+ x MUL z
+END OP EXP;
+
+PROC kuerze fuehrende nullen ( TEXT VAR text,TEXT CONST snull) :
+ INT VAR i;
+ text := subtext(text,erste nicht snull).
+
+ erste nicht snull :
+ FOR i FROM 1 UPTO length (text) - 1 REP
+ UNTIL (text SUB i) <> snull PER;
+ i
+END PROC kuerze fuehrende nullen;
+
+INT PROC length (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN length(CONCR(a))-1 ELSE length(CONCR(a)) FI
+END PROC length;
+
+TEXT OP MUL (TEXT CONST left,right) :
+ INT VAR i,j,carrybit,v,w;
+ ergebnis := (length(left) + length(right) - 1) * null;
+ FOR i FROM length(ergebnis) DOWNTO length(left) REP
+ v := i - length(left); w := length(right) - length(ergebnis) + i;
+ carrybit := 0;
+ FOR j FROM length(left) DOWNTO 1 REP
+ replace(ergebnis,v + j,result der addition)
+ PER;
+ replace(ergebnis,v,code(code(ergebnis SUB v) + carrybit));
+ PER;
+ IF carrybit = 0 THEN ergebnis ELSE code(carrybit) + ergebnis FI.
+
+ result der addition :
+ v byte := code(right SUB w) * code(left SUB j) + carrybit +
+ code(ergebnis SUB v + j);
+ carrybit := v byte DIV 100;
+ code(v byte MOD 100)
+END OP MUL;
+
+TEXT OP SUB (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der subtraktion);
+ PER;
+ IF carrybit = 1 THEN subtrahiere den uebertrag FI;
+ ergebnis.
+
+ das result der subtraktion :
+ v byte := (code(left SUB i) - code(right SUB i - dif) - carrybit);
+ IF v byte < 0
+ THEN carrybit := 1;code(v byte + 100)
+ ELSE carrybit := 0;code(v byte)
+ FI.
+ subtrahiere den uebertrag :
+ FOR i FROM i DOWNTO 2
+ WHILE (ergebnis SUB i) = null REP
+ replace(ergebnis,i,max digit)
+ PER;
+ replace(ergebnis,i,code(code(ergebnis SUB i) - 1))
+END OP SUB;
+
+END PACKET longint;
+
diff --git a/datatype/matrix b/datatype/matrix
new file mode 100644
index 0000000..d9de9fb
--- /dev/null
+++ b/datatype/matrix
@@ -0,0 +1,482 @@
+PACKET matrix DEFINES MATRIX, matrix, idn, (* Stand : 16.06.86 wk *)
+ :=, sub, (* Autor : H.Indenbirken *)
+ row, column,
+ COLUMNS,
+ ROWS,
+ DET,
+ INV,
+ TRANSP,
+ transp,
+ replace row, replace column,
+ replace element,
+ get, put,
+ =, <>,
+ +, -, * :
+
+TYPE MATRIX = STRUCT (INT rows, columns, VECTOR elems);
+TYPE INITMATRIX = STRUCT (INT rows, columns, REAL value, BOOL idn);
+
+MATRIX VAR a :: idn (1);
+INT VAR i;
+
+(****************************************************************************
+PROC dump (MATRIX CONST m) :
+ put line (text (m.rows) + " Reihen, " + text (m.columns) + " Spalten.");
+ dump (m.elems) .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (MATRIX VAR l, MATRIX CONST r) :
+ CONCR (l) := CONCR (r);
+END OP :=;
+
+OP := (MATRIX VAR l, INITMATRIX CONST r) :
+ l.rows := r.rows;
+ l.columns := r.columns;
+ l.elems := vector (r.rows*r.columns, r.value);
+ IF r.idn
+ THEN idn FI .
+
+idn :
+ INT VAR i;
+ FOR i FROM 1 UPTO r.rows
+ REP replace (l.elems, calc pos (l.columns, i, i), 1.0) PER
+
+END OP :=;
+
+INITMATRIX PROC matrix (INT CONST rows, columns, REAL CONST value) :
+ IF rows <= 0
+ THEN errorstop ("PROC matrix : rows <= 0")
+ ELIF columns <= 0
+ THEN errorstop ("PROC matrix : columns <= 0") FI;
+
+ INITMATRIX : (rows, columns, value, FALSE)
+
+END PROC matrix;
+
+INITMATRIX PROC matrix (INT CONST rows, columns) :
+ matrix (rows, columns, 0.0)
+
+END PROC matrix;
+
+INITMATRIX PROC idn (INT CONST size) :
+ IF size <= 0
+ THEN errorstop ("MATRIX PROC idn : size <= 0") FI;
+
+ INITMATRIX : (size, size, 0.0, TRUE)
+
+END PROC idn;
+
+VECTOR PROC row (MATRIX CONST m, INT CONST i) :
+ VECTOR VAR v :: vector (m.columns);
+ INT VAR j, k :: 1, pos :: (i-1) * m.columns;
+ FOR j FROM pos+1 UPTO pos + m.columns
+ REP replace (v, k, m.elems SUB j);
+ k INCR 1
+ PER;
+ v
+
+END PROC row;
+
+VECTOR PROC column (MATRIX CONST m, INT CONST j) :
+ VECTOR VAR v :: vector (m.rows);
+ INT VAR i, k :: j;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (v, i, m.elems SUB k);
+ k INCR m.columns
+ PER;
+ v
+
+END PROC column;
+
+INT OP COLUMNS (MATRIX CONST m) :
+ m.columns
+
+END OP COLUMNS;
+
+INT OP ROWS (MATRIX CONST m) :
+ m.rows
+
+END OP ROWS;
+
+REAL PROC sub (MATRIX CONST a, INT CONST row, column) :
+ a.elems SUB calc pos (a.columns, row, column)
+
+END PROC sub;
+
+PROC replace row (MATRIX VAR m, INT CONST rowindex, VECTOR CONST rowvalue) :
+ test ("PROC replace row : ", "LENGTH rowvalue", "COLUMNS m",
+ LENGTH rowvalue, m.columns);
+ test ("PROC replace row : row ", rowindex, m.rows);
+
+ INT VAR i, pos :: (rowindex-1) * m.columns;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (m.elems, pos+i, rowvalue SUB i) PER
+
+END PROC replace row;
+
+PROC replace column (MATRIX VAR m, INT CONST columnindex,
+ VECTOR CONST columnvalue) :
+ test ("PROC replace column : ", "LENGTH columnvalue", "ROWS m",
+ LENGTH columnvalue, m.rows);
+ test ("PROC replace column : column ", columnindex, m.columns);
+
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (m.elems, calc pos (m.columns, i, columnindex),
+ columnvalue SUB i) PER
+
+END PROC replace column;
+
+PROC replace element (MATRIX VAR a, INT CONST row, column, REAL CONST x) :
+ test ("PROC replace element : row ", row, a.rows);
+ test ("PROC replace element : column ", column, a.columns);
+ replace (a.elems, calc pos (a.columns, row, column), x)
+
+END PROC replace element;
+
+BOOL OP = (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN FALSE
+ ELIF l.columns <> r.columns
+ THEN FALSE
+ ELSE l.elems = r.elems FI
+
+END OP =;
+
+BOOL OP <> (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN TRUE
+ ELIF l.columns <> r.columns
+ THEN TRUE
+ ELSE l.elems <> r.elems FI
+
+END OP <>;
+
+INT PROC calc pos (INT CONST columns, z, s) :
+ (z-1) * columns + s
+END PROC calc pos;
+
+MATRIX OP + (MATRIX CONST m) :
+ m
+
+END OP +;
+
+MATRIX OP + (MATRIX CONST l, r) :
+ test ("MATRIX OP + : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP + : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) + (r.elems SUB i))
+ PER;
+ a
+
+END OP +;
+
+MATRIX OP - (MATRIX CONST m) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, -a.elems SUB i)
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP - (MATRIX CONST l, r) :
+ test ("MATRIX OP - : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP - : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) - (r.elems SUB i))
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP * (REAL CONST x, MATRIX CONST m) :
+ m*x
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST m, REAL CONST x) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, x*m.elems SUB i) PER;
+ a
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, MATRIX CONST m) :
+ test ("VECTOR OP * : ", "LENGTH v", "ROWS m", LENGTH v, m.rows);
+ VECTOR VAR result :: vector (m.columns); (*wk*)
+ INT VAR i;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (result, i, v * column (m, i)) PER;
+ result .
+
+END OP *;
+
+VECTOR OP * (MATRIX CONST m, VECTOR CONST v) :
+ test ("VECTOR OP * : ", "COLUMNS m", "LENGTH v", COLUMNS m, LENGTH v);
+ VECTOR VAR result :: vector (m.rows); (*wk*)
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (result, i, row (m, i) * v) PER;
+ result .
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST l, r) :
+ test ("MATRIX OP * : ","COLUMNS l","ROWS r", l.columns, r.rows);
+
+ a.rows := l.rows;
+ a.columns := r.columns;
+ a.elems := vector (a.rows*a.columns)
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP VECTOR VAR rl :: row (l, i), cr :: column (r, j);
+ replace (a.elems, calc pos (a.columns, i, j), rl * cr)
+ PER
+ PER;
+ a .
+
+END OP *;
+
+PROC get (MATRIX VAR a, INT CONST rows, columns) :
+
+ a := matrix (rows,columns);
+ INT VAR i, j;
+ VECTOR VAR v;
+ FOR i FROM 1 UPTO rows
+ REP get (v, columns);
+ store row
+ PER .
+
+store row :
+ FOR j FROM 1 UPTO a.columns
+ REP replace (a.elems, calc pos (a.columns, i, j), v SUB j)
+ PER .
+
+END PROC get;
+
+PROC put (MATRIX CONST a, INT CONST length, fracs) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP put (text (sub (a, i, j), length, fracs)) PER;
+ line (2);
+ PER
+
+END PROC put;
+
+PROC put (MATRIX CONST a) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP TEXT CONST number :: " " + text (sub (a, i, j));
+ put (subtext (number, LENGTH number - 15))
+ PER;
+ line (2);
+ PER
+
+END PROC put;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, l text, r text, INT CONST left, right) :
+ IF left <> right
+ THEN error := proc;
+ error CAT l text;
+ error CAT " (";
+ error CAT text (left);
+ error CAT ") <> ";
+ error CAT r text;
+ error CAT " (";
+ error CAT text (right);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, INT CONST i, n) :
+ IF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i > n
+ THEN error := proc;
+ error CAT "subscript overflow (i=";
+ error CAT text (i);
+ error CAT ", max=";
+ IF n <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (n) FI;
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+
+MATRIX OP TRANSP (MATRIX CONST m) :
+ MATRIX VAR a :: m;
+ transp (a);
+ a
+
+END OP TRANSP;
+
+PROC transp (MATRIX VAR m) :
+ INT VAR k :: 1, n :: m.rows*m.columns;
+ a := m;
+ FOR i FROM 2 UPTO n
+ REP replace (m.elems, i, a.elems SUB position) PER;
+ a := idn (1);
+ i := m.rows;
+ m.rows := m.columns;
+ m.columns := i .
+
+position :
+ k INCR m.columns;
+ IF k > n
+ THEN k DECR (n-1) FI;
+ k .
+END PROC transp;
+
+MATRIX OP INV (MATRIX CONST m) :
+ a := m;
+ ROW 32 INT VAR pivots;
+ INT VAR i, j, k :: ROWS a, n :: COLUMNS a, pos;
+
+ IF n <> k
+ THEN errorstop ("MATRIX OP INV : no square matrix") FI;
+
+ initialisiere die pivotpositionen;
+
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ IF sub (a, pos, pos) = 0.0
+ THEN errorstop ("MATRIX OP INV : singular matrix") FI;
+ zeilentausch (a, j, pos);
+ merke dir die vertauschung;
+ transformiere die matrix
+ PER;
+
+ spaltentausch;
+ a .
+
+initialisiere die pivotpositionen :
+ FOR i FROM 1 UPTO n
+ REP pivots [i] := i PER .
+
+merke dir die vertauschung :
+ IF pos > j
+ THEN INT VAR hi :: pivots [j];
+ pivots [j] := pivots [pos];
+ pivots [pos] := hi
+ FI .
+
+transformiere die matrix :
+ REAL VAR h := 1.0/sub (a, j, j);
+
+ FOR k FROM 1 UPTO n
+ REP IF k <> j
+ THEN FOR i FROM 1 UPTO n
+ REP IF i <> j
+ THEN replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*sub (a, j, k)*h);
+ FI
+ PER;
+ FI
+ PER;
+
+ FOR k FROM 1 UPTO n
+ REP replace element (a, j, k, -h*sub (a, j, k));
+ replace element (a, k, j, h*sub (a, k, j))
+ PER;
+ replace element (a, j, j, h) .
+
+spaltentausch :
+ VECTOR VAR v :: vector (n);
+ FOR i FROM 1 UPTO n
+ REP FOR k FROM 1 UPTO n
+ REP replace (v, pivots [k], sub(a, i, k)) PER;
+ replace row (a, i, v)
+ PER .
+
+END OP INV;
+
+REAL OP DET (MATRIX CONST m) :
+ IF COLUMNS m <> ROWS m
+ THEN errorstop ("REAL OP DET : no square matrix") FI;
+
+ a := m;
+ INT VAR i, j, k, n :: COLUMNS m, pos;
+ REAL VAR merker := 1.0;
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ IF j<> pos
+ THEN zeilentausch (a, j, pos);
+ zeilen tausch merken
+ FI;
+ transformiere die matrix
+ PER;
+ produkt der pivotelemente .
+
+transformiere die matrix :
+ REAL VAR hp := sub(a,j,j);
+ IF hp = 0.0
+ THEN LEAVE DET WITH 0.0
+ ELSE REAL VAR h := 1.0/hp;
+ FI;
+ FOR i FROM j+1 UPTO n
+ REP FOR k FROM j+1 UPTO n
+ REP replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*h*sub (a, j, k))
+ PER
+ PER .
+
+produkt der pivotelemente :
+ REAL VAR produkt :: sub (a, 1, 1);
+ FOR j FROM 2 UPTO n
+ REP produkt := produkt * sub (a, j, j) PER;
+ a := idn (1);
+ produkt * merker.
+
+zeilen tausch merken:
+ merker := merker * (-1.0).
+
+END OP DET;
+
+PROC pivotsuche (MATRIX CONST a, INT CONST start pos, INT VAR pos) :
+ REAL VAR max :: abs (sub (a, start pos, start pos));
+ INT VAR i;
+ pos := start pos;
+
+ FOR i FROM start pos+1 UPTO COLUMNS a
+ REP IF abs (sub (a, i, start pos)) > max
+ THEN max := abs (sub (a, i, start pos));
+ pos := i
+ FI
+ PER .
+
+END PROC pivotsuche;
+
+PROC zeilentausch (MATRIX VAR a, INT CONST old pos, pos) :
+ VECTOR VAR v := row (a, pos);
+ replace row (a, pos, row (a, old pos));
+ replace row (a, old pos, v) .
+
+END PROC zeilentausch;
+
+END PACKET matrix;
+
diff --git a/datatype/vector b/datatype/vector
new file mode 100644
index 0000000..5c9e896
--- /dev/null
+++ b/datatype/vector
@@ -0,0 +1,213 @@
+PACKET vector DEFINES VECTOR, :=, vector, (* Autor : H.Indenbirken *)
+ SUB, LENGTH, length, norm, (* Stand : 21.10.83 *)
+ nilvector, replace, =, <>,
+ +, -, *, /,
+ get, put :
+
+
+TYPE VECTOR = STRUCT (INT lng, TEXT elem);
+TYPE INITVECTOR = STRUCT (INT lng, REAL value);
+
+INT VAR i;
+TEXT VAR t :: "12345678";
+VECTOR VAR v :: nilvector;
+
+(****************************************************************************
+PROC dump (VECTOR CONST v) :
+ put line (text (v.lng) + " Elemente :");
+ FOR i FROM 1 UPTO v.lng
+ REP put line (text (i) + ": " + text (element i)) PER .
+
+element i :
+ v.elem RSUB i .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (VECTOR VAR l, VECTOR CONST r) :
+ l.lng := r.lng;
+ l.elem := r.elem
+
+END OP :=;
+
+OP := (VECTOR VAR l, INITVECTOR CONST r) :
+ l.lng := r.lng;
+ replace (t, 1, r.value);
+ l.elem := r.lng * t
+
+END OP :=;
+
+INITVECTOR PROC nilvector :
+ vector (1, 0.0)
+
+END PROC nilvector;
+
+INITVECTOR PROC vector (INT CONST lng, REAL CONST value) :
+ IF lng <= 0
+ THEN errorstop ("PROC vector : lng <= 0") FI;
+ INITVECTOR : (lng, value)
+
+END PROC vector;
+
+INITVECTOR PROC vector (INT CONST lng) :
+ vector (lng, 0.0)
+
+END PROC vector;
+
+REAL OP SUB (VECTOR CONST v, INT CONST i) :
+ test ("REAL OP SUB : ", v, i);
+ v.elem RSUB i
+
+END OP SUB;
+
+INT OP LENGTH (VECTOR CONST v) :
+ v.lng
+
+END OP LENGTH;
+
+INT PROC length (VECTOR CONST v) :
+ v.lng
+
+END PROC length;
+
+REAL PROC norm (VECTOR CONST v) :
+ REAL VAR result :: 0.0;
+ FOR i FROM 1 UPTO v.lng
+ REP result INCR ((v.elem RSUB i)**2) PER;
+ sqrt (result) .
+
+END PROC norm;
+
+PROC replace (VECTOR VAR v, INT CONST i, REAL CONST r) :
+ test ("PROC replace : ", v, i);
+ replace (v.elem, i, r)
+
+END PROC replace;
+
+BOOL OP = (VECTOR CONST l, r) :
+ l.elem = r.elem
+END OP =;
+
+BOOL OP <> (VECTOR CONST l, r) :
+ l.elem <> r.elem
+END OP <>;
+
+VECTOR OP + (VECTOR CONST v) :
+ v
+END OP +;
+
+VECTOR OP + (VECTOR CONST l, r) :
+ test ("VECTOR OP + : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) + (r.elem RSUB i)) PER;
+ v
+
+END OP +;
+
+VECTOR OP - (VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, - (a.elem RSUB i)) PER;
+ v
+
+END OP -;
+
+VECTOR OP - (VECTOR CONST l, r) :
+ test ("VECTOR OP - : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) - (r.elem RSUB i)) PER;
+ v
+END OP -;
+
+REAL OP * (VECTOR CONST l, r) :
+ test ("REAL OP * : ", l, r);
+ REAL VAR x :: 0.0;
+ FOR i FROM 1 UPTO l.lng
+ REP x INCR ((l.elem RSUB i) * (r.elem RSUB i)) PER;
+ x
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, REAL CONST r) :
+ r*v
+
+END OP *;
+
+VECTOR OP * (REAL CONST r, VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, r*(a.elem RSUB i)) PER;
+ v
+
+END OP *;
+
+VECTOR OP / (VECTOR CONST a, REAL CONST r) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (a.elem RSUB i)/r) PER;
+ v
+
+END OP /;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, VECTOR CONST v, INT CONST i) :
+ IF i > v.lng
+ THEN error := proc;
+ error CAT "subscript overflow (LENGTH v=";
+ error CAT text (v.lng);
+ error CAT ", i=";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (i = ";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, VECTOR CONST a, b) :
+ IF a.lng <> b.lng
+ THEN error := proc;
+ error CAT "LENGTH a (";
+ IF a.lng <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (a.lng) FI;
+ error CAT ") <> LENGTH b (";
+ error CAT text (b.lng);
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+PROC get (VECTOR VAR v, INT CONST lng) :
+ v.lng := lng;
+ v.elem := lng * "12345678";
+ REAL VAR x;
+ FOR i FROM 1 UPTO lng
+ REP get (x);
+ replace (v.elem, i, x)
+ PER .
+
+END PROC get;
+
+PROC put (VECTOR CONST v, INT CONST length, fracs) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i, length, fracs)) PER
+
+END PROC put;
+
+PROC put (VECTOR CONST v) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i)) PER
+
+END PROC put;
+
+END PACKET vector;
+
diff --git a/dialog/ls-DIALOG 1 b/dialog/ls-DIALOG 1
new file mode 100644
index 0000000..974bcda
--- /dev/null
+++ b/dialog/ls-DIALOG 1
@@ -0,0 +1,60 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG 1 **
+ ** **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+PACKET ls dialog 1 DEFINES
+ ecke oben links, balken oben,{} ecke oben rechts, balken rechts,{} ecke unten links, balken links,{} ecke unten rechts, balken unten,{} waagerecht, senkrecht, kreuz,{} cursor on, cursor off,{} clear buffer, clear buffer and count,{} center, invers, page, page up,{} out frame, out menuframe, erase frame,{} std graphic char, ft20 graphic char,{} ibm graphic char, AREA, :=, fill,{} areax, areay, areaxsize, areaysize,{} cursor, get cursor, out, out invers,{}
+ out with beam, out invers with beam,{} erase, erase invers, erase with beam:{}TYPE AREA = STRUCT (INT x, y, xsize, ysize);{}LET blank = " ",{} mark ein = ""15"",{} mark aus = ""14"",{} cleol = ""5"";{}TEXT CONST fehlermeldung :: "Unzulässige Größen!";{}TEXT VAR eol := "+", eor := "+", eul := "+", eur := "+",{} bo := "+", br := "+", bl := "+", bu := "+",{} waa := "-", sen := "|", kr := "+",{} cursor sichtbar := "", cursor unsichtbar := "";{}
+TEXT PROC ecke oben links : eol END PROC ecke oben links ;{}TEXT PROC ecke oben rechts: eor END PROC ecke oben rechts ;{}TEXT PROC ecke unten links : eul END PROC ecke unten links ;{}TEXT PROC ecke unten rechts: eur END PROC ecke unten rechts ;{}TEXT PROC balken oben : bo END PROC balken oben ;{}TEXT PROC balken links : bl END PROC balken links ;{}TEXT PROC balken rechts : br END PROC balken rechts ;{}TEXT PROC balken unten : bu END PROC balken unten ;{}
+TEXT PROC waagerecht : waa END PROC waagerecht ;{}TEXT PROC senkrecht : sen END PROC senkrecht ;{}TEXT PROC kreuz : kr END PROC kreuz ;{}PROC ecke oben links (TEXT CONST t): eol := t END PROC ecke oben links ;{}PROC ecke oben rechts (TEXT CONST t): eor := t END PROC ecke oben rechts ;{}PROC ecke unten links (TEXT CONST t): eul := t END PROC ecke unten links ;{}PROC ecke unten rechts (TEXT CONST t): eur := t END PROC ecke unten rechts ;{}
+PROC balken oben (TEXT CONST t): bo := t END PROC balken oben ;{}PROC balken links (TEXT CONST t): bl := t END PROC balken links ;{}PROC balken rechts (TEXT CONST t): br := t END PROC balken rechts ;{}PROC balken unten (TEXT CONST t): bu := t END PROC balken unten ;{}PROC waagerecht (TEXT CONST t): waa := t END PROC waagerecht ;{}PROC senkrecht (TEXT CONST t): sen := t END PROC senkrecht ;{}PROC kreuz (TEXT CONST t): kr := t END PROC kreuz ;{}
+PROC std graphic char:{} ecke oben links ("+"); ecke oben rechts ("+");{} ecke unten links ("+"); ecke unten rechts ("+");{} balken oben ("+"); balken rechts ("+");{} balken links ("+"); balken unten ("+");{} waagerecht ("-"); senkrecht ("|");{} kreuz ("+");{} cursor sichtbar := ""; cursor unsichtbar := ""{}END PROC std graphic char;{}PROC ft20 graphic char:{} ecke oben links (""27"R�"27"S"); ecke oben rechts (""27"RD"27"S");{} ecke unten links (""27"RH"27"S"); ecke unten rechts (""27"RL"27"S");{}
+ balken oben (""27"RP"27"S"); balken rechts (""27"RT"27"S");{} balken links (""27"RX"27"S"); balken unten (""27"R\"27"S");{} waagerecht (""27"R`"27"S"); senkrecht (""27"Rd"27"S");{} kreuz (""27"Rh"27"S");{} cursor sichtbar := ""27"-1" ; cursor unsichtbar := ""27"-0" ;{} ft20 statuszeilen aus{}END PROC ft20 graphic char;{}PROC ft 20 statuszeilen aus: out (""27".A") END PROC ft 20 statuszeilen aus;{}PROC ft 20 statuszeilen an : out (""27".�") END PROC ft 20 statuszeilen an ;{}
+PROC ibm graphic char:{} ecke oben links (""201""); ecke oben rechts (""187"");{} ecke unten links (""200""); ecke unten rechts (""188"");{} balken oben (""203""); balken rechts (""185"");{} balken links (""204""); balken unten (""202"");{} waagerecht (""205""); senkrecht (""186"");{} kreuz (""206"");{} cursor sichtbar := "" ; cursor unsichtbar := ""{}END PROC ibm graphic char;{}PROC cursor on : out (cursor sichtbar ) END PROC cursor on ;{}
+PROC cursor off : out (cursor unsichtbar) END PROC cursor off;{}PROC cursor on (TEXT CONST t): cursor sichtbar := t END PROC cursor on ;{}PROC cursor off (TEXT CONST t): cursor unsichtbar := t END PROC cursor off;{}PROC clear buffer:{} REP UNTIL incharety = "" PER{}END PROC clear buffer;{}INT PROC clear buffer and count (TEXT CONST zeichen):{} INT VAR zaehler :: 0;{} TEXT VAR zeichenkette :: "", ch;{} IF zeichen = "" THEN clear buffer; LEAVE clear buffer and count WITH 0 FI;{}
+ ermittle die zeichenkette;{} untersuche auf vorhandene zeichen;{} zaehler.{} ermittle die zeichenkette:{} REP{} ch := incharety (1);{} zeichenkette CAT ch{} UNTIL ch = "" PER.{} untersuche auf vorhandene zeichen:{} INT VAR i;{} FOR i FROM 1 UPTO length (zeichenkette) REP{} IF pos (subtext (zeichenkette, i), zeichen) = 1{} THEN zaehler INCR 1{} FI{} PER.{}END PROC clear buffer and count;{}TEXT PROC center (INT CONST xsize, TEXT CONST t):{} TEXT VAR zeile :: compress (t);{}
+ zeile := ((xsize - length (zeile)) DIV 2) * blank + zeile;{} zeile CAT (xsize - length (zeile)) * blank;{} zeile{}END PROC center;{}TEXT PROC center (TEXT CONST t):{} center (79, t){}END PROC center;{}TEXT PROC invers (TEXT CONST t):{} TEXT VAR neu :: mark ein; neu CAT t; neu CAT " "; neu CAT mark aus;{} neu{}END PROC invers;{}PROC page (INT CONST x, y, xsize, ysize):{} INT VAR zeiger;{} IF x + xsize = 80{} THEN in einem streich{} ELSE putze vorsichtig{} FI;{} cursor (x, y).{}
+ in einem streich:{} FOR zeiger FROM y UPTO y + ysize - 1 REP{} cursor (x, zeiger); out (cleol){} PER.{} putze vorsichtig:{} FOR zeiger FROM y UPTO y + ysize - 1 REP{} cursor (x, zeiger); xsize TIMESOUT blank{} PER.{}END PROC page;{}PROC page (AREA CONST a):{} page (a.x, a.y, a.xsize, a.ysize){}END PROC page;{}PROC page up (INT CONST x, y, xsize, ysize):{} INT VAR zeiger;{} IF x + xsize = 80{} THEN in einem streich{} ELSE putze vorsichtig{}
+ FI.{} in einem streich:{} FOR zeiger FROM y + ysize - 1 DOWNTO y REP{} cursor (x, zeiger); out (cleol){} PER.{} putze vorsichtig:{} FOR zeiger FROM y + ysize - 1 DOWNTO y REP{} cursor (x, zeiger); xsize TIMESOUT blank{} PER.{}END PROC page up;{}PROC page up (AREA CONST a):{} page up (a.x, a.y, a.xsize, a.ysize){}END PROC page up;{}PROC out frame (INT CONST x, y, xsize, ysize):{} INT VAR zeiger;{} IF x < 1 COR y < 1 COR xsize < 8 COR ysize < 3 COR{} x + xsize > 80 COR y + ysize > 25{}
+ THEN LEAVE out frame{} FI;{} male oben;{} male seiten;{} male unten.{} male oben:{} cursor (x, y);{} out (ecke oben links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke oben rechts).{} male seiten:{} FOR zeiger FROM 1 UPTO ysize - 2 REP{} cursor (x, y + zeiger); out (senkrecht);{} cursor (x + xsize - 1, y + zeiger); out (senkrecht){} PER.{} male unten:{} cursor (x, y + ysize - 1);{} out (ecke unten links);{} (xsize - 2) TIMESOUT waagerecht;{}
+ out (ecke unten rechts){}END PROC out frame;{}PROC out frame (AREA CONST a):{} IF a.x - 1 < 1 OR a.y - 1 < 1{} OR a.xsize + 2 > 79 OR a.ysize + 2 > 24{} OR a.x + a.xsize + 1 > 80{} OR a.y + a.ysize + 1 > 25{} THEN LEAVE out frame{} FI;{} out frame (a.x - 1, a.y - 1, a.xsize + 2, a.ysize + 2){}END PROC out frame;{}PROC out menuframe (INT CONST x, y, xsize, ysize):{} INT VAR i;{} untersuche angaben;{} schreibe rahmen.{} untersuche angaben:{} IF x < 0 COR y < 0 COR x + xsize > 81 COR y + ysize > 26{}
+ THEN LEAVE out menuframe{} FI.{} schreibe rahmen:{} IF x = 0 COR y = 0 COR xsize = 81 COR ysize = 26{} THEN zeichne reduzierten rahmen{} ELSE zeichne vollen rahmen{} FI.{} zeichne reduzierten rahmen:{} zeichne oberlinie;{} zeichne unterlinie.{} zeichne oberlinie:{} cursor (1, 2);{} 79 TIMESOUT waagerecht.{} zeichne unterlinie:{} cursor (1, 23);{} 79 TIMESOUT waagerecht.{} zeichne vollen rahmen:{} schreibe kopf; schreibe rumpf; schreibe fuss;{}
+ schreibe kopfleiste; schreibe fussleiste.{} schreibe kopf:{} cursor (x, y);{} out (ecke oben links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke oben rechts).{} schreibe rumpf:{} FOR i FROM y + 1 UPTO y + ysize - 2 REP{} cursor (x, i); out (senkrecht);{} cursor (x + xsize - 1, i); out (senkrecht){} PER.{} schreibe fuss:{} cursor (x, y + ysize - 1);{} out (ecke unten links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke unten rechts).{}
+ schreibe kopfleiste:{} cursor (x, y + 2 ); schreibe balkenlinie.{} schreibe fussleiste:{} cursor (x, y + ysize - 3); schreibe balkenlinie.{} schreibe balkenlinie:{} out (balken links); (xsize - 2) TIMESOUT waagerecht; out (balken rechts).{}END PROC out menuframe;{}PROC out menuframe (AREA CONST a):{} out menuframe (a.x - 1, a.y - 1, a.xsize + 2, a.ysize + 2){}END PROC out menuframe;{}PROC erase frame (INT CONST x, y, xsize, ysize):{} INT VAR zeiger;{} loesche oben; loesche seiten; loesche unten.{}
+ loesche oben:{} cursor (x, y); xsize TIMESOUT blank.{} loesche seiten:{} FOR zeiger FROM 1 UPTO ysize - 2 REP{} cursor (x, y + zeiger); out (blank);{} cursor (x + xsize - 1, y + zeiger); out (blank){} PER.{} loesche unten:{} cursor (x, y + ysize - 1); xsize TIMESOUT blank.{}END PROC erase frame;{}OP := (AREA VAR ziel, AREA CONST quelle):{} CONCR (ziel) := CONCR (quelle){}END OP :=;{}PROC fill (AREA VAR ziel, INT CONST a, b, c, d):{} IF a < 1 COR b < 1 COR a > 79 COR b > 24 COR c < 8 COR d < 3{}
+ COR c > 79 COR d > 24 COR a + c > 80 COR b + d > 25{} THEN errorstop (fehlermeldung){} FI;{} ziel.x := a; ziel.y := b; ziel.xsize := c; ziel.ysize := d{}END PROC fill;{}INT PROC areax (AREA CONST a): a.x END PROC areax;{}INT PROC areay (AREA CONST a): a.y END PROC areay;{}INT PROC areaxsize (AREA CONST a): a.xsize END PROC areaxsize;{}INT PROC areaysize (AREA CONST a): a.ysize END PROC areaysize;{}PROC out (TEXT CONST t, INT CONST breite):{} outtext (t, 1, breite){}
+END PROC out;{}PROC erase (INT CONST breite):{} breite TIMESOUT blank{}END PROC erase;{}PROC cursor (AREA CONST a, INT CONST spa, zei):{} cursor (a.x + spa - 1, a.y + zei - 1){}END PROC cursor;{}PROC get cursor (AREA CONST a, INT VAR spalte, zeile):{} INT VAR x, y;{} get cursor (x, y);{} spalte := x - a.x + 1; zeile := y - a.y + 1{}END PROC get cursor;{}PROC out (AREA CONST a, INT CONST spa, zei, TEXT CONST t):{} ueberpruefe cursorangaben; positioniere cursor;{} IF text ist zu lang{} THEN verkuerzte ausgabe{}
+ ELSE out (t){} FI.{} ueberpruefe cursorangaben:{} IF spa > xsize COR zei > a.ysize COR spa < 1 COR zei < 1{} THEN LEAVE out{} FI.{} positioniere cursor:{} cursor (a.x + spa - 1, a.y + zei - 1).{} text ist zu lang:{} length (t) > a.xsize - spa + 1.{} verkuerzte ausgabe:{} outsubtext (t, 1, a.xsize - spa + 1){}END PROC out;{}PROC out (AREA CONST a, INT CONST spa, zei, TEXT CONST t, INT CONST laenge):{} ueberpruefe cursorangaben; positioniere cursor;{} IF laenge ist zu gross{}
+ THEN verkuerzte ausgabe{} ELSE outtext (t, 1, laenge){} FI.{} ueberpruefe cursorangaben:{} IF spa > a.xsize COR zei > a.ysize COR spa < 1 COR zei < 1{} THEN LEAVE out{} FI.{} positioniere cursor:{} cursor (a.x + spa - 1, a.y + zei - 1).{} laenge ist zu gross:{} laenge > a.xsize - spa + 1.{} verkuerzte ausgabe:{} outtext (t, 1, a.xsize - spa + 1){}END PROC out;{}PROC erase (AREA CONST a, INT CONST spa, zei, INT CONST laenge):{} ueberpruefe cursorangaben; positioniere cursor;{}
+ IF laenge ist zu gross{} THEN verkuerzte ausgabe{} ELSE erase (laenge){} FI.{} ueberpruefe cursorangaben:{} IF spa > a.xsize COR zei > a.ysize COR spa < 1 COR zei < 1{} THEN LEAVE erase{} FI.{} positioniere cursor:{} cursor (a.x + spa - 1, a.y + zei - 1).{} laenge ist zu gross:{} laenge > a.xsize - spa + 1.{} verkuerzte ausgabe:{} erase (a.xsize - spa + 1){}END PROC erase;{}PROC out invers (AREA CONST a, INT CONST spa, zei, TEXT CONST t):{} ueberpruefe cursorangaben; positioniere cursor;{}
+ IF text ist zu lang{} THEN verkuerzte ausgabe{} ELSE out (mark ein); out (t); out (blank); out (mark aus){} FI.{} ueberpruefe cursorangaben:{} IF spa > (xsize - 4) COR zei > ysize COR spa < 2 COR zei < 1{} THEN LEAVE out invers{} FI.{} positioniere cursor:{} cursor (a.x + spa - 2, a.y + zei - 1).{} text ist zu lang:{} length (t) > a.xsize - spa - 1.{} verkuerzte ausgabe:{} out (mark ein); outsubtext (t, 1, a.xsize - spa - 1);{} out (blank); out (mark aus){}END PROC out invers;{}
+PROC out invers (AREA CONST a, INT CONST spa, zei,{} TEXT CONST t, INT CONST laenge):{} ueberpruefe cursorangaben; positioniere cursor;{} IF laenge ist zu gross{} THEN verkuerzte ausgabe{} ELSE out (mark ein); outtext (t, 1, laenge); out (blank); out (mark aus){} FI.{} ueberpruefe cursorangaben:{} IF spa > (a.xsize - 4) COR zei > a.ysize COR spa < 2 COR zei < 1{} THEN LEAVE out invers{} FI.{} positioniere cursor:{} cursor (a.x + spa - 2, a.y + zei - 1).{}
+ laenge ist zu gross:{} laenge > a.xsize - spa - 1.{} verkuerzte ausgabe:{} out (mark ein); outsubtext (t, 1, a.xsize - spa - 1);{} out (blank); out (mark aus){}END PROC out invers;{}PROC erase invers (AREA CONST a, INT CONST spa, zei, INT CONST laenge):{} ueberpruefe cursorangaben; positioniere cursor;{} IF laenge ist zu gross{} THEN verkuerzte ausgabe{} ELSE erase (laenge + 3){} FI.{} ueberpruefe cursorangaben:{} IF spa > (a.xsize - 4) COR zei > a.ysize COR spa < 2 COR zei < 1{}
+ THEN LEAVE erase invers{} FI.{} positioniere cursor:{} cursor (a.x + spa - 2, a.y + zei - 1).{} laenge ist zu gross:{} laenge > a.xsize - spa - 1.{} verkuerzte ausgabe:{} erase ( a.xsize - spa + 2).{}END PROC erase invers;{}PROC out with beam (AREA CONST a, INT CONST spa, zei, TEXT CONST t):{} ueberpruefe cursorangaben; positioniere cursor;{} IF text ist zu lang{} THEN verkuerzte ausgabe{} ELSE out (senkrecht); out (blank); out (blank);{} out (t);{} out (blank); out (blank); out (senkrecht){}
+ FI.{} ueberpruefe cursorangaben:{} IF spa > a.xsize - 7 COR zei > a.ysize COR spa < 4 COR zei < 1{} THEN LEAVE out with beam{} FI.{} positioniere cursor:{} cursor (a.x + spa - 4, a.y + zei - 1).{} text ist zu lang:{} length (t) > a.xsize - spa - 2.{} verkuerzte ausgabe:{} out (senkrecht); out (blank); out (blank);{} outsubtext (t, 1, a.xsize - spa - 2);{} out (blank); out (blank); out (senkrecht){}END PROC out with beam;{}PROC out with beam (AREA CONST a, INT CONST spa, zei,{}
+ TEXT CONST t, INT CONST laenge):{} ueberpruefe cursorangaben; positioniere cursor;{} IF laenge ist zu gross{} THEN verkuerzte ausgabe{} ELSE out (senkrecht); out (blank); out (blank);{} outtext (t, 1,laenge);{} out (blank); out (blank); out (senkrecht){} FI.{} ueberpruefe cursorangaben:{} IF spa > a.xsize - 7 COR zei > a.ysize COR spa < 4 COR zei < 1{} THEN LEAVE out with beam{} FI.{} positioniere cursor:{} cursor (a.x + spa - 4, a.y + zei - 1).{}
+ laenge ist zu gross:{} laenge > a.xsize - spa - 2.{} verkuerzte ausgabe:{} out (senkrecht); out (blank); out (blank);{} outsubtext (t, 1, a.xsize - spa - 2);{} out (blank); out (blank); out (senkrecht){}END PROC out with beam;{}PROC erase with beam (AREA CONST a, INT CONST spa, zei, INT CONST laenge):{} ueberpruefe cursorangaben; positioniere cursor;{} IF laenge ist zu gross{} THEN verkuerzte ausgabe{} ELSE erase (laenge + 6){} FI.{} ueberpruefe cursorangaben:{} IF spa > a.xsize - 7 COR zei > a.ysize COR spa < 4 COR zei < 1{}
+ THEN LEAVE erase with beam{} FI.{} positioniere cursor:{} cursor (a.x + spa - 4, a.y + zei - 1).{} laenge ist zu gross:{} laenge > a.xsize - spa - 2.{} verkuerzte ausgabe:{} erase (a.xsize - spa + 4).{}END PROC erase with beam;{}PROC out invers with beam (AREA CONST a, INT CONST spa, zei, TEXT CONST t):{} ueberpruefe cursorangaben; positioniere cursor;{} IF text ist zu lang{} THEN verkuerzte ausgabe{} ELSE out (senkrecht); out (blank); out (mark ein);{} out (t);{}
+ out (blank); out (mark aus); out (senkrecht){} FI.{} ueberpruefe cursorangaben:{} IF spa > a.xsize - 7 COR zei > a.ysize COR spa < 4 COR zei < 1{} THEN LEAVE out invers with beam{} FI.{} positioniere cursor:{} cursor (a.x + spa - 4, a.y + zei - 1).{} text ist zu lang:{} length (t) > a.xsize - spa - 2.{} verkuerzte ausgabe:{} out (senkrecht); out (blank); out (mark ein);{} outsubtext (t, 1, a.xsize - spa - 2);{} out (blank); out (mark aus); out (senkrecht){}
+END PROC out invers with beam;{}PROC out invers with beam (AREA CONST a, INT CONST spa, zei,{} TEXT CONST t, INT CONST laenge):{} ueberpruefe cursorangaben; positioniere cursor;{} IF laenge ist zu gross{} THEN verkuerzte ausgabe{} ELSE out (senkrecht); out (blank); out (mark ein);{} outtext (t, 1, laenge);{} out (blank); out (mark aus); out (senkrecht){} FI.{} ueberpruefe cursorangaben:{} IF spa > a.xsize - 7 COR zei > a.ysize COR spa < 4 COR zei < 1{}
+ THEN LEAVE out invers with beam{} FI.{} positioniere cursor:{} cursor (a.x + spa - 4, a.y + zei - 1).{} laenge ist zu gross:{} laenge > a.xsize - spa - 2.{} verkuerzte ausgabe:{} out (senkrecht); out (blank); out (mark ein);{} outsubtext (t, 1, a.xsize - spa - 2);{} out (blank); out (mark aus); out (senkrecht){}END PROC out invers with beam;{}END PACKET ls dialog 1;{}
+
diff --git a/dialog/ls-DIALOG 2 b/dialog/ls-DIALOG 2
new file mode 100644
index 0000000..1750162
--- /dev/null
+++ b/dialog/ls-DIALOG 2
@@ -0,0 +1,77 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG 2 **
+ ** **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+PACKET ls dialog 2 DEFINES
+ some,{} one,{} infix namen,{} ohne praefix,{} not empty:{}LET maxentries = 200;{}LET zeichenstring = ""1""27""3""10""13""12"xo?",{} oben unten return rubout kreuz kringel = ""3""10""13""12"xo",{} q eins neun h = "q19h";{}LET zurueck = ""8"",{} piep = ""7"";{}LET hop = 1,{} esc = 2,{} oben = 3,{} unten = 4,{} return = 5,{} rubout = 6,{}
+ kreuz = 7,{} kringel = 8,{} frage = 9;{}LET punkt = ".",{} gleich = "=",{} blank = " ";{}INT VAR x,{} y,{} xsize,{} ysize,{} maxeintraege,{} anzahl,{} erste auswahlzeile,{} virtueller cursor,{} reeller cursor;{}TEXT VAR kennzeile 1,{} kennzeile 2,{} registrierkette :: "";{}BOOL VAR abbruch,{} auswahlende;{}BOUND ROW max entries TEXT VAR eintrag;{}ROW 2 TEXT CONST fehlermeldung :: ROW 2 TEXT : ({}
+ "Unzulässige Cursorwerte bei der Auswahl",{} "Fenster für Auswahl zu klein (x < 56 / y < 15)");{}ROW 24 TEXT CONST hinweis :: ROW 24 TEXT : ({} " Bitte warten... Ich sortiere und räume auf!",{} " Info: <?> Fertig: <ESC><q> Abbrechen: <ESC><h>",{} " Zum Weitermachen bitte irgendeine Taste tippen!",{} "Weitere Dateien!",{} "INFORMATIONEN: Auswahl mehrerer Dateien",{} "INFORMATIONEN: Auswahl einer Datei",{} " "15"Positionierungen: "14"",{} " hoch : zum vorausgehenden Namen",{}
+ " runter : zum folgenden Namen",{} " HOP hoch : auf den ersten Namen der Seite", (***********){} " HOP runter : auf den letzten Namen der Seite", (* bitte *){} " ESC 1 : auf den ersten Namen der Liste", (* diese *){} " ESC 9 : auf den letzten Namen der Liste", (* Länge *){} " "15"Auswahl treffen: "14"", (* nicht *){} " RETURN / x : diesen Namen ankreuzen ", (* über- *){}
+ " RUBOUT / o : Kreuz vor dem Namen loeschen", (* schrei-*){} " HOP RETURN / HOP x : alle folgende Namen ankreuzen", (* ten! *){} " HOP RUBOUT / HOP o : alle folgende Kreuze loeschen", (***********){} " "15"Auswahl verlassen: "14"",{} " ESC q : Auswahl verlassen",{} " ESC h : Auswahl abbrechen",{} " Auswahl m e h r e r e r Dateien durch Ankreuzen",{} " Auswahl e i n e r Datei durch Ankreuzen",{} " Bitte warten... Ich breche die Auswahl ab!"{}
+ );{}THESAURUS PROC auswahl (THESAURUS CONST t,{} BOOL CONST mehrere moeglich,{} TEXT CONST t1, t2):{} werte initialisieren;{} namen besorgen;{} bildschirm aufbauen;{} auswaehlen lassen;{} abgang vorbereiten.{} werte initialisieren:{} THESAURUS VAR ausgabe :: empty thesaurus;{} DATASPACE VAR ds := nilspace;{} eintrag := ds;{} kennzeile 1 := t1;{} kennzeile 2 := t2;{} abbruch := FALSE;{}
+ erste auswahlzeile := y + 7;{} anzahl := 0;{} maxeintraege := ysize - 11;{} virtueller cursor := 1;{} reeller cursor := 1.{} namen besorgen:{} fische die namen aus dem thesaurus;{} IF kein eintrag vorhanden{} THEN LEAVE auswahl WITH ausgabe{} FI.{} bildschirm aufbauen:{} schreibe kopfzeile;{} gib hinweis aus (kennzeile 1, kennzeile 2);{} gib erklaerungszeile aus (mehrere moeglich);{} baue bildschirm auf (1);{} footnote (x, y, xsize, ysize, hinweis [2]);{}
+ schreibe fusszeile;{} reellen cursor setzen .{} schreibe kopfzeile:{} cursor (x, y);{} out(ecke oben links);{} (xsize - 2) TIMESOUT waagerecht;{} out(ecke oben rechts).{} schreibe fusszeile:{} cursor (x, y + ysize - 1);{} out (ecke unten links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke unten rechts).{} auswaehlen lassen:{} kreuze an (mehrere moeglich).{} abgang vorbereiten:{} IF abbruch{} THEN change footnote (x, y, xsize, ysize, hinweis [24]){}
+ ELSE change footnote (x, y, xsize, ysize, hinweis [ 1]){} FI;{} cursor (x + 1, y + ysize - 1);{} ausgabe erzeugen;{} forget (ds);{} ausgabe.{} fische die namen aus dem thesaurus:{} INT VAR zeiger;{} FOR zeiger FROM 1 UPTO highest entry (t) REP{} IF name (t, zeiger) <> ""{} THEN anzahl INCR 1;{} eintrag [anzahl] := name (t, zeiger){} FI{} PER.{} kein eintrag vorhanden:{} anzahl = 0.{} ausgabe erzeugen:{} TEXT VAR nummer;{} WHILE registrierkette <> "" REP{}
+ nummer := subtext (registrierkette, 1, 3);{} registrierkette := subtext (registrierkette, 5);{} insert (ausgabe, eintrag [ int (nummer)]){} PER.{}END PROC auswahl;{}PROC reellen cursor setzen:{} cursor (x + 1, erste auswahlzeile + reeller cursor - 1);{} out (marke (virtueller cursor, TRUE) + (8 * zurueck)){}END PROC reellen cursor setzen;{}PROC baue bildschirm auf (INT CONST anfang):{} gib kopfzeile aus;{} gib namenstabelle aus;{} gib fusszeile aus;{} loesche ggf restbereich.{}
+ gib kopfzeile aus:{} cursor (x, erste auswahlzeile - 1); out (senkrecht);{} IF reeller cursor = virtueller cursor{} THEN (xsize - 2) TIMESOUT punkt{} ELSE (xsize - length (hinweis [4]) - 5) TIMESOUT punkt;{} out (invers (hinweis [4])){} FI;{} out (senkrecht);{} line.{} gib namenstabelle aus:{} INT VAR zeiger, zaehler :: -1;{} FOR zeiger FROM anfang UPTO grenze REP{} zaehler INCR 1;{} cursor (x, erste auswahlzeile + zaehler);{} out (senkrecht); out (marke (zeiger, FALSE));{}
+ outtext (subtext (eintrag [zeiger], 1, xsize - 10), 1, xsize - 10);{} out (senkrecht);{} PER.{} gib fusszeile aus:{} cursor (x, erste auswahlzeile + zaehler + 1);{} out (senkrecht);{} IF NOT ((virtueller cursor + maxeintraege - reeller cursor) < anzahl){} THEN (xsize - 2) TIMESOUT punkt{} ELSE (xsize - length (hinweis [4]) - 5) TIMESOUT punkt;{} out (invers (hinweis [4])){} FI;{} out (senkrecht).{} loesche ggf restbereich:{} IF zaehler + 1 < maxeintraege{}
+ THEN loesche bildschirmrest{} FI.{} loesche bildschirmrest:{} FOR zeiger FROM restanfang UPTO restende REP{} cursor (x, zeiger); out (senkrecht);{} (xsize - 2) TIMESOUT blank;{} out (senkrecht){} PER.{} restanfang:{} erste auswahlzeile + zaehler + 2.{} restende:{} erste auswahlzeile + maxeintraege.{} grenze:{} min (anzahl, anfang + max eintraege - 1).{}END PROC baue bildschirm auf;{}TEXT PROC marke (INT CONST zeiger, BOOL CONST mit cursor):{}
+ INT VAR platz := nr (zeiger);{} IF platz = 0{} THEN leer{} ELSE mit zahl{} FI.{} mit zahl:{} IF mit cursor{} THEN "==>" + (3 - length (text (platz))) * blank + text (platz) + "x "{} ELSE " " + (3 - length (text (platz))) * blank + text (platz) + "x "{} FI.{} leer:{} IF mit cursor{} THEN "==> o "{} ELSE " o "{} FI.{}END PROC marke;{}INT PROC nr (INT CONST zeiger):{} IF pos (registrierkette, textstring (zeiger)) = 0{} THEN 0{} ELSE (pos (registrierkette, textstring (zeiger)) DIV 4) + 1{}
+ FI{}END PROC nr;{}TEXT PROC textstring (INT CONST nr):{} text (nr, 3) + "!"{}END PROC textstring;{}PROC info (BOOL CONST mehrere):{} notiere hinweisueberschrift;{} notiere positionierhinweise;{} IF noch platz vorhanden{} THEN notiere auswahlmoeglichkeiten auf alter seite{} ELSE wechsle auf naechste seite;{} notiere hinweisueberschrift;{} notiere auswahlmoeglichtkeiten auf neuer seite{} FI;{} stelle alten bildschirmzustand wieder her.{} notiere hinweisueberschrift:{}
+ cursor (x + 1, y + 1);{} IF mehrere{} THEN out (center(xsize - 2, invers (hinweis [5]))){} ELSE out (center(xsize - 2, invers (hinweis [6]))){} FI;{} cursor (x + 1, y + 2); out ("", xsize - 2).{} notiere positionierhinweise:{} cursor (x + 1, y + 3); out (hinweis [ 7], xsize - 2);{} cursor (x + 1, y + 4); out (hinweis [ 8], xsize - 2);{} cursor (x + 1, y + 5); out (hinweis [ 9], xsize - 2);{} cursor (x + 1, y + 6); out (hinweis [10], xsize - 2);{} cursor (x + 1, y + 7); out (hinweis [11], xsize - 2);{}
+ cursor (x + 1, y + 8); out (hinweis [12], xsize - 2);{} cursor (x + 1, y + 9); out (hinweis [13], xsize - 2).{} notiere auswahlmoeglichkeiten auf alter seite:{} cursor (x + 1, y + 10); out ("", xsize - 2);{} cursor (x + 1, y + 11); out (hinweis [14], xsize - 2);{} cursor (x + 1, y + 12); out (hinweis [15], xsize - 2);{} IF mehrere{} THEN gib alle auswahlmoeglichkeiten auf der alten seite an{} ELSE gib eine auswahlmoeglichkeit auf der alten seite an{} FI;{}
+ notiere verlassmoeglichkeiten auf der alten seite;{} loesche die restlichen zeilen;{} change footnote (x, y, xsize, ysize, hinweis [3]);{} cursor in ruhestellung;{} clear buffer.{} gib alle auswahlmoeglichkeiten auf der alten seite an:{} cursor (x + 1, y + 13); out (hinweis [16], xsize - 2);{} cursor (x + 1, y + 14); out (hinweis [17], xsize - 2);{} cursor (x + 1, y + 15); out (hinweis [18], xsize - 2).{} gib eine auswahlmoeglichkeit auf der alten seite an:{} cursor (x + 1, y + 13); out ("", xsize - 2);{}
+ cursor (x + 1, y + 14); out ("", xsize - 2);{} cursor (x + 1, y + 15); out ("", xsize - 2).{} notiere verlassmoeglichkeiten auf der alten seite:{} cursor (x + 1, y + 16); out ("", xsize - 2);{} cursor (x + 1, y + 17); out (hinweis [19], xsize - 2);{} cursor (x + 1, y + 18); out (hinweis [20], xsize - 2);{} cursor (x + 1, y + 19); out (hinweis [21], xsize - 2).{} loesche die restlichen zeilen:{} IF ysize = 24{} THEN cursor (x + 1, y + 20); out ("", xsize - 2){} FI.{}
+ wechsle auf naechste seite:{} loesche seitenrest;{} change footnote (x, y, xsize, ysize, hinweis [3]);{} cursor in ruhestellung;{} clear buffer;{} pause.{} loesche seitenrest:{} INT VAR zaehler;{} FOR zaehler FROM 10 UPTO ysize - 4 REP{} cursor (x + 1, y + zaehler); out ("", xsize - 2){} PER.{} notiere auswahlmoeglichtkeiten auf neuer seite:{} cursor (x + 1, y + 3); out (hinweis [14], xsize - 2);{} cursor (x + 1, y + 4); out (hinweis [15], xsize - 2);{} IF mehrere{}
+ THEN gib alle auswahlmoeglichkeiten auf der neuen seite an{} ELSE gib eine auswahlmoeglichkeit auf der neuen seite an{} FI;{} notiere verlassmoeglichkeiten auf der neuen seite.{} gib alle auswahlmoeglichkeiten auf der neuen seite an:{} cursor (x + 1, y + 5); out (hinweis [16], xsize - 2);{} cursor (x + 1, y + 6); out (hinweis [17], xsize - 2);{} cursor (x + 1, y + 7); out (hinweis [18], xsize - 2).{} gib eine auswahlmoeglichkeit auf der neuen seite an:{} cursor (x + 1, y + 5); out ("", xsize - 2);{}
+ cursor (x + 1, y + 6); out ("", xsize - 2);{} cursor (x + 1, y + 7); out ("", xsize - 2).{} notiere verlassmoeglichkeiten auf der neuen seite:{} cursor (x + 1, y + 8); out ("", xsize - 2);{} cursor (x + 1, y + 9); out (hinweis [19], xsize - 2);{} cursor (x + 1, y + 10); out (hinweis [20], xsize - 2);{} cursor (x + 1, y + 11); out (hinweis [21], xsize - 2);{} cursor in ruhestellung.{} cursor in ruhestellung:{} cursor (x + 1, y + ysize - 2).{} stelle alten bildschirmzustand wieder her:{}
+ clear buffer;{} pause;{} gib hinweis aus (kennzeile 1, kennzeile 2);{} gib erklaerungszeile aus (mehrere);{} virtueller cursor := 1;{} reeller cursor := 1;{} baue bildschirm auf (1);{} change footnote (x, y, xsize, ysize, hinweis [2]);{} reellen cursor setzen.{} noch platz vorhanden:{} (ysize - 4) > 18.{}END PROC info;{}PROC kreuze an (BOOL CONST mehrere):{} auswahlende := FALSE;{} REP{} zeichen lesen; zeichen interpretieren{} UNTIL auswahlende PER.{} zeichen lesen:{}
+ TEXT VAR zeichen;{} getchar (zeichen).{} zeichen interpretieren:{} SELECT pos (zeichenstring, zeichen) OF{} CASE hop : hop kommando verarbeiten (mehrere){} CASE esc : esc kommando verarbeiten{} CASE oben : nach oben{} CASE unten : nach unten{} CASE kreuz : ankreuzen; evtl aufhoeren{} CASE return : ankreuzen weiter; evtl aufhoeren{} CASE rubout : auskreuzen weiter{} CASE kringel : auskreuzen{} CASE frage : info (mehrere){}
+ OTHERWISE out (piep){} END SELECT.{} evtl aufhoeren:{} IF NOT mehrere{} THEN LEAVE kreuze an{} FI.{}END PROC kreuze an;{}PROC hop kommando verarbeiten (BOOL CONST mehrere):{} zweites zeichen lesen;{} zeichen interpretieren.{} zweites zeichen lesen:{} TEXT VAR zweites zeichen;{} getchar(zweites zeichen).{} zeichen interpretieren:{} SELECT pos (oben unten return rubout kreuz kringel, zweites zeichen) OF{} CASE 1 : hop nach oben{} CASE 2 : hop nach unten{}
+ CASE 3, 5 : IF mehrere THEN alle darunter ankreuzen FI{} CASE 4, 6 : IF mehrere THEN alle darunter loeschen FI{} OTHERWISE out (piep){} END SELECT.{} alle darunter ankreuzen:{} INT VAR i;{} FOR i FROM virtueller cursor UPTO anzahl REP{} IF nr (i) = 0{} THEN ankreuzen{} FI{} PER;{} bild aktualisieren ;{} reellen cursor setzen .{} ankreuzen:{} registrierkette CAT textstring (i).{} alle darunter loeschen:{} INT VAR j, position;{} FOR j FROM virtueller cursor UPTO anzahl REP{}
+ position := nr (j);{} IF position > 0{} THEN rausschmeissen;{} FI{} PER;{} bild aktualisieren;{} reellen cursor setzen.{} rausschmeissen:{} registrierkette := subtext (registrierkette, 1, (4 * position) - 4) +{} subtext (registrierkette, (4 * position) + 1).{} hop nach oben:{} IF ganz oben{} THEN out (piep){} ELIF oben auf der seite{} THEN raufblaettern{} ELSE top of page{} FI.{} ganz oben:{} virtueller cursor = 1.{}
+ oben auf der seite:{} reeller cursor = 1.{} raufblaettern:{} virtueller cursor DECR max eintraege;{} virtueller cursor := max (virtueller cursor, 1);{} baue bildschirm auf (virtueller cursor);{} reellen cursor setzen.{} top of page:{} loesche marke;{} virtueller cursor DECR (reeller cursor - 1);{} reeller cursor := 1;{} reellen cursor setzen.{} hop nach unten:{} IF ganz unten{} THEN out (piep){} ELIF unten auf der seite{} THEN runterblaettern{}
+ ELSE bottom of page{} FI.{} ganz unten:{} virtueller cursor = anzahl.{} unten auf der seite:{} reeller cursor > max eintraege - 1.{} runterblaettern:{} INT VAR alter virtueller cursor :: virtueller cursor;{} virtueller cursor INCR max eintraege;{} virtueller cursor := min (virtueller cursor, anzahl);{} reeller cursor := virtueller cursor - alter virtueller cursor;{} baue bildschirm auf (alter virtueller cursor + 1);{} reellen cursor setzen.{} bottom of page:{}
+ loesche marke;{} alter virtueller cursor := virtueller cursor;{} virtueller cursor INCR (max eintraege - reeller cursor);{} virtueller cursor := min (anzahl, virtueller cursor);{} reeller cursor INCR (virtueller cursor - alter virtueller cursor);{} reellen cursor setzen.{}END PROC hop kommando verarbeiten;{}PROC esc kommando verarbeiten:{} TEXT VAR zweites zeichen;{} getchar (zweites zeichen);{} SELECT pos (q eins neun h, zweites zeichen) OF{} CASE 1 : auswahlende := TRUE{}
+ CASE 2 : zeige anfang{} CASE 3 : zeige ende{} CASE 4 : abbruch := TRUE;{} auswahlende := TRUE;{} registrierkette := ""{} OTHERWISE out (piep){} END SELECT.{} zeige anfang:{} IF virtueller cursor = 1{} THEN out (piep){} ELIF virtueller cursor = reeller cursor{} THEN loesche marke;{} virtueller cursor := 1;{} reeller cursor := 1;{} reellen cursor setzen{} ELSE virtueller cursor := 1;{}
+ reeller cursor := 1;{} baue bildschirm auf (1);{} reellen cursor setzen{} FI.{} zeige ende:{} IF virtueller cursor = anzahl{} THEN out (piep){} ELIF ende auf bildschirm{} THEN loesche marke;{} reeller cursor INCR (anzahl - virtueller cursor);{} virtueller cursor := anzahl;{} reellen cursor setzen{} ELSE virtueller cursor := anzahl;{} reeller cursor := max eintraege;{}
+ baue bildschirm auf (anzahl - (max eintraege - 1));{} reellen cursor setzen{} FI.{} ende auf bildschirm:{} (reeller cursor + anzahl - virtueller cursor) < max eintraege + 1.{}END PROC esc kommando verarbeiten;{}PROC ankreuzen:{} INT VAR platz :: nr (virtueller cursor);{} IF platz <> 0{} THEN out (piep);{} LEAVE ankreuzen{} FI;{} registrierkette CAT textstring (virtueller cursor);{} reellen cursor setzen{}END PROC ankreuzen;{}PROC ankreuzen weiter:{}
+ INT VAR platz :: nr (virtueller cursor);{} IF platz <> 0{} THEN out (piep);{} LEAVE ankreuzen weiter{} FI;{} registrierkette CAT textstring (virtueller cursor);{} IF virtueller cursor < anzahl{} THEN nach unten{} FI;{} IF virtueller cursor = anzahl{} THEN reellen cursor setzen{} FI{}END PROC ankreuzen weiter;{}PROC auskreuzen weiter:{} INT VAR position :: nr (virtueller cursor);{} IF position = 0{} THEN out (piep);{} LEAVE auskreuzen weiter{} FI;{} rausschmeissen;{}
+ IF virtueller cursor < anzahl{} THEN nach unten{} ELSE loesche marke{} FI;{} bild aktualisieren;{} reellen cursor setzen.{} rausschmeissen:{} registrierkette := subtext (registrierkette, 1, 4 * position - 4) +{} subtext (registrierkette, 4 * position + 1).{}END PROC auskreuzen weiter;{}PROC auskreuzen:{} INT VAR position :: nr (virtueller cursor);{} IF position = 0{} THEN out (piep);{} LEAVE auskreuzen{} FI;{} rausschmeissen;{} loesche marke;{}
+ bild aktualisieren;{} reellen cursor setzen.{} rausschmeissen:{} registrierkette := subtext (registrierkette, 1, 4 * position - 4) +{} subtext (registrierkette, 4 * position + 1).{}END PROC auskreuzen;{}PROC bild aktualisieren:{} INT VAR ob, un, i, zaehler :: -1;{} ob := virtueller cursor - reeller cursor + 1;{} un := min (ob + max eintraege - 1, anzahl);{} FOR i FROM ob UPTO un REP{} zaehler INCR 1;{} cursor (x + 1, erste auswahlzeile + zaehler);{} out (marke (i,FALSE)) PER{}
+END PROC bild aktualisieren;{}PROC nach oben:{} IF noch nicht oben (*virtuell*){} THEN gehe nach oben{} ELSE out (piep){} FI.{} noch nicht oben:{} virtueller cursor > 1.{} gehe nach oben:{} IF reeller cursor = 1 THEN scroll down ELSE cursor up FI.{} scroll down:{} virtueller cursor DECR 1;{} baue bildschirm auf (virtueller cursor);{} reellen cursor setzen.{} cursor up:{} loesche marke;{} virtueller cursor DECR 1;{} reeller cursor DECR 1;{} reellen cursor setzen{}
+END PROC nach oben;{}PROC nach unten:{} IF noch nicht unten (*virtuell*){} THEN gehe nach unten{} ELSE out (piep){} FI.{} noch nicht unten:{} virtueller cursor < anzahl.{} gehe nach unten:{} IF reeller cursor > max eintraege - 1 THEN scroll up ELSE cursor down FI.{} scroll up:{} virtueller cursor INCR 1;{} baue bildschirm auf (virtueller cursor - (max eintraege - 1));{} reellen cursor setzen.{} cursor down:{} loesche marke;{} virtueller cursor INCR 1;{} reeller cursor INCR 1;{}
+ reellen cursor setzen{}END PROC nach unten;{}PROC loesche marke:{} out (marke (virtueller cursor, FALSE)){}END PROC loesche marke;{}PROC footnote (INT CONST x, y, xsize, ysize, TEXT CONST text):{} cursor (x, y + ysize - 3);{} out (balken links); (xsize - 2) TIMESOUT waagerecht; out (balken rechts);{} change footnote (x, y, xsize, ysize, text){}END PROC footnote;{}PROC change footnote (INT CONST x, y, xsize, ysize, TEXT CONST text):{} cursor (x, y + ysize - 2);{} out (senkrecht); outtext (text, 1, xsize - 2); out (senkrecht){}
+END PROC change footnote;{}PROC gib hinweis aus (TEXT CONST t1, t2):{} cursor (x, y + 1); out (senkrecht);{} out (center (xsize - 2, invers (t1)));{} out (senkrecht);{} cursor (x, y + 2); out (senkrecht);{} out ("", xsize - 2);{} out (senkrecht);{} cursor (x, y + 3); out (senkrecht);{} out (center (xsize - 2, t2));{} out (senkrecht){}END PROC gib hinweis aus;{}PROC gib erklaerungszeile aus (BOOL CONST mehrere):{}
+ cursor (x, y + 4); out (senkrecht);{} out ((xsize - 2) * gleich);{} out (senkrecht);{} cursor (x, y + 5); out (senkrecht);{} IF mehrere{} THEN out (erklaerungszeile mehrere){} ELSE out (erklaerungszeile eine){} FI;{} out (senkrecht).{} erklaerungszeile mehrere:{} invers (text 1 + (rest1 * blank)).{} erklaerungszeile eine:{} invers (text 2 + (rest2 * blank)).{}
+ text1:{} hinweis [22].{} text2:{} hinweis [23].{} rest1: (***************************){} xsize - length (text1) - 5. (* durch 'invers' wird ein *){} (* Blank angehängt und zu- *){} rest2: (* sätzlich noch durch *){} xsize - length (text2) - 5. (* 'relativcenter' - außer-*){}END PROC gib erklaerungszeile aus; (* dem nimmt die Markierung*){} (* selbst eine Position ein*){}
+ (***************************){}THESAURUS PROC infix namen (THESAURUS CONST t, TEXT CONST infix):{} THESAURUS VAR tt :: empty thesaurus;{} INT VAR i;{} FOR i FROM 1 UPTO highest entry (t) REP{} TEXT VAR eintrag :: name (t,i);{} IF eintrag enthaelt infix{} THEN insert (tt, eintrag){} FI{} PER;{} tt.{} eintrag enthaelt infix:{} pos (eintrag, infix) <> 0{}END PROC infix namen;{}THESAURUS PROC infix namen (THESAURUS CONST t, INT CONST dateityp):{}
+ THESAURUS VAR tt :: empty thesaurus;{} INT VAR i;{} FOR i FROM 1 UPTO highest entry (t) REP{} TEXT VAR eintrag :: name (t,i);{} IF eintrag enthaelt infix{} THEN insert (tt, eintrag){} FI{} PER;{} tt.{} eintrag enthaelt infix:{} type (old (eintrag)) = dateityp.{}END PROC infix namen;{}THESAURUS PROC infix namen (THESAURUS CONST t,{} TEXT CONST infix 1, INT CONST dateityp):{} THESAURUS VAR tt :: empty thesaurus;{} INT VAR i;{} FOR i FROM 1 UPTO highest entry (t) REP{}
+ TEXT VAR eintrag :: name (t,i);{} IF eintrag enthaelt infix{} THEN insert (tt, eintrag){} FI{} PER;{} tt.{} eintrag enthaelt infix:{} (pos (eintrag, infix 1) <> 0) AND (type (old (eintrag)) = dateityp).{}END PROC infix namen;{}THESAURUS PROC infix namen (THESAURUS CONST t,{} TEXT CONST infix 1, infix 2):{} THESAURUS VAR tt :: empty thesaurus;{} INT VAR i;{} FOR i FROM 1 UPTO highest entry (t) REP{} TEXT VAR eintrag :: name (t,i);{} IF eintrag enthaelt infix{}
+ THEN insert (tt, eintrag){} FI{} PER;{} tt.{} eintrag enthaelt infix:{} (pos (eintrag, infix 1) <> 0) OR (pos (eintrag, infix 2) <> 0){}END PROC infix namen;{}THESAURUS PROC infix namen (TEXT CONST infix):{} infix namen (ALL myself, infix){}END PROC infix namen;{}THESAURUS PROC infix namen (TEXT CONST infix 1, infix 2):{} infix namen (ALL myself, infix 1, infix 2){}END PROC infix namen;{}THESAURUS PROC ohne praefix (THESAURUS CONST thesaurus, TEXT CONST praefix):{} THESAURUS VAR t :: empty thesaurus;{}
+ INT VAR zaehler;{} FOR zaehler FROM 1 UPTO highest entry (thesaurus) REP{} IF name (thesaurus, zaehler) <> ""{} AND pos (name (thesaurus, zaehler), praefix) = 1{} THEN insert (t, subtext (name (thesaurus, zaehler),{} length (praefix) + 1)){} FI;{} PER;{} t{}END PROC ohne praefix;{}BOOL PROC not empty (THESAURUS CONST t):{} INT VAR i;{} FOR i FROM 1 UPTO highest entry (t) REP{} IF name (t, i) <> ""{} THEN LEAVE not empty WITH TRUE{}
+ FI{} PER;{} FALSE{}END PROC not empty;{}PROC untersuche bildschirmmasszahlen (TEXT CONST t1, t2):{} IF unzulaessige cursorwerte{} THEN errorstop (fehlermeldung [1]){} ELIF fenster ist zu klein{} THEN errorstop (fehlermeldung [2]){} FI.{} unzulaessige cursorwerte:{} (x + xsize) > 80 COR (y + ysize) > 25 COR x < 1 COR y < 1{} COR xsize > 79 COR ysize > 24.{} fenster ist zu klein:{} (xsize) < 56 COR (ysize) < 15{} COR length (t1) > (xsize - 5) COR length (t2) > (xsize - 5).{}
+END PROC untersuche bildschirmmasszahlen;{}TEXT PROC ggf gekuerzter text (TEXT CONST text):{} IF length (text) > (xsize - 5){} THEN subtext (text, 1, xsize - 7) + ".."{} ELSE text{} FI{}END PROC ggf gekuerzter text;{}THESAURUS PROC some (INT CONST spa, zei, breite, hoehe,{} THESAURUS CONST t,{} TEXT CONST t1, t2):{} TEXT VAR text 1, text 2;{} x := spa;{} y := zei;{} xsize := breite;{} ysize := hoehe;{} text 1 := ggf gekuerzter text (t1);{}
+ text 2 := ggf gekuerzter text (t2);{} untersuche bildschirmmasszahlen (text 1, text 2);{} auswahl (t, TRUE, text 1, text 2){}END PROC some;{}THESAURUS PROC some (INT CONST spa, zei,{} THESAURUS CONST t,{} TEXT CONST t1, t2):{} some (spa, zei, 79 - spa + 1, 24 - zei + 1, t, t1, t2){}END PROC some;{}THESAURUS PROC some (THESAURUS CONST t,{} TEXT CONST t1, t2):{} some (1, 1, 79, 24, t, t1, t2){}END PROC some;{}TEXT PROC one (INT CONST spa, zei, breite, hoehe,{}
+ THESAURUS CONST t,{} TEXT CONST t1, t2):{} TEXT VAR text 1, text 2;{} x := spa;{} y := zei;{} xsize := breite;{} ysize := hoehe;{} text 1 := ggf gekuerzter text (t1);{} text 2 := ggf gekuerzter text (t2);{} untersuche bildschirmmasszahlen (text 1, text 2);{} name (auswahl (t, FALSE, text 1, text 2), 1){}END PROC one;{}TEXT PROC one (INT CONST spa, zei,{} THESAURUS CONST t,{} TEXT CONST t1, t2):{} one (spa, zei, 79 - spa + 1, 24 - zei + 1, t, t1, t2){}
+END PROC one;{}TEXT PROC one (THESAURUS CONST t, TEXT CONST t1, t2):{} one (1, 1, 79, 24, t, t1, t2){}END PROC one;{}END PACKET ls dialog 2;{}
+
diff --git a/dialog/ls-DIALOG 3 b/dialog/ls-DIALOG 3
new file mode 100644
index 0000000..dce6507
--- /dev/null
+++ b/dialog/ls-DIALOG 3
@@ -0,0 +1,48 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG 3 **
+ ** **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+PACKET ls dialog 3 DEFINES{} WINDOW, :=, window,{} show, page, erase,{} line, remaining lines,{} cursor, get cursor,{} out frame, out menuframe,{} out, put, putline, editget,{} get, getline, yes, no,{} edit, center, stop,{} area, areax, areay,{} areaxsize, areaysize:{}LET piep = ""7"",{} cr = ""13"";{}LET janeinkette = "jJyYnN",{} blank = " ",{} niltext = "";{}TYPE WINDOW = STRUCT (AREA fenster,{}
+ INT cspalte, czeile, belegbare zeilen,{} BOOL fensterende erreicht);{}ROW 3 TEXT CONST aussage :: ROW 3 TEXT : ({} " 'Window' ungültig!",{} " (j/n) ?",{} " Zum Weitermachen bitte irgendeine Taste tippen!"{} );{}TEXT VAR number word, exit char;{}OP := (WINDOW VAR links, WINDOW CONST rechts):{} CONCR (links) := CONCR (rechts){}END OP :=;{}WINDOW PROC window (INT CONST x, y, xsize, ysize):{} WINDOW VAR w;{} fill (w.fenster, x, y, xsize, ysize);{} IF fenster ungueltig (w){}
+ THEN errorstop (aussage [1]){} FI;{} initialize (w);{} w{}END PROC window;{}PROC initialize (WINDOW VAR w):{} w.czeile := 1;{} w.cspalte := 1;{} w.fensterende erreicht := FALSE;{} w.belegbare zeilen := areaysize (w.fenster){}END PROC initialize;{}BOOL PROC fenster ungueltig (WINDOW CONST w):{} IF areax (w.fenster) < 1 COR areax (w.fenster) > 79{} COR areay (w.fenster) < 1 COR areay (w.fenster) > 24{} COR areaxsize (w.fenster) < 6 COR areaysize (w.fenster) < 3{}
+ COR areax (w.fenster) + areaxsize (w.fenster) > 80{} COR areay (w.fenster) + areaysize (w.fenster) > 25{} THEN TRUE{} ELSE FALSE{} FI.{}END PROC fenster ungueltig;{}PROC show (WINDOW VAR w):{} zeige rahmen;{} fenster putzen.{} zeige rahmen:{} out frame (w.fenster).{} fenster putzen:{} page (w).{}END PROC show;{}PROC page (WINDOW VAR w):{} initialize (w);{} page (w, FALSE){}END PROC page;{}PROC page (WINDOW CONST w, BOOL CONST mit rahmen ):{} IF areax (w) = 1 AND areay (w) = 1 AND{}
+ areaxsize (w) = 79 AND areaysize (w) = 24{} THEN page;{} ELSE loesche bereich{} FI.{} loesche bereich:{} IF mit rahmen{} THEN page (areax (w) - 1, areay (w) - 1,{} areaxsize (w) + 2, areaysize (w) + 2){} ELSE page (area (w)){} FI{}END PROC page;{}PROC erase (WINDOW VAR w):{} page (w, TRUE){}END PROC erase;{}PROC line (WINDOW VAR w):{} w.cspalte := 1;{} IF w.czeile < w.belegbare zeilen{} THEN w.czeile INCR 1;{} ELSE w.czeile := 1;{}
+ w.fensterende erreicht := TRUE{} FI;{} cursor (w, w.cspalte, w.czeile){}END PROC line;{}PROC line (WINDOW VAR w, INT CONST anzahl):{} INT VAR i; FOR i FROM 1 UPTO anzahl REP line (w) PER{}END PROC line;{}INT PROC remaining lines (WINDOW CONST w):{} INT VAR spalte, zeile;{} get cursor (w, spalte, zeile);{} IF spalte = 0 OR zeile = 0{} THEN 0{} ELSE w.belegbare zeilen - w.czeile{} FI{}END PROC remaining lines;{}PROC cursor (WINDOW VAR w, INT CONST spalte, zeile):{} IF spalte < 1 OR zeile < 1 OR spalte > areaxsize (w) OR zeile > areaysize (w){}
+ THEN page (w);{} ELSE w.cspalte := spalte; w.czeile := zeile;{} FI;{} cursor (w.fenster, w.cspalte, w.czeile){}END PROC cursor;{}PROC get cursor (WINDOW CONST w, INT VAR spalte, zeile):{} IF (w.cspalte < 1) OR (w.cspalte > areaxsize (w.fenster)){} OR{} (w.czeile < 1) OR (w.czeile > areaysize (w.fenster)){} THEN spalte := 0; zeile := 0{} ELSE spalte := w.cspalte; zeile := w.czeile{} FI{}END PROC get cursor;{}PROC out (WINDOW VAR w, TEXT CONST text):{}
+ INT VAR restlaenge;{} IF (w.cspalte >= 1) AND (w.cspalte <= areaxsize (w.fenster)){} AND{} (w.czeile >= 1) AND (w.czeile <= w.belegbare zeilen){} THEN putze ggf fenster;{} cursor (w.fenster, w.cspalte, w.czeile);{} outtext (text, 1, textende);{} setze fenstercursor neu;{} setze ausgabe ggf in naechster zeile fort{} FI.{} putze ggf fenster:{} IF w.fensterende erreicht{} THEN page (w);{} w.fensterende erreicht := FALSE{}
+ FI.{} textende:{} restlaenge := areaxsize (w.fenster) - w.cspalte + 1;{} min (length (text), restlaenge).{} setze fenstercursor neu:{} IF length (text) >= restlaenge{} THEN w.cspalte := 1;{} w.czeile INCR 1;{} schlage ggf neue seite auf{} ELSE w.cspalte INCR length (text){} FI.{} schlage ggf neue seite auf:{} IF w.czeile > w.belegbare zeilen{} THEN page (w);{} w.czeile := 1{} FI.{} setze ausgabe ggf in naechster zeile fort:{}
+ IF length (text) > restlaenge{} THEN out (w, subtext (text, restlaenge + 1)){} FI.{}END PROC out;{}PROC out frame (WINDOW VAR w):{} out frame (area (w)){}END PROC out frame;{}PROC out menuframe (WINDOW VAR w):{} out menu frame (area (w)){}END PROC out menuframe;{}PROC put (WINDOW VAR w, TEXT CONST word):{} out (w, word); out (w, blank){}END PROC put;{}PROC put (WINDOW VAR w, INT CONST number):{} put (w, text (number)){}END PROC put;{}PROC put (WINDOW VAR w, REAL VAR number):{} put (w, text (number)){}
+END PROC put;{}PROC putline (WINDOW VAR w, TEXT CONST textline):{} out (w, textline); line (w){}END PROC putline;{}PROC editget (WINDOW VAR w, TEXT VAR ausgabe,{} INT CONST max laenge, scroll,{} TEXT CONST sep, res, TEXT VAR exit char):{} INT VAR spalte, zeile;{} ggf zur naechsten zeile;{} get cursor (spalte, zeile); cursor on; cursor (spalte, zeile);{} editget (ausgabe, max laenge, min (scroll, restlaenge),{} sep, res, exitchar);{} get cursor (spalte, zeile); cursor off; cursor (spalte, zeile).{}
+ ggf zur naechsten zeile:{} IF restlaenge < 5 THEN line (w) FI.{} restlaenge:{} areaxsize (w.fenster) - w.cspalte - 1.{}END PROC editget;{}PROC editget (WINDOW VAR w, TEXT VAR ausgabe):{} TEXT VAR dummy;{} editget (w, ausgabe, 79, 79, "", "", dummy){}END PROC editget;{}PROC get (WINDOW VAR w, TEXT VAR word):{} INT VAR spa, zei;{} ggf zur naechsten zeile;{} get cursor (spa, zei); cursor on; cursor (spa, zei);{} REP{} word := "";{} editget (word, maxtextlength, restlaenge, " ", "", exit char);{}
+ out (w, subtext (word, 1, restlaenge));{} IF compress (word) <> ""{} THEN echoe exit char (w){} FI{} UNTIL word <> niltext AND word <> blank PER;{} get cursor (spa, zei); cursor off; cursor (spa, zei);{} delete leading blanks.{} ggf zur naechsten zeile:{} IF restlaenge < 5 THEN line (w) FI.{} restlaenge:{} areaxsize (w.fenster) - w.cspalte - 1.{} delete leading blanks:{} WHILE (word SUB 1) = blank REP word := subtext (word, 2) PER.{}END PROC get;{}PROC get (WINDOW VAR w, TEXT VAR word, TEXT CONST separator):{}
+ INT VAR spa, zei;{} ggf zur naechsten zeile;{} get cursor (spa, zei); cursor on; cursor (spa, zei);{} REP{} word := "";{} editget (word, maxtextlength, restlaenge, separator, "", exit char);{} out (w, subtext (word, 1, restlaenge));{} echoe exit char (w);{} UNTIL word <> niltext AND word <> blank PER;{} get cursor (spa, zei); cursor off; cursor (spa, zei).{} ggf zur naechsten zeile:{} IF restlaenge < 5 THEN line (w) FI.{} restlaenge:{} areaxsize (w.fenster) - w.cspalte - 1.{}
+END PROC get;{}PROC get (WINDOW VAR w, TEXT VAR word, INT CONST length):{} INT VAR spa, zei;{} ggf zur naechsten zeile;{} get cursor (spa, zei); cursor on; cursor (spa, zei);{} REP{} word := "";{} editget (word, maxtextlength, laenge, "", "", exit char);{} out (w, subtext (word, 1, laenge));{} echoe exit char (w){} UNTIL word <> niltext AND word <> blank PER;{} get cursor (spa, zei); cursor off; cursor (spa, zei).{} ggf zur naechsten zeile:{} IF restlaenge < 5 THEN line (w) FI.{}
+ restlaenge:{} areaxsize (w.fenster) - w.cspalte - 1.{} laenge:{} min (length, restlaenge).{}END PROC get;{}PROC get (WINDOW VAR w, INT VAR number):{} get (w, number word);{} number := int (number word){}END PROC get;{}PROC get (WINDOW VAR w, REAL VAR number):{} get (w, number word);{} number := real (number word){}END PROC get;{}PROC getline (WINDOW VAR w, TEXT VAR textline):{} INT VAR spa, zei;{} ggf zur naechsten zeile;{} get cursor (spa, zei); cursor on; cursor (spa, zei);{} REP{}
+ textline := "";{} editget (textline, maxtextlength, restlaenge, "", "", exit char);{} out (w, subtext (word, 1, restlaenge));{} echoe exit char (w);{} UNTIL textline <> niltext AND textline <> blank PER;{} get cursor (spa, zei); cursor off; cursor (spa, zei).{} ggf zur naechsten zeile:{} IF restlaenge < 5 THEN line (w) FI.{} restlaenge:{} areaxsize (w.fenster) - w.cspalte - 1.{}END PROC getline;{}PROC echoe exit char (WINDOW VAR fenster):{} IF exit char = cr{} THEN line (fenster){}
+ ELSE out (fenster, exit char){} FI{}END PROC echoe exit char;{}TEXT PROC center (WINDOW CONST w, TEXT CONST text):{} IF length (text) >= areaxsize (w.fenster){} THEN subtext (text, 1, areaxsize (w.fenster)){} ELSE center (areaxsize (w.fenster), text){} FI{}END PROC center;{}BOOL PROC yes (WINDOW VAR w, TEXT CONST frage):{} TEXT VAR zeichen, interne frage :: frage;{} interne frage CAT aussage [2];{} wechsel ggf auf neue seite;{} out (w, interne frage);{} hole eingabezeichen;{}
+ werte zeichen aus.{} wechsel ggf auf neue seite:{} IF remaining lines (w) < 1{} THEN page (w){} FI.{} hole eingabezeichen:{} cursor on; clear buffer;{} REP{} inchar (zeichen);{} piepse ggf{} UNTIL pos (janeinkette, zeichen) > 0 PER;{} out (w, blank + zeichen);{} cursor off; line (w).{} piepse ggf:{} IF pos (janeinkette, zeichen) = 0 THEN out (piep) FI.{} werte zeichen aus:{} IF pos (janeinkette, zeichen) < 5{} THEN TRUE{} ELSE FALSE{} FI.{}
+END PROC yes;{}PROC edit (WINDOW VAR w, FILE VAR f):{} out frame (w.fenster);{} loesche rechte spalten (w);{} cursor on;{} edit (f, areax (w.fenster), areay (w.fenster),{} areaxsize (w.fenster) - 1, areaysize (w.fenster));{} cursor off{}END PROC edit;{}PROC edit (WINDOW VAR w, TEXT CONST dateiname):{} FILE VAR f :: sequential file (modify, dateiname);{} to line (f, 1);{} edit (w, f){}END PROC edit;{}PROC show (WINDOW VAR w, FILE VAR f):{} out frame (w.fenster);{} loesche rechte spalten (w);{}
+ open editor (groesster editor + 1, f, FALSE,{} areax (w.fenster), areay (w.fenster),{} areaxsize (w.fenster) - 1, areaysize (w.fenster));{} cursor on;{} edit (groesster editor, "eqvw19dpgn"9"",{} PROC (TEXT CONST) std kommando interpreter);{} cursor off{}END PROC show;{}PROC show (WINDOW VAR w, TEXT CONST dateiname):{} FILE VAR f :: sequential file (modify, dateiname);{} to line (f, 1);{} show (w, f){}END PROC show;{}PROC loesche rechte spalten (WINDOW VAR w):{}
+ INT VAR i;{} FOR i FROM 1 UPTO areaysize (w.fenster) REP{} cursor (w, areaxsize (w.fenster) - 2, i); out (3 * blank){} PER{}END PROC loesche rechte spalten;{}BOOL PROC no (WINDOW VAR w, TEXT CONST frage):{} NOT yes (w, frage){}END PROC no;{}PROC stop (WINDOW VAR w):{} stop (w, 2){}END PROC stop;{}PROC stop (WINDOW VAR w, INT CONST zeilenzahl):{} INT VAR i; FOR i FROM 1 UPTO zeilenzahl REP line (w) PER;{} out (w, aussage [3]);{} pause{}END PROC stop;{}AREA PROC area (WINDOW CONST w):{}
+ w.fenster{}END PROC area;{}INT PROC areax (WINDOW CONST w):{} areax (w.fenster){}END PROC areax;{}INT PROC areay (WINDOW CONST w):{} areay (w.fenster){}END PROC areay;{}INT PROC areaxsize (WINDOW CONST w):{} areaxsize (w.fenster){}END PROC areaxsize;{}INT PROC areaysize (WINDOW CONST w):{} areaysize (w.fenster){}END PROC areaysize;{}END PACKET ls dialog 3;{}
+
diff --git a/dialog/ls-DIALOG 4 b/dialog/ls-DIALOG 4
new file mode 100644
index 0000000..7c9d9c4
--- /dev/null
+++ b/dialog/ls-DIALOG 4
@@ -0,0 +1,71 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG 4 **
+ ** **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+PACKET ls dialog 4 DEFINES{} boxinfo,{} boxnotice,{} boxalternative,{} boxyes,{} boxno,{} boxanswer,{} boxone,{} boxanswerone,{} boxsome,{} boxanswersome,{} out footnote,{} erase footnote:{}LET mark ein = ""15"",{} mark aus = ""14"",{} delimiter = ""13"",{} piep = ""7"",{} rechts links esc return = ""2""8""27""13"",{}
+ rechts links null return = ""2""8""0""13"" ,{} blank = " ",{} niltext = "",{} janeintasten = "jJyYnN";{}ROW 8 TEXT CONST aussage :: ROW 8 TEXT : ({}" Zum Weitermachen bitte irgendeine Taste tippen!",{}" Ändern: <Pfeile> Bestätigen: <RETURN> Abbruch: <ESC> <h>",{}" Ändern: <Pfeile> Bestätigen: <RETURN> Ja: <j> Nein: <n>",{}" Ändern: <Pfeile> Bestätigen: <RETURN>",{}" Fertig: <RETURN> Zeigen: <ESC><z> Abbruch: <ESC><h>",{}
+" Fertig: <RETURN> Abbruch: <ESC><h>",{}"Ja"13"Nein",{}" Eingabe: "{});{}PROC boxinfo (WINDOW VAR w, TEXT CONST t,{} INT CONST position, timelimit,{} INT VAR x, y, xsize, ysize):{} INT VAR spa, zei;{} get cursor (w, spa, zei);{} schreibe box (w, t, position, timelimit, x, y, xsize, ysize);{} cursor (w, spa, zei);{}END PROC boxinfo;{}PROC boxinfo (WINDOW VAR w, TEXT CONST t, INT CONST position,{} timelimit, BOOL CONST trennlinie weg):{} INT VAR x, y, xsize, ysize, spa, zei;{}
+ get cursor (w, spa, zei);{} schreibe box (w, t, position, timelimit, x, y, xsize, ysize);{} page up (x, y, xsize, ysize);{} IF trennlinie weg{} THEN erase footnote (w, TRUE){} ELSE erase footnote (w, FALSE){} FI;{} cursor (w, spa, zei){}END PROC boxinfo;{}PROC boxinfo (WINDOW VAR w, TEXT CONST t, INT CONST position, timelimit):{} boxinfo (w, t, position, timelimit, TRUE){}END PROC boxinfo;{}PROC boxinfo (WINDOW VAR w, TEXT CONST t):{} boxinfo (w, t, 5, maxint, TRUE){}END PROC boxinfo;{}
+PROC boxnotice (WINDOW VAR w, TEXT CONST t, INT CONST position,{} INT VAR x, y, xsize, ysize):{} INT VAR spa, zei;{} get cursor (w, spa, zei);{} schreibe notiz (w, t, position, x, y, xsize, ysize);{} cursor (w, spa, zei){}END PROC boxnotice;{}INT PROC boxalternative (WINDOW VAR w, TEXT CONST t,{} auswahlliste, zusatztasten,{} INT CONST position, BOOL CONST mit abbruch,{} INT VAR x, y, xsize, ysize):{}
+ INT VAR ergebnis, spa, zei;{} get cursor (w, spa, zei);{} schreibe alternativen (w, t, auswahlliste, zusatztasten, position,{} mit abbruch, x, y, xsize, ysize, ergebnis);{} cursor (w, spa, zei);{} ergebnis{}END PROC boxalternative;{}INT PROC boxalternative (WINDOW VAR w, TEXT CONST t, auswahlliste,{} zusatztasten, INT CONST position,{} BOOL CONST mit abbruch, trennlinie weg):{} INT VAR x, y, xsize, ysize, ergebnis, spa, zei;{}
+ get cursor (w, spa, zei);{} ergebnis := boxalternative (w, t, auswahlliste, zusatztasten, position,{} mit abbruch, x, y, xsize, ysize);{} page up (x, y, xsize, ysize);{} IF trennlinie weg{} THEN erase footnote (w, TRUE){} ELSE erase footnote (w, FALSE){} FI;{} cursor (w, spa, zei);{} ergebnis{}END PROC boxalternative;{}INT PROC boxalternative (WINDOW VAR w, TEXT CONST t,{} auswahlliste, zusatztasten,{} INT CONST position, BOOL CONST mit abbruch):{}
+ boxalternative (w, t, auswahlliste, zusatztasten,{} position, mit abbruch, TRUE){}END PROC boxalternative;{}BOOL PROC boxyes (WINDOW VAR w, TEXT CONST t, INT CONST position,{} INT VAR x, y, xsize, ysize):{} INT VAR spa, zei;{} get cursor (w, spa, zei);{} BOOL CONST wert :: ja (w, t, position, x, y, xsize, ysize);{} cursor (w, spa, zei);{} wert{}END PROC boxyes;{}BOOL PROC boxyes (WINDOW VAR w, TEXT CONST t,{} INT CONST position, BOOL CONST trennlinie weg):{}
+ INT VAR x, y, xsize, ysize, spa, zei;{} get cursor (w, spa, zei);{} BOOL VAR wert :: ja (w, t, position, x, y, xsize, ysize);{} page up (x, y, xsize, ysize);{} IF trennlinie weg{} THEN erase footnote (w, TRUE){} ELSE erase footnote (w, FALSE);{} FI;{} cursor (w, spa, zei);{} wert{}END PROC boxyes;{}BOOL PROC boxyes (WINDOW VAR w, TEXT CONST t, INT CONST position):{} boxyes (w, t, position, TRUE){}END PROC boxyes;{}BOOL PROC boxno (WINDOW VAR w, TEXT CONST t, INT CONST position,{}
+ INT VAR x, y, xsize, ysize):{} NOT boxyes (w, t, position, x, y, xsize, ysize){}END PROC boxno;{}BOOL PROC boxno (WINDOW VAR w, TEXT CONST t,{} INT CONST position, BOOL CONST trennlinie weg):{} NOT boxyes (w, t, position, trennlinie weg){}END PROC boxno;{}BOOL PROC boxno (WINDOW VAR w, TEXT CONST t, INT CONST position):{} boxno (w, t, position){}END PROC boxno;{}TEXT PROC boxanswer (WINDOW VAR w, TEXT CONST t, vorgabe,{} INT CONST position, INT VAR x, y, xsize, ysize):{}
+ INT VAR spa, zei;{} TEXT VAR wert;{} get cursor (w, spa, zei);{} wert := hole antwort (w, t, vorgabe, position, FALSE, x, y, xsize, ysize);{} cursor (spa, zei);{} wert{}END PROC boxanswer;{}TEXT PROC boxanswer (WINDOW VAR w, TEXT CONST t, vorgabe,{} INT CONST position, BOOL CONST trennlinie weg):{} INT VAR x, y, xsize, ysize, spa, zei;{} get cursor (w, spa, zei);{} TEXT VAR wert := hole antwort (w, t, vorgabe, position, FALSE,{} x, y, xsize, ysize);{}
+ page up (x, y, xsize, ysize);{} IF trennlinie weg{} THEN erase footnote (w, TRUE){} ELSE erase footnote (w, FALSE){} FI;{} cursor (w, spa, zei);{} wert{}END PROC boxanswer;{}TEXT PROC boxanswer (WINDOW VAR w, TEXT CONST t, vorgabe,{} INT CONST position):{} boxanswer (w, t, vorgabe, position, TRUE){}END PROC boxanswer;{}TEXT PROC boxone (WINDOW VAR w, THESAURUS CONST thesaurus,{} TEXT CONST text1, text2, BOOL CONST mit reinigung):{}
+ INT VAR spa, zei;{} get cursor (w, spa, zei);{} TEXT VAR wert :: one (areax (w) + 2, areay (w) + 2,{} areaxsize (w) - 4, areaysize (w) - 2,{} thesaurus, text1, text2);{} IF mit reinigung{} THEN page up (areax (w) + 2, areay (w) + 2,{} areaxsize (w) - 4, areaysize (w) - 2);{} erase footnote (w){} FI;{} cursor (w, spa, zei);{} wert{}END PROC boxone;{}TEXT PROC boxanswerone (WINDOW VAR w, TEXT CONST text, vorgabe,{}
+ THESAURUS CONST thesaurus, TEXT CONST t1, t2,{} BOOL CONST mit reinigung, trennlinie weg):{} INT VAR x,y, xsize, ysize, spa, zei;{} get cursor (w, spa, zei);{} TEXT VAR wert := hole antwort (w, text, vorgabe, 5, TRUE,{} x, y, xsize, ysize);{} IF wert = ""27"z"{} THEN lasse auswaehlen{} ELSE uebernimm den wert{} FI;{} cursor (w, spa, zei);{} wert.{} lasse auswaehlen:{} IF mit reinigung{} THEN wert := boxone (w, thesaurus, t1, t2, TRUE ){}
+ ELSE wert := boxone (w, thesaurus, t1, t2, FALSE){} FI.{} uebernimm den wert:{} IF mit reinigung{} THEN page up (x, y, xsize, ysize);{} entferne ggf die trennlinie{} FI.{} entferne ggf die trennlinie:{} IF trennlinie weg{} THEN erase footnote (w, TRUE){} ELSE erase footnote (w, FALSE){} FI.{}END PROC boxanswer one;{}TEXT PROC boxanswerone (WINDOW VAR w, TEXT CONST text, vorgabe,{} THESAURUS CONST thesaurus, TEXT CONST t1, t2,{}
+ BOOL CONST mit reinigung):{} boxanswerone (w, text, vorgabe, thesaurus, t1, t2, mit reinigung, TRUE){}END PROC boxanswer one;{}THESAURUS PROC boxsome (WINDOW VAR w, THESAURUS CONST thesaurus,{} TEXT CONST text1, text2,{} BOOL CONST mit reinigung):{} INT VAR spa, zei;{} get cursor (w, spa, zei);{} THESAURUS VAR wert :: some (areax (w) + 2, areay (w) + 2,{} areaxsize (w) - 4, areaysize (w) - 2,{}
+ thesaurus, text1, text2);{} IF mit reinigung{} THEN page up (areax (w) + 2, areay (w) + 2,{} areaxsize (w) - 4, areaysize (w) - 2);{} erase footnote (w){} FI;{} cursor (w, spa, zei);{} wert{}END PROC boxsome;{}THESAURUS PROC boxanswersome (WINDOW VAR w, TEXT CONST text, vorgabe,{} THESAURUS CONST thesaurus,{} TEXT CONST t1, t2,{} BOOL CONST mit reinigung, trennlinie weg):{}
+ THESAURUS VAR ergebnis :: empty thesaurus;{} INT VAR x, y, xsize, ysize, spa, zei;{} get cursor (w, spa, zei);{} TEXT VAR wert := hole antwort (w, text, vorgabe, 5, TRUE,{} x, y, xsize, ysize);{} IF wert = ""27"z"{} THEN lasse auswaehlen{} ELSE uebernimm den wert{} FI;{} cursor (w, spa, zei);{} ergebnis.{} lasse auswaehlen:{} IF mit reinigung{} THEN ergebnis := boxsome (w, thesaurus, t1, t2, TRUE ){} ELSE ergebnis := boxsome (w, thesaurus, t1, t2, FALSE){}
+ FI.{} uebernimm den wert:{} IF wert <> niltext{} THEN insert (ergebnis, wert){} FI;{} IF mit reinigung{} THEN page up (x, y, xsize, ysize);{} entferne ggf die trennlinie{} FI.{} entferne ggf die trennlinie:{} IF trennlinie weg{} THEN erase footnote (w, TRUE){} ELSE erase footnote (w, FALSE){} FI.{}END PROC boxanswer some;{}THESAURUS PROC boxanswersome (WINDOW VAR w, TEXT CONST text, vorgabe,{} THESAURUS CONST thesaurus,{}
+ TEXT CONST t1, t2,{} BOOL CONST mit reinigung):{} boxanswersome (w, text, vorgabe, thesaurus, t1, t2, mit reinigung, TRUE){}END PROC boxanswersome;{}PROC out footnote (WINDOW VAR w, BOOL CONST mit trennlinie, TEXT CONST text):{} INT VAR spa, zei;{} get cursor (w, spa, zei);{} IF mit trennlinie{} THEN cursor (w, 1, areaysize (w) - 1);{} areaxsize (w) TIMESOUT waagerecht{} FI;{} cursor (w, 1, areaysize (w));{} outtext (text, 1, areaxsize (w));{}
+ cursor (w, spa, zei){}END PROC out footnote;{}PROC out footnote (WINDOW VAR w, TEXT CONST t):{} out footnote (w, TRUE, t){}END PROC out footnote;{}PROC erase footnote (WINDOW VAR w, BOOL CONST auch trennlinie):{} INT VAR spa, zei;{} get cursor (w, spa, zei);{} IF auch trennlinie{} THEN cursor (w, 1, areaysize (w) - 1);{} outtext ("", 1, areaxsize (w)){} FI;{} cursor (w, 1, areaysize (w));{} outtext ("", 1, areaxsize (w));{} cursor (w, spa, zei){}END PROC erase footnote;{}PROC erase footnote (WINDOW VAR w):{}
+ erase footnote (w, TRUE){}END PROC erase footnote;{}PROC schreibe boxtext (WINDOW VAR w, TEXT CONST t,{} INT CONST position, zusatzlaenge,{} mindestbreite, mindesthoehe,{} INT VAR x, y, xsize, ysize):{} ermittle boxbreite und boxhoehe;{} ermittle rahmenwerte;{} schreibe boxkopf;{} schreibe boxrumpf.{} ermittle boxbreite und boxhoehe:{} TEXT VAR intern :: t + delimiter;{} entferne fuehrende delimiter;{} INT VAR anfang :: 1,{}
+ ende :: pos (intern, delimiter, anfang) - 1;{} xsize := 0;{} ysize := 0;{} WHILE ende > 0 REP{} ysize INCR 1;{} lege ggf boxbreite fest;{} bestimme neue positionen{} PER.{} entferne fuehrende delimiter:{} WHILE (intern SUB 1) = delimiter REP{} intern := subtext (intern, 2){} PER.{} lege ggf boxbreite fest:{} IF length (subtext (intern, anfang, ende)) > xsize{} THEN xsize := length (subtext (intern, anfang, ende)){} FI.{} bestimme neue positionen:{}
+ anfang := ende + 2;{} ende := pos (intern, delimiter, anfang) - 1.{} ermittle rahmenwerte:{} schlage notwendige groessen auf;{} kill ueberlaengen;{} lege bildschirmpositionen fest.{} schlage notwendige groessen auf:{} IF xsize < mindestbreite{} THEN xsize := mindestbreite{} FI;{} IF ysize < mindesthoehe{} THEN ysize := mindesthoehe{} FI;{} ysize INCR zusatzlaenge;{} ysize INCR 2; (* Für den Rahmen *){} xsize INCR 2. (* Für den Rahmen *){} kill ueberlaengen:{}
+ IF ysize > (areaysize (w) - 4){} THEN ysize := areaysize (w) - 4{} FI;{} IF xsize > (areaxsize (w) - 4){} THEN xsize := areaxsize (w) - 4{} FI.{} lege bildschirmpositionen fest:{} SELECT position OF{} CASE 1: plazierung links oben{} CASE 2: plazierung rechts oben{} CASE 3: plazierung links unten{} CASE 4: plazierung rechts unten{} OTHERWISE plazierung im zentrum{} END SELECT.{} plazierung links oben:{} x := areax (w) + 2;{} y := areay (w) + 2.{}
+ plazierung rechts oben:{} x := areax (w) + areaxsize (w) - xsize - 2;{} y := areay (w) + 2.{} plazierung links unten:{} x := areax (w) + 2;{} y := areay (w) + areaysize (w) - ysize - 2.{} plazierung rechts unten:{} x := areax (w) + areaxsize (w) - xsize - 2;{} y := areay (w) + areaysize (w) - ysize - 2.{} plazierung im zentrum:{} x := areax (w) + ((areaxsize (w) - (xsize + 2)) DIV 2) + 1;{} y := areay (w) + ((areaysize (w) - ysize) DIV 2).{} schreibe boxkopf:{}
+ cursor (x, y);{} out (ecke oben links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke oben rechts).{} schreibe boxrumpf:{} INT VAR i;{} intern := t + delimiter;{} entferne fuehrende delimiter;{} anfang := 1;{} ende := pos (intern, delimiter, anfang) - 1;{} FOR i FROM y + 1 UPTO y + ysize - zusatzlaenge - 2 REP{} cursor (x, i);{} out (senkrecht);{} outtext (subtext (intern, anfang, ende), 1, xsize - 2);{} out (senkrecht);{} anfang := ende + 2;{}
+ ende := pos (intern, delimiter, anfang) - 1{} PER{}END PROC schreibe boxtext;{}PROC schreibe boxfuss (WINDOW VAR w,{} INT CONST x, y, xsize, ysize, limit):{} schreibe abschlusszeile;{} out footnote (w, aussage [1]);{} cursor in position und warten.{} schreibe abschlusszeile:{} cursor (x, y + ysize - 1);{} out (ecke unten links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke unten rechts).{} cursor in position und warten:{} cursor parken (w);{}
+ clear buffer;{} pause (limit){}END PROC schreibe boxfuss;{}PROC cursor parken (WINDOW VAR w):{} cursor (w, 1, 2){}END PROC cursor parken;{}PROC schreibe box (WINDOW VAR w, TEXT CONST t,{} INT CONST position, timelimit,{} INT VAR x, y, xsize, ysize):{} schreibe boxtext (w, t, position, 0, 0, 0, x, y, xsize, ysize);{} schreibe boxfuss (w, x, y, xsize, ysize, timelimit){}END PROC schreibe box;{}PROC schreibe notizfuss (WINDOW VAR w, INT CONST x, y, xsize, ysize):{}
+ schreibe abschlusszeile;{} cursor parken (w).{} schreibe abschlusszeile:{} cursor (x, y + ysize - 1);{} out (ecke unten links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke unten rechts).{}END PROC schreibe notizfuss;{}PROC schreibe notiz (WINDOW VAR w, TEXT CONST t, INT CONST position,{} INT VAR x, y, xsize, ysize):{} schreibe boxtext (w, t, position, 0, 0, 0, x, y, xsize, ysize);{} schreibe notizfuss (w, x, y, xsize, ysize){}END PROC schreibe notiz;{}PROC schreibe alternativen (WINDOW VAR w, TEXT CONST t, altzeile, sonst,{}
+ INT CONST position, BOOL CONST mit abbruch,{} INT VAR x, y, xsize, ysize, ergebnis):{} ROW 10 STRUCT (TEXT alternat, INT anfang, laenge) VAR altliste;{} normiere alternativen;{} untersuche alternativen;{} schreibe boxtext (w, textintern, position, 2, altbreite,{} 0, x, y, xsize, ysize);{} schreibe alternativenfuss;{} lasse auswaehlen;{} liefere ergebnis.{} textintern:{} IF sonst = janeintasten{} THEN TEXT VAR zwischen;{}
+ zwischen := t;{} kuerze um folgende blanks;{} zwischen + "? "{} ELSE t{} FI.{} kuerze um folgende blanks:{} WHILE (zwischen SUB (length (zwischen))) = blank REP{} zwischen := subtext (zwischen , 1, length (zwischen) - 1){} PER.{} normiere alternativen:{} TEXT VAR altintern :: altzeile;{} altintern CAT delimiter.{} untersuche alternativen:{} INT VAR altanzahl :: 1, altbreite, first :: - 2, anfang :: 1,{} ende :: pos (altintern, delimiter, anfang) - 1;{}
+ WHILE ende > 0 AND altanzahl <= 10 REP{} trage alternative ein;{} trage alternativenanfang ein;{} trage alternativenlaenge ein;{} setze neue positionen fest{} PER;{} ermittle gesamtalternativenbreite.{} trage alternative ein:{} altliste [altanzahl].alternat :={} compress (subtext (altintern, anfang, ende)).{} trage alternativenanfang ein:{} first INCR 3;{} altliste [altanzahl].anfang := first.{} trage alternativenlaenge ein:{}
+ altliste [altanzahl].laenge := length (altliste [altanzahl].alternat);{} first INCR altliste [altanzahl].laenge.{} setze neue positionen fest:{} anfang := ende + 2;{} ende := pos (altintern, delimiter, anfang) - 1;{} altanzahl INCR 1.{} ermittle gesamtalternativenbreite:{} altanzahl DECR 1;{} altbreite := altliste [altanzahl].anfang;{} altbreite INCR (altliste [altanzahl].laenge + 3);{} IF altbreite > areaxsize (w) - 6{} THEN LEAVE schreibe alternativen{}
+ FI.{} schreibe alternativenfuss:{} schreibe leerzeile;{} schreibe antwortmoeglichkeiten;{} schreibe abschlusszeile;{} IF mit abbruch{} THEN out footnote (w, aussage [2]){} ELSE beruecksichtige ja nein hinweis{} FI.{} schreibe leerzeile:{} cursor (x, y + ysize - 3);{} out (senkrecht);{} (xsize - 2) TIMESOUT blank;{} out (senkrecht).{} schreibe antwortmoeglichkeiten:{} cursor (x, y + ysize - 2);{} out (senkrecht);{} einrueckbreite TIMESOUT blank;{}
+ out (antwortleiste);{} rest TIMESOUT blank;{} out (senkrecht).{} einrueckbreite:{} (xsize - 2 - length (antwortleiste)) DIV 2.{} antwortleiste:{} INT VAR zeiger; TEXT VAR ausgabe :: "";{} FOR zeiger FROM 1 UPTO altanzahl REP{} ausgabe CAT altliste [zeiger].alternat;{} ausgabe CAT " "{} PER;{} compress (ausgabe).{} rest:{} xsize - 2 - einrueckbreite - length (antwortleiste).{} schreibe abschlusszeile:{} cursor (x, y + ysize - 1);{} out (ecke unten links);{}
+ (xsize - 2) TIMESOUT waagerecht;{} out (ecke unten rechts).{} beruecksichtige ja nein hinweis:{} IF sonst = janeintasten{} THEN out footnote (w, aussage [3]){} ELSE out footnote (w, aussage [4]){} FI.{} lasse auswaehlen:{} INT VAR altzeiger :: 1;{} stelle erste alternative invers dar;{} REP{} hole eingabe;{} werte eingabe aus und reagiere{} UNTIL alternative gefunden PER.{} stelle erste alternative invers dar:{} cursor (x + einrueckbreite, y + ysize - 2);{}
+ out (mark ein);{} out (altliste [altzeiger].alternat); out (blank);{} out (mark aus);{} cursor (x + einrueckbreite, y + ysize - 2).{} hole eingabe:{} TEXT VAR moegliche, eingabe;{} IF mit abbruch{} THEN moegliche := rechts links esc return + sonst{} ELSE moegliche := rechts links null return + sonst{} FI;{} clear buffer;{} REP{} inchar (eingabe);{} piepse bei unzulaessiger eingabe{} UNTIL pos (moegliche, eingabe) > 0 PER.{} piepse bei unzulaessiger eingabe:{}
+ IF pos (moegliche, eingabe) = 0 THEN out (piep) FI.{} werte eingabe aus und reagiere:{} SELECT pos (moegliche, eingabe) OF{} CASE 1: zur naechsten alternative{} CASE 2: zur vorausgehenden alternative{} CASE 3: esc kommando verarbeiten{} END SELECT.{} zur naechsten alternative:{} loesche aktuelle alternative;{} ermittle rechte alternative;{} stelle neue alternative invers dar.{} zur vorausgehenden alternative:{} loesche aktuelle alternative;{} ermittle linke alternative;{}
+ stelle neue alternative invers dar.{} loesche aktuelle alternative:{} cursor (alternativenanfang - 1, y + ysize - 2);{} out (blank);{} out (altliste [altzeiger].alternat);{} out (2 * blank).{} alternativenanfang:{} x + einrueckbreite + altliste [altzeiger].anfang.{} ermittle rechte alternative:{} IF altzeiger = altanzahl{} THEN altzeiger := 1{} ELSE altzeiger INCR 1{} FI.{} ermittle linke alternative:{} IF altzeiger = 1{} THEN altzeiger := altanzahl{}
+ ELSE altzeiger DECR 1{} FI.{} stelle neue alternative invers dar:{} cursor (alternativenanfang - 1, y + ysize - 2);{} out (mark ein);{} out (altliste [altzeiger].alternat); out (blank);{} out (mark aus);{} cursor (alternativenanfang - 1, y + ysize - 2).{} esc kommando verarbeiten:{} inchar (eingabe);{} IF eingabe = "h"{} THEN ergebnis := 0;{} LEAVE schreibe alternativen{} ELSE out (piep); eingabe := ""{} FI.{} alternative gefunden:{} pos (moegliche, eingabe) > 3.{}
+ liefere ergebnis:{} IF pos (moegliche, eingabe) = 4{} THEN ergebnis := altzeiger{} ELSE ergebnis := 100 + pos (sonst, eingabe){} FI.{}END PROC schreibe alternativen;{}BOOL PROC ja (WINDOW VAR w, TEXT CONST t, INT CONST position,{} INT VAR x, y, xsize, ysize):{} INT VAR ergebnis;{} schreibe alternativen (w, t, aussage [7], janeintasten, position,{} FALSE, x, y, xsize, ysize, ergebnis);{} SELECT ergebnis OF{} CASE 2, 105, 106: FALSE{} OTHERWISE TRUE{}
+ END SELECT.{}END PROC ja;{}TEXT PROC hole antwort (WINDOW VAR w, TEXT CONST t, vorgabe,{} INT CONST position, BOOL CONST mit auswahl,{} INT VAR x, y, xsize, ysize):{} TEXT VAR eingabe :: compress (vorgabe);{} schreibe boxtext (w, t, position, 2, length (aussage [8]) + 12, 2,{} x, y, xsize, ysize);{} schreibe antwortfuss;{} clear buffer;{} REP{} IF eingabe = "break"{} THEN eingabe := ""{} FI;{} lasse eintragen{}
+ UNTIL eingabe <> "break" PER;{} liefere ergebnis.{} schreibe antwortfuss:{} schreibe leerzeile;{} schreibe eingabezeile;{} schreibe abschlusszeile;{} IF mit auswahl{} THEN out footnote (w, aussage [5]){} ELSE out footnote (w, aussage [6]){} FI.{} schreibe leerzeile:{} cursor (x, y + ysize - 3);{} out (senkrecht);{} (xsize - 2) TIMESOUT blank;{} out (senkrecht).{} schreibe eingabezeile:{} cursor (x, y + ysize - 2);{} out (senkrecht);{} out (aussage [8]);{}
+ (xsize - 2 - length (aussage [8])) TIMESOUT blank;{} out (senkrecht).{} schreibe abschlusszeile:{} cursor (x, y + ysize - 1);{} out (ecke unten links);{} (xsize - 2) TIMESOUT waagerecht;{} out (ecke unten rechts).{} lasse eintragen:{} TEXT VAR exit :: "";{} cursor on;{} cursor (x + length (aussage [8]) + 1, y + ysize - 2);{} IF mit auswahl{} THEN editget (eingabe, maxtextlength, textlaenge, "", "hz", exit){} ELSE editget (eingabe, maxtextlength, textlaenge, "", "h", exit){}
+ FI;{} cursor off;{} IF exit = ""27"h"{} THEN eingabe := ""{} ELIF mit auswahl AND (exit = ""27"z"){} THEN eingabe := ""27"z"{} ELSE eingabe := compress (eingabe){} FI.{} textlaenge:{} xsize - 2 - length (aussage [8]).{} liefere ergebnis:{} eingabe.{}END PROC hole antwort;{}END PACKET ls dialog 4;{}
+
diff --git a/dialog/ls-DIALOG 5 b/dialog/ls-DIALOG 5
new file mode 100644
index 0000000..1772b99
--- /dev/null
+++ b/dialog/ls-DIALOG 5
@@ -0,0 +1,118 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG 5 **
+ ** **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+PACKET ls dialog 5 DEFINES{} menufootnote, old menufootnote,{} menuinfo,menualternative,{} menuyes, menuno, menuone,{} menusome,menuanswer,{} menuanswerone, menuanswersome,{} install menu, handle menu,{} refresh submenu, deactivate,{} regenerate menuscreen, activate,{} write menunotice, erase menunotice,{} menubasistext, anwendungstext,{} show menuwindow, menuwindowpage,{} menuwindowout, menuwindowget,{} menuwindoweditget, menuwindowedit,{}
+ menuwindowshow, menuwindowline,{} menuwindowyes, menuwindowno,{} menuwindowcursor, get menuwindowcursor,{} remaining menuwindowlines,{} menuwindowcenter, menuwindowstop,{} editorinformationen,stdinfoedit,{} menukartenname, current menuwindow,{} reset dialog, only intern, ausstieg,{} direktstart:{}LET systemkuerzel = "ls-DIALOG",{} menutafeltaskname = "ls-MENUKARTEN",{} menutafeltype = 1954,{} menutafelpraefix = "ls-MENUKARTE:",{}
+ stdmenukartenname = "ls-MENUKARTE:Archiv",{} versionsnummer = "1.1",{} copyright1 = " (C) 1987/88 Eva Latta-Weber",{} copyright2 = " (C) 1988 ERGOS GmbH";{}LET maxmenus = 6,{} maxmenutexte = 300,{} maxinfotexte = 2000,{} maxhauptmenupunkte = 10,{} maxuntermenupunkte = 15,{} erste untermenuzeile = 3;{}LET blank = " ",{} piep = ""7"",{}
+ cleol = ""5"",{} cleop = ""4"",{} trennzeilensymbol = "###",{} bleibt leer symbol = "***",{} hauptmenuluecke = " ";{}LET auswahlstring1 = ""8""2""10""3""13""27"?";{}TYPE MENUPUNKT = STRUCT (TEXT punktkuerzel,{} punktname,{} procname,{} boxtext,{} BOOL aktiv,{} angewaehlt),{}
+ EINZELMENU = STRUCT (INT belegt,{} TEXT ueberschrift,{} INT anfangsposition,{} maxlaenge,{} ROW maxuntermenupunkte MENUPUNKT menupunkt,{} INT aktueller untermenupunkt,{} TEXT startprozedurname,{} leaveprozedurname),{} MENU = STRUCT (TEXT menuname,{} INT anzahl hauptmenupunkte,{}
+ ROW maxhauptmenupunkte EINZELMENU einzelmenu,{} TEXT menueingangsprozedur,{} menuausgangsprozedur,{} menuinfo,{} lizenznummer,{} versionsnummer,{} INT hauptmenuzeiger,{} untermenuanfang,{} untermenuzeiger),{} INFOTEXT = STRUCT (INT anzahl infotexte,{}
+ ROW maxinfotexte TEXT stelle),{} MENUTEXT = STRUCT (INT anzahl menutexte,{} ROW maxmenutexte TEXT platz),{} MENULEISTE = STRUCT (INT belegt, zeigeraktuell, zeigerhintergrund,{} ROW maxmenus MENU menu,{} MENUTEXT menutext,{} INFOTEXT infotext);{}BOUND MENULEISTE VAR menuleiste;{}DATASPACE VAR ds;{}WINDOW VAR menuwindow, schreibfenster, editorinfofenster;{}
+INITFLAG VAR in this task :: FALSE;{}INT VAR anzahl offener menus :: 0;{}INT VAR menunotizx, menunotizxsize,{} menunotizy, menunotizysize,{} menunotizposition;{}TEXT VAR angekoppelte menutafel :: "",{} permanent footnote :: "",{} menunotiztext;{}BOOL VAR menunotiz ist gesetzt :: FALSE,{} nur interne verwendung :: FALSE,{} mit ausstieg :: FALSE;{}REAL VAR zeitpunkt :: clock (1);{}
+ROW 13 TEXT CONST fehlermeldung :: ROW 13 TEXT : ({}"Die Task '" + menutafeltaskname + "' existiert nicht!",{}"Die Menukarte '",{}"' existiert nicht in der Task '" + menutafeltaskname + "'!",{}"' hat falschen Typ/Bezeichnung (keine 'MENUKARTE')!",{}"Das Menu '",{}"' ist nicht in der angekoppelten Menukarte!",{}"Zu viele geoeffnete Menus ( > 2 )!",{}"Kein Menu geoeffnet!",{}"Menu enthaelt keine Menupunkte!",{}"Menupunkt ist nicht im Menu enthalten!",{}"Kein Text vorhanden!",{}"Zugriff unmöglich!",{}
+"Einschränkung unzulässig!"{});{}ROW 1 TEXT CONST vergleichstext :: ROW 1 TEXT : ({}"gibt es nicht"{});{}ROW 3 TEXT CONST hinweis :: ROW 3 TEXT : ({}"Info:<ESC><?>/<?> Wahl:<Pfeile> Ausführen:<RETURN> Verlassen:<ESC><q>",{}" Zum Weitermachen bitte irgendeine Taste tippen!",{}"Bitte warten ... Ich räume auf!"{});{}ROW 3 TEXT CONST infotext :: ROW 3 TEXT : ({}" Für diesen Menupunkt ist (noch) keine "13""13" Funktion eingetragen!",{}" Möchten Sie dieses Menu tatsächlich verlassen",{}" Leider ist zu diesem Menupunkt "13""13" kein Info - Text eingetragen!"{}
+ );{}PROC install menu (TEXT CONST menutafelname):{} installmenu (menutafelname, TRUE){}END PROC install menu;{}PROC install menu (TEXT CONST menutafelname, BOOL CONST mit kennung):{} TEXT VAR letzter parameter;{} IF mit kennung{} THEN zeige menukennung{} FI;{} initialisiere menu ggf;{} IF menutafel noch nicht angekoppelt{} THEN letzter parameter := std;{} hole menutafel;{} kopple menutafel an;{} last param (letzter parameter){} FI.{} initialisiere menu ggf:{}
+ IF NOT initialized (in this task){} THEN angekoppelte menutafel := "";{} anzahl offener menus := 0;{} menunotiz ist gesetzt := FALSE;{} nur interne verwendung := FALSE{} FI.{} menutafel noch nicht angekoppelt:{} menutafelname <> angekoppelte menutafel.{} hole menutafel:{} IF NOT exists task (menutafeltaskname){} THEN bereinige situation; cursor on;{} errorstop (fehlermeldung [1]){} FI;{} disable stop;{} fetch (menutafelname, /menutafeltaskname);{}
+ IF is error AND pos (errormessage, vergleichstext [1]) > 0{} THEN clear error; enable stop;{} bereinige situation; cursor on;{} errorstop (fehlermeldung [2] + menutafelname +{} fehlermeldung [3]){} ELIF is error{} THEN clear error; enable stop;{} bereinige situation; cursor on;{} errorstop (errormessage){} ELSE enable stop{} FI.{} kopple menutafel an:{} IF type (old (menutafelname)) = menutafeltype{}
+ AND pos (menutafelname,menutafelpraefix) = 1{} THEN forget (ds);{} ds := old (menutafelname);{} menuleiste := ds;{} angekoppelte menutafel := menutafelname;{} forget (menutafelname, quiet){} ELSE bereinige situation; cursor on;{} errorstop ("'" + menutafelname + fehlermeldung [4]){} FI.{}END PROC install menu;{}PROC only intern (BOOL CONST wert):{} nur interne verwendung := wert{}END PROC only intern;{}
+PROC ausstieg (BOOL CONST wert):{} mit ausstieg := wert{}END PROC ausstieg;{}TEXT PROC menukartenname:{} IF NOT initialized (in this task){} THEN angekoppelte menutafel := "";{} anzahl offener menus := 0;{} menunotiz ist gesetzt := FALSE;{} FI;{} angekoppelte menutafel{}END PROC menukartenname;{}PROC handle menu (TEXT CONST menuname):{} nur interne verwendung := FALSE;{} mit ausstieg := TRUE;{} handle menu (menuname, ""){}END PROC handle menu;{}
+PROC handle menu (TEXT CONST menuname, ausstiegsproc):{} cursor off;{} IF nur interne verwendung{} THEN oeffne menu (menuname){} ELSE biete menu an{} FI;{} lasse menupunkte auswaehlen;{} IF nur interne verwendung{} THEN do (ausstiegsproc);{} anzahl offener menus DECR 1;{} IF anzahl offener menus < 1 THEN erase menunotice FI;{} menuleiste.zeigeraktuell := menuleiste.zeigerhintergrund;{} menuwindow := window (1,1,79, 24);{} nur interne verwendung := FALSE;{}
+ mit ausstieg := TRUE;{} cursor on{} ELSE schliesse menu;{} leere ggf den bildschirm{} FI.{} biete menu an:{} REAL VAR zwischenzeit :: clock (1) - zeitpunkt;{} IF zwischenzeit < 2.0{} THEN pause (20 - int (10.0 * zwischenzeit)){} FI;{} oeffne menu (menuname).{} leere ggf den bildschirm:{} IF anzahl offener menus < 1{} THEN erase menunotice;{} page; cursor on{} FI.{} lasse menupunkte auswaehlen:{} TEXT VAR kuerzelkette :: "";{}
+ starte aktuelle untermenuoperationen;{} REP{} cursor in warteposition;{} ermittle aktuelle kuerzelkette;{} nimm zeichen auf;{} interpretiere zeichen;{} UNTIL menu verlassen gewuenscht PER.{} nimm zeichen auf:{} TEXT CONST erlaubte zeichen ::auswahlstring1 + kuerzelkette;{} TEXT VAR eingabezeichen;{} INT VAR zeichenposition;{} REP{} inchar (eingabezeichen);{} zeichenposition := pos (erlaubte zeichen, eingabezeichen);{} piepse ggf{} UNTIL zeichenposition > 0 PER.{}
+ piepse ggf:{} IF zeichenposition = 0 THEN out (piep) FI.{} menu verlassen gewuenscht:{} zeichenposition = 6 AND (zweites zeichen = "q").{} interpretiere zeichen:{} SELECT zeichenposition OF{} CASE 1: gehe einen hauptmenupunkt nach links{} CASE 2: gehe einen hauptmenupunkt nach rechts{} CASE 3: gehe einen untermenupunkt nach unten{} CASE 4: gehe einen untermenupunkt nach oben{} CASE 5: fuehre aktuellen menupunkt aus{} CASE 6: hole esc sequenz{} CASE 7: zeige erklaerungstext im menu an{}
+ OTHERWISE werte kuerzeleingabe aus{} END SELECT.{} gehe einen hauptmenupunkt nach links:{} INT VAR anzahl schritte :: 1;{} beende aktuelle untermenuoperationen;{} loesche aktuelles untermenu auf bildschirm;{} loesche alte hauptmenumarkierung;{} anzahl schritte INCR clear buffer and count (""8"");{} ermittle linke menuposition;{} stelle aktuellen hauptmenupunkt invers dar;{} starte aktuelle untermenuoperationen;{} schreibe aktuelles untermenu auf bildschirm.{} gehe einen hauptmenupunkt nach rechts:{}
+ anzahl schritte := 1;{} beende aktuelle untermenuoperationen;{} loesche aktuelles untermenu auf bildschirm;{} loesche alte hauptmenumarkierung;{} anzahl schritte INCR clear buffer and count (""2"");{} ermittle rechte menuposition;{} stelle aktuellen hauptmenupunkt invers dar;{} starte aktuelle untermenuoperationen;{} schreibe aktuelles untermenu auf bildschirm.{} loesche alte hauptmenumarkierung:{} erase invers (area (menuwindow), startpos, 1, ueberschriftlaenge);{}
+ out (area (menuwindow), startpos, 1, ueberschrifttext).{} startpos:{} aktuelles untermenu.anfangsposition.{} ueberschriftlaenge:{} length (ueberschrifttext).{} ueberschrifttext:{} aktuelles untermenu.ueberschrift.{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} ermittle linke menuposition:{} INT VAR positionszaehler;{} FOR positionszaehler FROM 1 UPTO anzahl schritte REP{}
+ drehe die menuposition um einen wert runter{} PER.{} ermittle rechte menuposition:{} FOR positionszaehler FROM 1 UPTO anzahl schritte REP{} drehe die menuposition um einen wert hoch{} PER.{} drehe die menuposition um einen wert runter:{} IF aktuelles menu.hauptmenuzeiger > 1{} THEN aktuelles menu.hauptmenuzeiger DECR 1{} ELSE aktuelles menu.hauptmenuzeiger{} := aktuelles menu.anzahl hauptmenupunkte{} FI.{} drehe die menuposition um einen wert hoch:{}
+ IF aktuelles menu.hauptmenuzeiger{} < aktuelles menu.anzahl hauptmenupunkte{} THEN aktuelles menu.hauptmenuzeiger INCR 1{} ELSE aktuelles menu.hauptmenuzeiger := 1{} FI.{} gehe einen untermenupunkt nach unten:{} INT VAR naechster aktiver := folgender aktiver untermenupunkt;{} nimm ummarkierung vor.{} gehe einen untermenupunkt nach oben:{} naechster aktiver := vorausgehender aktiver untermenupunkt;{} nimm ummarkierung vor.{} nimm ummarkierung vor:{} IF ueberhaupt aktive menupunkte vorhanden{}
+ THEN demarkiere aktuellen untermenupunkt;{} gehe zum folgenden untermenupunkt;{} markiere aktuellen untermenupunkt{} FI.{} ueberhaupt aktive menupunkte vorhanden:{} (aktuelles untermenu.belegt > 0) CAND (naechster aktiver > 0).{} gehe zum folgenden untermenupunkt:{} aktuelles menu.untermenuzeiger := naechster aktiver.{} stelle aktuellen hauptmenupunkt invers dar:{} out invers (area (menuwindow), startpos, 1, ueberschrifttext).{} fuehre aktuellen menupunkt aus:{}
+ IF nur interne verwendung AND mit ausstieg{} THEN kennzeichne als angetickt;{} disable stop;{} do (ausstiegsproc);{} do (menuanweisung);{} aktueller menupunkt.angewaehlt := FALSE;{} IF is error THEN put error; clear error FI;{} enable stop;{} anzahl offener menus DECR 1;{} menuleiste.zeigeraktuell := menuleiste.zeigerhintergrund;{} menuwindow := window (1,1,79, 24);{} nur interne verwendung := FALSE;{}
+ cursor on;{} LEAVE handle menu{} ELSE kennzeichne als angetickt;{} fuehre operation aus (menuanweisung);{} nimm kennzeichnung zurueck{} FI.{} kennzeichne als angetickt:{} aktueller menupunkt.angewaehlt := TRUE;{} markiere aktuellen untermenupunkt.{} nimm kennzeichnung zurueck:{} aktueller menupunkt.angewaehlt := FALSE;{} markiere aktuellen untermenupunkt.{} menuanweisung:{} compress (aktueller menupunkt.procname).{} aktueller menupunkt:{}
+ aktuelles untermenu.menupunkt [aktuelles menu.untermenuzeiger].{} hole esc sequenz:{} TEXT VAR zweites zeichen;{} inchar (zweites zeichen);{} SELECT pos ("q?$", zweites zeichen) OF{} CASE 1: erfrage abbruch{} CASE 2: zeige menubedienhinweise{} CASE 3: gib info aus{} OTHERWISE out (piep){} END SELECT.{} erfrage abbruch:{} IF menuno (infotext [2], 5){} THEN zweites zeichen := "n" (* gleichgültig, nur nicht 'q' *){} FI.{} zeige menubedienhinweise:{}
+ INT VAR gewaehlt;{} REP{} gewaehlt := menualternative ( alttext, altwahl, altzusatz, 5, FALSE);{} erfuelle den wunsch{} UNTIL ausstieg aus bedienhinweisen gewuenscht PER.{} alttext:{} menuleiste.menutext.platz [1].{} altwahl:{} menuleiste.menutext.platz [2].{} altzusatz:{} menuleiste.menutext.platz [3].{} erfuelle den wunsch:{} SELECT gewaehlt OF{} CASE 1,101,106: menuinfo (menuleiste.menutext.platz [4], 5, maxint){} CASE 2,102,107: menuinfo (menuleiste.menutext.platz [5], 5, maxint){}
+ CASE 3,103,108: menuinfo (menuleiste.menutext.platz [6], 5, maxint){} CASE 4,104,109: menuinfo (menuleiste.menutext.platz [7], 5, maxint){} END SELECT.{} ausstieg aus bedienhinweisen gewuenscht:{} gewaehlt = 5 OR gewaehlt = 105 OR gewaehlt = 110.{} gib info aus:{} menuinfo (menuleiste.menutext.platz [20]).{} zeige erklaerungstext im menu an:{} IF compress (erklaerungstext) = ""{} THEN menuinfo (infotext [3]){} ELSE menuinfo (erklaerungstext){} FI.{} erklaerungstext:{}
+ aktueller menupunkt.boxtext.{} werte kuerzeleingabe aus:{} naechster aktiver := pos (kuerzelkette, eingabezeichen);{} nimm ummarkierung vor;{} fuehre aktuellen menupunkt aus.{} starte aktuelle untermenuoperationen:{} ermittle aktuelle kuerzelkette;{} IF startoperation <> ""{} THEN fuehre operation aus (startoperation){} FI.{} startoperation:{} compress (aktuelles untermenu.startprozedurname).{} ermittle aktuelle kuerzelkette:{} kuerzelkette := "";{} INT VAR kuerzelzeiger;{}
+ FOR kuerzelzeiger FROM 1 UPTO aktuelles untermenu.belegt REP{} IF compress (aktuelles punktkuerzel) = ""{} THEN kuerzelkette CAT ""0"" { beliebiger Code der Länge 1 }{} ELSE haenge ggf kuerzel an{} FI{} PER.{} aktuelles punktkuerzel:{} aktuelles untermenu.menupunkt [kuerzelzeiger].punktkuerzel.{} haenge ggf kuerzel an:{} IF betrachteter punkt ist aktiv{} THEN kuerzelkette CAT aktuelles punktkuerzel{} ELSE kuerzelkette CAT ""0""{} FI.{} betrachteter punkt ist aktiv:{}
+ aktuelles untermenu.menupunkt [kuerzelzeiger].aktiv.{} beende aktuelle untermenuoperationen:{} kuerzelkette := "".{}END PROC handle menu;{}PROC oeffne menu (TEXT CONST menuname):{} cursor off;{} suche eingestelltes menu;{} IF menu existiert nicht{} THEN cursor on;{} page;{} errorstop (fehlermeldung [5] + menuname + fehlermeldung [6]){} FI;{} anzahl offener menus INCR 1;{} ggf neue seite aufschlagen;{} ueberpruefe anzahl offener menus;{} lege ggf aktuelles menu auf eis;{}
+ initialisiere den menubildschirm;{} IF NOT nur interne verwendung{} THEN aktuelles menu.hauptmenuzeiger := 1;{} aktuelles menu.untermenuzeiger := 0;{} aktuelles menu.untermenuanfang := 0;{} FI;{} show menu;{} fuehre ggf menueingangsprozedur aus;{} zeige ggf menukenndaten an.{} suche eingestelltes menu:{} INT VAR i, suchzeiger;{} BOOL VAR gefunden :: FALSE;{} FOR i FROM 1 UPTO menuleiste.belegt REP{} IF menuleiste.menu [i].menuname = menuname{}
+ THEN gefunden := TRUE;{} suchzeiger := i;{} FI{} UNTIL menuleiste.menu [i].menuname = menuname PER.{} menu existiert nicht:{} NOT gefunden.{} ueberpruefe anzahl offener menus:{} IF anzahl offener menus > 2{} THEN anzahl offener menus := 0; cursor on;{} errorstop (fehlermeldung [7]){} FI.{} lege ggf aktuelles menu auf eis:{} IF anzahl offener menus = 2{} THEN menuleiste.zeigerhintergrund := menuleiste.zeigeraktuell{} FI;{} menuleiste.zeigeraktuell := suchzeiger.{}
+ initialisiere den menubildschirm:{} IF anzahl offener menus = 2{} THEN menuwindow := window (6, 4, 73, 20){} ELSE menuwindow := window (1, 1, 79, 24);{} FI.{} fuehre ggf menueingangsprozedur aus:{} IF aktuelles menu.menueingangsprozedur <> ""{} THEN fuehre operation aus (aktuelles menu.menueingangsprozedur){} FI.{} ggf neue seite aufschlagen:{} IF anzahl offener menus = 1 THEN page FI.{} zeige ggf menukenndaten an:{} IF anzahl offener menus = 1 AND aktuelles menu.menuinfo <> bleibt leer symbol{}
+ THEN write menunotice (vollstaendiger infotext, 4);{} pause (100);{} erase menunotice{} FI.{} vollstaendiger infotext:{} aktuelles menu.menuinfo +{} aktuelles menu.lizenznummer +{} aktuelles menu.versionsnummer.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{}END PROC oeffne menu;{}PROC show menu:{} ueberpruefe menudaten;{} stelle hauptmenuleiste zusammen;{} zeige hauptmenu an;{} stelle aktuellen hauptmenupunkt invers dar;{} schreibe aktuelles untermenu auf bildschirm;{}
+ zeige informationszeile an.{} ueberpruefe menudaten:{} IF anzahl offener menus = 0{} THEN errorstop (fehlermeldung [8]){} ELIF aktuelles menu.anzahl hauptmenupunkte < 1{} THEN errorstop (fehlermeldung [9]){} FI.{} stelle hauptmenuleiste zusammen:{} TEXT VAR hauptmenuzeile :: "";{} INT VAR zeiger;{} hauptmenuzeile CAT aktuelles menu.menuname;{} hauptmenuzeile CAT ":";{} FOR zeiger FROM 1 UPTO aktuelles menu.anzahl hauptmenupunkte REP{} haenge hauptmenupunkt an{}
+ PER.{} haenge hauptmenupunkt an:{} hauptmenuzeile CAT hauptmenuluecke;{} hauptmenuzeile CAT hauptmenupunktname.{} hauptmenupunktname:{} aktuelles menu.einzelmenu [zeiger].ueberschrift.{} zeige hauptmenu an:{} page (menuwindow, TRUE);{} out menuframe (area (menuwindow));{} cursor (menuwindow, 1, 1);{} out (menuwindow, hauptmenuzeile).{} stelle aktuellen hauptmenupunkt invers dar:{} cursor (menuwindow, startposition, 1);{} out (menuwindow, invers (ueberschrifttext)).{}
+ startposition:{} aktuelles untermenu.anfangsposition - 1.{} ueberschrifttext:{} aktuelles untermenu.ueberschrift.{} zeige informationszeile an:{} write permanent footnote (hinweis [1]).{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC show menu;{}PROC schreibe aktuelles untermenu auf bildschirm:{} ermittle linke obere ecke des untermenukastens;{} wirf untermenu aus;{}
+ show menunotice;{} cursor in warteposition.{} ermittle linke obere ecke des untermenukastens:{} aktuelles menu.untermenuanfang := menumitte - halbe menubreite;{} achte auf randextrema.{} menumitte:{} startposition + (length (ueberschrifttext) DIV 2) - 1.{} startposition:{} aktuelles untermenu.anfangsposition.{} ueberschrifttext:{} aktuelles untermenu.ueberschrift.{} halbe menubreite:{} aktuelles untermenu.maxlaenge DIV 2.{} achte auf randextrema:{} gleiche ggf linken rand aus;{}
+ gleiche ggf rechten rand aus.{} gleiche ggf linken rand aus:{} IF aktuelles menu.untermenuanfang < 4{} THEN aktuelles menu.untermenuanfang := 4{} FI.{} gleiche ggf rechten rand aus:{} IF (aktuelles menu.untermenuanfang + aktuelles untermenu.maxlaenge) >{} (areaxsize (menuwindow) - 3){} THEN aktuelles menu.untermenuanfang{} := areaxsize (menuwindow) - aktuelles untermenu.maxlaenge - 3{} FI.{} wirf untermenu aus:{} IF aktuelles menu.untermenuzeiger = 0{}
+ THEN aktuelles menu.untermenuzeiger := folgender aktiver untermenupunkt{} FI;{} wirf untermenukopfzeile aus;{} wirf untermenurumpf aus;{} wirf untermenufusszeile aus;{} markiere aktuellen untermenupunkt.{} wirf untermenukopfzeile aus:{} cursor (menuwindow, spalte, anfangszeile);{} out (balken oben); striche; out (balken oben).{} wirf untermenufusszeile aus:{} cursor (menuwindow, spalte, endezeile);{} out (ecke unten links); striche; out (ecke unten rechts).{} spalte:{}
+ aktuelles menu.untermenuanfang - 3.{} anfangszeile:{} erste untermenuzeile - 1.{} endezeile:{} erste untermenuzeile + aktuelles untermenu.belegt.{} striche:{} (aktuelles untermenu.maxlaenge + 5) TIMESOUT waagerecht.{} wirf untermenurumpf aus:{} INT VAR laufvar;{} INT CONST aktuelle punktlaenge :: aktuelles untermenu.maxlaenge + 1;{} FOR laufvar FROM 1 UPTO aktuelles untermenu.belegt REP{} wirf eine einzelne menuzeile aus{} PER.{} wirf eine einzelne menuzeile aus:{}
+ out with beam (area (menuwindow), menuspalte, menuzeile,{} aktueller punktname, laenge).{} menuspalte:{} aktuelles menu.untermenuanfang.{} menuzeile:{} erste untermenuzeile + laufvar - 1.{} aktueller punktname:{} untermenubezeichnung (laufvar).{} laenge:{} aktuelle punktlaenge.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC schreibe aktuelles untermenu auf bildschirm;{}
+PROC loesche aktuelles untermenu auf bildschirm:{} beende aktuelle untermenuoperationen;{} loesche untermenu auf bildschirm;{} schreibe balken wieder hin;{} aktuelles menu.untermenuzeiger := 1.{} beende aktuelle untermenuoperationen:{} IF leaveoperation <> ""{} THEN fuehre operation aus (leaveoperation){} FI.{} leaveoperation:{} compress (aktuelles untermenu.leaveprozedurname).{} loesche untermenu auf bildschirm:{} INT VAR laufvar;{} FOR laufvar FROM aktuelles untermenu.belegt + 1 DOWNTO 1 REP{}
+ loesche eine einzelne menuzeile{} PER.{} loesche eine einzelne menuzeile:{} erase with beam (area (menuwindow), menuspalte, menuzeile, laenge).{} menuspalte:{} aktuelles menu.untermenuanfang.{} menuzeile:{} erste untermenuzeile + laufvar - 1.{} laenge:{} aktuelles untermenu.maxlaenge + 1.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{} schreibe balken wieder hin:{}
+ cursor (menuwindow, spalte, anfangszeile);{} (aktuelles untermenu.maxlaenge + 7) TIMESOUT waagerecht.{} spalte:{} aktuelles menu.untermenuanfang - 3.{} anfangszeile:{} erste untermenuzeile - 1.{}END PROC loesche aktuelles untermenu auf bildschirm;{}PROC markiere aktuellen untermenupunkt:{} IF aktuelles menu.untermenuzeiger <> 0{} THEN laufe ggf zum naechsten aktiven menupunkt;{} out invers with beam (area (menuwindow), menuspalte, menuzeile,{} aktueller punktname, laenge){}
+ FI.{} laufe ggf zum naechsten aktiven menupunkt:{} IF NOT aktuelles untermenu.menupunkt [aktuelles menu.untermenuzeiger].aktiv{} THEN aktuelles menu.untermenuzeiger := folgender aktiver untermenupunkt{} FI.{} menuspalte:{} aktuelles menu.untermenuanfang.{} menuzeile:{} erste untermenuzeile - 1 + aktuelles menu.untermenuzeiger.{} aktueller punktname:{} untermenubezeichnung (aktuelles menu.untermenuzeiger).{} laenge:{} aktuelles untermenu.maxlaenge + 1.{} aktuelles menu:{}
+ menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC markiere aktuellen untermenupunkt;{}PROC demarkiere aktuellen untermenupunkt:{} IF aktuelles menu.untermenuzeiger <> 0{} THEN erase invers (area (menuwindow), menuspalte, menuzeile, laenge);{} out (area (menuwindow), menuspalte, menuzeile,{} aktueller punktname, laenge){} FI.{} menuspalte:{} aktuelles menu.untermenuanfang.{}
+ menuzeile:{} erste untermenuzeile - 1 + aktuelles menu.untermenuzeiger.{} aktueller punktname:{} untermenubezeichnung (aktuelles menu.untermenuzeiger).{} laenge:{} aktuelles untermenu.maxlaenge + 1.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC demarkiere aktuellen untermenupunkt;{}INT PROC folgender aktiver untermenupunkt:{} INT VAR anzahl aktiver menupunkte :: 0;{}
+ untersuche anzahl aktiver menupunkte;{} IF kein aktiver menupunkt vorhanden{} THEN 0{} ELIF nur ein aktiver menupunkt vorhanden{} THEN liefere einzigen aktiven menupunkt{} ELSE liefere naechsten aktiven menupunkt{} FI.{} untersuche anzahl aktiver menupunkte:{} INT VAR zaehler, position;{} FOR zaehler FROM 1 UPTO aktuelles untermenu.belegt REP{} IF aktuelles untermenu.menupunkt [zaehler].aktiv{} THEN anzahl aktiver menupunkte INCR 1;{} position := zaehler{}
+ FI{} UNTIL anzahl aktiver menupunkte > 1 PER.{} kein aktiver menupunkt vorhanden:{} anzahl aktiver menupunkte = 0.{} nur ein aktiver menupunkt vorhanden:{} anzahl aktiver menupunkte = 1.{} liefere einzigen aktiven menupunkt:{} position.{} liefere naechsten aktiven menupunkt:{} INT VAR interner zeiger;{} stelle internen zeiger auf den naechsten menupunkt;{} WHILE NOT punkt ist aktiv REP{} untersuche naechsten menupunkt{} PER;{} ergebnis.{} stelle internen zeiger auf den naechsten menupunkt:{}
+ IF aktuelles menu.untermenuzeiger = letzter untermenupunkt{} THEN interner zeiger := 1{} ELSE interner zeiger := aktuelles menu.untermenuzeiger + 1{} FI.{} letzter untermenupunkt:{} aktuelles untermenu.belegt.{} punkt ist aktiv:{} aktuelles untermenu.menupunkt [interner zeiger].aktiv.{} untersuche naechsten menupunkt:{} IF interner zeiger = letzter untermenupunkt{} THEN interner zeiger := 1{} ELSE interner zeiger INCR 1{} FI.{}
+ ergebnis:{} interner zeiger.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC folgender aktiver untermenupunkt;{}INT PROC vorausgehender aktiver untermenupunkt:{} INT VAR anzahl aktiver menupunkte :: 0;{} untersuche anzahl aktiver menupunkte;{} IF kein aktiver menupunkt vorhanden{} THEN 0{} ELIF nur ein aktiver menupunkt vorhanden{} THEN liefere einzigen aktiven menupunkt{}
+ ELSE liefere vorausgehenden aktiven menupunkt{} FI.{} untersuche anzahl aktiver menupunkte:{} INT VAR zaehler, position;{} FOR zaehler FROM 1 UPTO aktuelles untermenu.belegt REP{} IF aktuelles untermenu.menupunkt [zaehler].aktiv{} THEN anzahl aktiver menupunkte INCR 1;{} position := zaehler{} FI{} UNTIL anzahl aktiver menupunkte > 1 PER.{} kein aktiver menupunkt vorhanden:{} anzahl aktiver menupunkte = 0.{} nur ein aktiver menupunkt vorhanden:{} anzahl aktiver menupunkte = 1.{}
+ liefere einzigen aktiven menupunkt:{} position.{} liefere vorausgehenden aktiven menupunkt:{} INT VAR interner zeiger;{} stelle internen zeiger auf vorausgehenden menupunkt;{} WHILE NOT punkt ist aktiv REP{} untersuche vorausgehenden menupunkt{} PER;{} ergebnis.{} stelle internen zeiger auf vorausgehenden menupunkt:{} IF aktuelles menu.untermenuzeiger <= 1{} THEN interner zeiger := letzter untermenupunkt{} ELSE interner zeiger := aktuelles menu.untermenuzeiger - 1{}
+ FI.{} letzter untermenupunkt:{} aktuelles untermenu.belegt.{} punkt ist aktiv:{} aktuelles untermenu.menupunkt [interner zeiger].aktiv.{} untersuche vorausgehenden menupunkt:{} IF interner zeiger = 1{} THEN interner zeiger := letzter untermenupunkt{} ELSE interner zeiger DECR 1{} FI.{} ergebnis:{} interner zeiger.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}
+END PROC vorausgehender aktiver untermenupunkt;{}PROC cursor in warteposition:{} cursor (areax (menuwindow), areay (menuwindow) + 1){}END PROC cursor in warteposition;{}TEXT PROC untermenubezeichnung (INT CONST position):{} TEXT VAR bezeichnung :: "";{} bezeichnung CAT kennzeichnung;{} bezeichnung CAT punktkennung;{} bezeichnung.{} kennzeichnung:{} IF aktueller menupunkt.aktiv{} AND aktueller menupunkt.angewaehlt{} THEN "*"{} ELIF aktueller menupunkt.aktiv{}
+ AND aktueller menupunkt.punktkuerzel <> ""{} THEN aktueller menupunkt.punktkuerzel{} ELIF aktueller menupunkt.aktiv{} AND aktueller menupunkt.punktkuerzel = ""{} THEN blank{} ELSE "-"{} FI.{} punktkennung:{} IF menupunkt ist trennzeile{} THEN strichellinie{} ELSE aktueller menupunkt.punktname{} FI.{} menupunkt ist trennzeile:{} aktueller menupunkt.punktname = (blank + trennzeilensymbol).{} strichellinie:{}
+ (aktuelles untermenu.maxlaenge + 1) * "-".{} aktueller menupunkt:{} aktuelles untermenu.menupunkt [position].{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC untermenubezeichnung;{}PROC fuehre operation aus (TEXT CONST operation):{} disable stop;{} IF operation = ""{} THEN menuinfo (infotext [1]);{} LEAVE fuehre operation aus{} FI;{} do (operation);{}
+ IF is error{} THEN menuinfo (errormessage, 5);{} clear error{} FI;{} old menufootnote;{} enable stop;{} cursor off{}END PROC fuehre operation aus;{}PROC veraendere aktivierung (TEXT CONST unterpunkt, BOOL CONST eintrag):{} INT VAR unterpunktposition :: 0, zeiger;{} suche unterpunkt;{} aendere aktivierung.{} suche unterpunkt:{} FOR zeiger FROM 1 UPTO untermenuende REP{} IF untermenupunkt = blank + compress (unterpunkt){} THEN unterpunktposition := zeiger;{} LEAVE suche unterpunkt{}
+ FI{} PER;{} LEAVE veraendere aktivierung.{} untermenuende:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].belegt.{} untermenupunkt:{} aktuelles untermenu.menupunkt [zeiger].punktname.{} aendere aktivierung:{} aktuelles untermenu.menupunkt [unterpunktposition].aktiv := eintrag.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC veraendere aktivierung;{}
+PROC veraendere aktivierung (INT CONST punktnummer, BOOL CONST eintrag):{} IF punktnummer >= 1 AND punktnummer <= untermenuende{} THEN aktuelles untermenu.menupunkt [punktnummer].aktiv := eintrag{} FI.{} untermenuende:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].belegt.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC veraendere aktivierung;{}PROC veraendere anwahl (TEXT CONST unterpunkt, BOOL CONST eintrag):{}
+ INT VAR unterpunktposition :: 0, zeiger;{} suche unterpunkt;{} aendere anwahl.{} suche unterpunkt:{} FOR zeiger FROM 1 UPTO untermenuende REP{} IF untermenupunkt = blank + compress (unterpunkt){} THEN unterpunktposition := zeiger;{} LEAVE suche unterpunkt{} FI{} PER;{} enable stop;{} errorstop (fehlermeldung [10]).{} untermenuende:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].belegt.{} untermenupunkt:{} aktuelles untermenu.menupunkt [zeiger].punktname.{}
+ aendere anwahl:{} aktuelles untermenu.menupunkt [unterpunktposition].angewaehlt := eintrag.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{} aktuelles untermenu:{} aktuelles menu.einzelmenu [aktuelles menu.hauptmenuzeiger].{}END PROC veraendere anwahl;{}PROC activate (TEXT CONST unterpunkt):{} enable stop;{} veraendere aktivierung (unterpunkt, TRUE){}END PROC activate;{}PROC activate (INT CONST punktnummer):{} enable stop;{} veraendere aktivierung (punktnummer, TRUE){}
+END PROC activate;{}PROC deactivate (TEXT CONST unterpunkt):{} enable stop;{} veraendere aktivierung (unterpunkt, FALSE){}END PROC deactivate;{}PROC deactivate (INT CONST punktnummer):{} enable stop;{} veraendere aktivierung (punktnummer, FALSE){}END PROC deactivate;{}PROC select (TEXT CONST unterpunkt):{} enable stop;{} veraendere anwahl (unterpunkt, TRUE){}END PROC select;{}PROC deselect (TEXT CONST unterpunkt):{} enable stop;{} veraendere anwahl (unterpunkt, FALSE){}END PROC deselect;{}
+PROC schliesse menu:{} IF aktuelles menu.menuausgangsprozedur <> ""{} THEN menufootnote (hinweis [3]);{} fuehre operation aus (aktuelles menu.menuausgangsprozedur){} FI;{} anzahl offener menus DECR 1;{} IF anzahl offener menus = 1{} THEN aktiviere das auf eis gelegte menu{} FI.{} aktiviere das auf eis gelegte menu:{} menuleiste.zeigeraktuell := menuleiste.zeigerhintergrund;{} menuwindow := window (1, 1, 79, 24);{} show menu.{} aktuelles menu:{} menuleiste.menu [menuleiste.zeigeraktuell].{}
+END PROC schliesse menu;{}PROC refresh submenu:{} schreibe aktuelles untermenu auf bildschirm;{} show menunotice;{}END PROC refresh submenu;{}PROC regenerate menuscreen:{} IF anzahl offener menus = 0{} THEN errorstop (fehlermeldung [8]){} ELIF anzahl offener menus = 1{} THEN page;{} show menu;{} show menunotice{} ELSE zeige erstes menu an;{} zeige zweites menu an;{} show menunotice{} FI.{} zeige erstes menu an:{} INT VAR menuzeiger :: menuleiste.zeigeraktuell;{}
+ menuleiste.zeigeraktuell := menuleiste.zeigerhintergrund;{} menuwindow := window (1, 1, 79, 24);{} anzahl offener menus := 1;{} show menu.{} zeige zweites menu an:{} menuleiste.zeigeraktuell := menuzeiger;{} menuwindow := window (6, 4, 73, 20);{} anzahl offener menus := 2;{} show menu.{}END PROC regenerate menuscreen;{}PROC menuinfo (TEXT CONST t, INT CONST position, timelimit):{} boxinfo (menuwindow, t, position, timelimit, FALSE);{} schreibe aktuelles untermenu auf bildschirm;{}
+ old menufootnote{}END PROC menuinfo;{}PROC menuinfo (TEXT CONST t, INT CONST position):{} menuinfo (t, position, maxint){}END PROC menuinfo;{}PROC menuinfo (TEXT CONST t):{} menuinfo (t, 5, maxint){}END PROC menuinfo;{}INT PROC menualternative (TEXT CONST t, auswahlliste, zusatztasten,{} INT CONST position, BOOL CONST mit abbruch):{} INT VAR ergebnis := boxalternative (menuwindow, t, auswahlliste,{} zusatztasten, position, mit abbruch, FALSE);{}
+ schreibe aktuelles untermenu auf bildschirm;{} old menufootnote;{} ergebnis{}END PROC menualternative;{}BOOL PROC menuyes (TEXT CONST frage, INT CONST position):{} BOOL VAR wert := boxyes (menuwindow, frage, position, FALSE);{} schreibe aktuelles untermenu auf bildschirm;{} old menufootnote;{} wert{}END PROC menuyes;{}BOOL PROC menuno (TEXT CONST frage, INT CONST position):{} NOT menuyes (frage, position){}END PROC menuno;{}TEXT PROC menuone (THESAURUS CONST thes, TEXT CONST t1, t2,{} BOOL CONST mit reinigung):{}
+ TEXT CONST wert :: boxone (menuwindow, thes, t1, t2, mit reinigung);{} IF mit reinigung{} THEN schreibe aktuelles untermenu auf bildschirm;{} old menufootnote{} FI;{} wert{}END PROC menuone;{}THESAURUS PROC menusome (THESAURUS CONST thes, TEXT CONST t1, t2,{} BOOL CONST mit reinigung):{} THESAURUS CONST thesaurus :: boxsome (menuwindow, thes, t1, t2,{} mit reinigung);{} IF mit reinigung{} THEN schreibe aktuelles untermenu auf bildschirm;{}
+ old menufootnote{} FI;{} thesaurus{}END PROC menusome;{}TEXT PROC menuanswer (TEXT CONST t, vorgabe, INT CONST position):{} TEXT VAR wert :: boxanswer (menuwindow, t, vorgabe, position, FALSE);{} schreibe aktuelles untermenu auf bildschirm;{} old menufootnote;{} wert{}END PROC menuanswer;{}TEXT PROC menuanswerone (TEXT CONST t, vorgabe, THESAURUS CONST thes,{} TEXT CONST t1, t2, BOOL CONST mit reinigung):{} TEXT VAR wert :: boxanswerone (menuwindow, t, vorgabe, thes, t1, t2,{}
+ mit reinigung, FALSE){} IF mit reinigung{} THEN schreibe aktuelles untermenu auf bildschirm;{} old menufootnote{} FI;{} wert{}END PROC menuanswer one;{}THESAURUS PROC menuanswersome (TEXT CONST t, vorgabe, THESAURUS CONST thes,{} TEXT CONST t1, t2, BOOL CONST mit reinigung):{} THESAURUS VAR wert :: boxanswersome (menuwindow, t, vorgabe,{} thes, t1, t2, mit reinigung, FALSE){}
+ IF mit reinigung{} THEN schreibe aktuelles untermenu auf bildschirm;{} old menufootnote{} FI;{} wert{}END PROC menuanswersome;{}PROC menufootnote (TEXT CONST t):{} cursor (menuwindow, 1, areaysize (menuwindow) - 1);{} areaxsize (menuwindow) TIMESOUT waagerecht;{} cursor (menuwindow, 1, areaysize (menuwindow));{} outtext (t, 1, areaxsize (menuwindow)){}END PROC menufootnote;{}PROC old menufootnote:{} menufootnote (permanent footnote){}END PROC old menufootnote;{}TEXT PROC menubasistext (INT CONST nummer):{}
+ IF nummer <= 20{} THEN fehlermeldung [12]{} ELIF nummer > menuleiste.menutext.anzahl menutexte{} THEN fehlermeldung [11]{} ELSE menuleiste.menutext.platz [nummer]{} FI{}END PROC menubasistext;{}TEXT PROC anwendungstext (INT CONST nummer):{} IF nummer > menuleiste.infotext.anzahl infotexte{} THEN fehlermeldung [11]{} ELSE menuleiste.infotext.stelle [nummer]{} FI{}END PROC anwendungstext;{}PROC zeige menukennung:{} IF anzahl offener menus = 0{} THEN zeige angaben und emblem;{}
+ FI.{} zeige angaben und emblem:{} ROW 5 WINDOW VAR w;{} w [ 1] := window (40, 3, 30, 9);{} w [ 2] := window (36, 5, 30, 9);{} w [ 3] := window (30, 7, 30, 9);{} w [ 4] := window (22, 9, 30, 9);{} w [ 5] := window (12, 11, 30, 9);{} page;{} show (w [1]); out (w [1], center (w [1], invers (systemkuerzel)));{} show (w [2]); out (w [2], " Version " + versionsnummer);{} show (w [3]); out (w [3], copyright1);{} show (w [4]); out (w [4], copyright2);{} show (w [5]);{}
+ cursor (w [5], 1, 2);out (w [5], " lll sssssssss ");{} cursor (w [5], 1, 3);out (w [5], " lll sss sss ");{} cursor (w [5], 1, 4);out (w [5], " lll sss ");{} cursor (w [5], 1, 5);out (w [5], " lll sssssssss ");{} cursor (w [5], 1, 6);out (w [5], " lll sss ");{} cursor (w [5], 1, 7);out (w [5], " lll latta soft sss ");{} cursor (w [5], 1, 8);out (w [5], " lllllllll sssssssss ");{} cursor (79, 24);{}
+ zeitpunkt := clock (1);{}END PROC zeige menukennung;{}PROC reset dialog:{} angekoppelte menutafel := "";{} anzahl offener menus := 0{}END PROC reset dialog;{}PROC write permanent footnote (TEXT CONST t):{} permanent footnote := t;{} cursor (menuwindow, 1, areaysize (menuwindow));{} outtext (t, 1, areaxsize (menuwindow)){}END PROC write permanent footnote;{}PROC write menunotice (TEXT CONST t, INT CONST position):{} erase menunotice;{} boxnotice (menuwindow, t, position, menunotizx, menunotizy,{}
+ menunotizxsize, menunotizysize);{} menunotiztext := t;{} menunotizposition := position;{} menunotiz ist gesetzt := TRUE{}END PROC write menunotice;{}PROC show menunotice:{} IF menunotiz ist gesetzt{} THEN boxnotice (menuwindow, menunotiztext, menunotizposition,{} menunotizx, menunotizy, menunotizxsize, menunotizysize);{} FI{}END PROC show menunotice;{}PROC erase menunotice:{} INT VAR spa, zei;{} get cursor (spa, zei);{}
+ IF menunotiz ist gesetzt{} THEN page up (menunotizx, menunotizy, menunotizxsize, menunotizysize);{} menunotiz ist gesetzt := FALSE;{} cursor (spa, zei){} FI{}END PROC erase menunotice;{}PROC initialize menuwindow:{} schreibfenster := window (areax (menuwindow) + 1,{} areay (menuwindow) + 3,{} areaxsize (menuwindow) - 2,{} areaysize (menuwindow) - 4){}END PROC initialize menuwindow;{}
+PROC show menuwindow:{} initialize menuwindow;{} show (schreibfenster);{}END PROC show menuwindow;{}PROC menuwindow page:{} initialize menuwindow;{} page (schreibfenster){}END PROC menuwindow page;{}PROC menuwindowout (TEXT CONST text):{} out (schreibfenster, text){}END PROC menuwindow out;{}PROC menuwindowget (TEXT VAR text):{} get (schreibfenster, text){}END PROC menuwindowget;{}PROC menuwindoweditget (TEXT VAR text):{} editget (schreibfenster, text){}END PROC menuwindoweditget;{}PROC menuwindowedit (TEXT CONST dateiname):{}
+ initialize menuwindow;{} edit (schreibfenster, dateiname){}END PROC menuwindowedit;{}PROC menuwindowedit (FILE VAR f):{} initialize menuwindow;{} edit (schreibfenster, f){}END PROC menuwindowedit;{}PROC menuwindowshow (TEXT CONST dateiname):{} initialize menuwindow;{} show (schreibfenster, dateiname){}END PROC menuwindowshow;{}PROC menuwindowshow (FILE VAR f):{} initialize menuwindow;{} show (schreibfenster, f){}END PROC menuwindowshow;{}BOOL PROC menuwindowyes (TEXT CONST frage):{} yes (schreibfenster, frage){}
+END PROC menuwindowyes;{}BOOL PROC menuwindowno (TEXT CONST frage):{} no (schreibfenster, frage){}END PROC menuwindowno;{}PROC menuwindowline:{} menuwindowline (1){}END PROC menuwindowline;{}PROC menuwindowline (INT CONST anzahl):{} line (schreibfenster, anzahl){}END PROC menuwindowline;{}PROC menuwindowcursor (INT CONST spa, zei):{} cursor (schreibfenster, spa, zei){}END PROC menuwindowcursor;{}PROC get menuwindowcursor (INT VAR spa, zei):{} get cursor (schreibfenster, spa, zei){}END PROC get menuwindowcursor;{}
+INT PROC remaining menuwindowlines:{} remaining lines (schreibfenster){}END PROC remaining menuwindowlines;{}TEXT PROC menuwindowcenter (TEXT CONST t):{} center (schreibfenster, t){}END PROC menuwindowcenter;{}PROC menuwindowstop:{} menuwindowstop (2){}END PROC menuwindowstop;{}PROC menuwindowstop (INT CONST anzahl):{} stop (schreibfenster, anzahl){}END PROC menuwindowstop;{}WINDOW PROC current menuwindow:{} initialize menuwindow;{} schreibfenster{}END PROC current menuwindow;{}PROC stdinfoedit (FILE VAR f, INT CONST oberste zeile):{}
+ IF oberste zeile < 1 OR oberste zeile > 3{} THEN errorstop (fehlermeldung [13]);{} FI;{} garantiere menukarte;{} cursor (1, oberste zeile); out (cleop);{} cursor (1, 23); out(79 * waagerecht);{} cursor (1, 24); outtext (menubasistext (141), 1, 79);{} editorinfofenster := window (1, oberste zeile + 1, 79, 24 - oberste zeile);{} kommando auf taste legen ("?", "editorinformationen");{} command dialogue (FALSE);{} cursor on; edit (f, 1, oberste zeile, 79, 23 - oberste zeile);{} command dialogue (TRUE);{}
+ kommando auf taste legen ("?", "").{} garantiere menukarte:{} TEXT VAR name := compress (menukartenname);{} IF name = ""{} THEN install menu (stdmenukartenname, FALSE){} FI.{}END PROC stdinfoedit;{}PROC stdinfoedit (FILE VAR f):{} stdinfoedit (f, 1){}END PROC stdinfoedit;{}PROC stdinfoedit (TEXT CONST dateiname, INT CONST oberste zeile):{} FILE VAR f :: sequential file (modify, dateiname);{} stdinfoedit (f, oberste zeile);{}END PROC stdinfoedit;{}PROC stdinfoedit (TEXT CONST dateiname):{}
+ stdinfoedit (dateiname, 1){}END PROC stdinfoedit;{}PROC editorinformationen:{} BOOL VAR ende gewuenscht :: FALSE; INT VAR z;{} FOR z FROM startwert UPTO 22 REP{} cursor (1, z); out (cleol);{} PER;{} REP{} INT VAR erg := boxalternative (editorinfofenster,{} menubasistext (149),{} menubasistext (150),{} menubasistext (151),{} 5, FALSE, FALSE);{} erfuelle den wunsch{}
+ UNTIL ende gewuenscht PER;{} cursor (2, 23); 77 TIMESOUT waagerecht;{} cursor (1, 24); outtext (menubasistext (141), 1, 79).{} startwert:{} areay (editorinfofenster) + 1.{} erfuelle den wunsch:{} SELECT erg OF{} CASE 1, 101, 109: boxinfo (editorinfofenster, menubasistext (142), 5, maxint, FALSE){} CASE 2, 102, 110: boxinfo (editorinfofenster, menubasistext (143), 5, maxint, FALSE){} CASE 3, 103, 111: boxinfo (editorinfofenster, menubasistext (144), 5, maxint, FALSE){} CASE 4, 104, 112: boxinfo (editorinfofenster, menubasistext (145), 5, maxint, FALSE){}
+ CASE 5, 105, 113: boxinfo (editorinfofenster, menubasistext (146), 5, maxint, FALSE){} CASE 6, 106, 114: boxinfo (editorinfofenster, menubasistext (147), 5, maxint, FALSE){} CASE 7, 107, 115: boxinfo (editorinfofenster, menubasistext (148), 5, maxint, FALSE){} CASE 8, 108, 116: ende gewuenscht := TRUE{} OTHERWISE (*tue nichts*){} END SELECT{}END PROC editorinformationen;{}PROC bereinige situation:{} page;{} forget (ds);{} reset dialog{}END PROC bereinige situation;{}
+PROC direktstart (TEXT CONST procname, BOOL CONST autoloeschen):{} TEXT VAR datname := "Selbststartergenerierungsdatei", letzter := std;{} kopple archivmenukarte an;{} schreibe programm;{} insertiere programm;{} abkoppeln.{} kopple archivmenukarte an:{} install menu (stdmenukartenname, FALSE).{} schreibe programm:{} forget (datname, quiet);{} FILE VAR f :: sequential file (output, datname);{} putline (f, menubasistext (191));{} putline (f, "do (""reset dialog; erase menunotice; " + procname + """);");{}
+ putline (f, menubasistext (192));{} IF autoloeschen{} THEN putline (f, menubasistext (193)){} ELSE putline (f, menubasistext (194)){} FI;{} putline (f, menubasistext (195));{} putline (f, menubasistext (196)).{} insertiere programm:{} TEXT VAR t := "insert (""" + datname + """)"; do (t).{} abkoppeln:{} forget (datname, quiet); last param (letzter);{} reset dialog;{} global manager.{}END PROC direktstart;{}END PACKET ls dialog 5;{}
+
diff --git a/dialog/ls-DIALOG 6 b/dialog/ls-DIALOG 6
new file mode 100644
index 0000000..b27eae2
--- /dev/null
+++ b/dialog/ls-DIALOG 6
@@ -0,0 +1,102 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG 6 **
+ ** Archiv-/Taskhandling **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+PACKET ls dialog 6 DEFINES{} menu archiv notizort setzen,{} menu archiv grundeinstellung,{} menu archiv zieltask einstellen,{} menu archiv zieltask aendern,{} menu archiv reservieren,{} menu archiv neue diskette,{} menu archiv schreiben,{} menu archiv checken,{} menu archiv schreibcheck,{} menu archiv holen,{} menu archiv loeschen,{} menu archiv verzeichnis,{} menu archiv verzeichnis drucken,{} menu archiv initialisieren,{}
+ menu archiv reservierung aufgeben,{} archiv:{}LET menukartenname = "ls-MENUKARTE:Archiv";{}LET ack = 0,{} schreiben = 1,{} checken = 2,{} schreibcheck = 3,{} holen = 4,{} loeschen = 5,{} list code = 15,{} reserve code = 19;{}BOOL VAR zieltask ist archivmanager :: TRUE,{} archiv gehoert mir :: FALSE,{} fehlerfall :: FALSE,{} kontakt mit zieltask erfolgt :: FALSE;{}
+TEXT VAR zieltaskname :: "ARCHIVE",{} aktueller archivname :: "";{}INT VAR stationsnummer :: station (myself),{} letzte funktion :: 11,{} notizort :: 3;{}PROC archiv:{} install menu (menukartenname, FALSE);{} handle menu ("ARCHIV"){}END PROC archiv;{}PROC melde zieltaskerror (TEXT CONST meldung):{} IF meldung = menubasistext (47){} THEN menuinfo (menubasistext (123)){} ELIF meldung = menubasistext (46){}
+ THEN menuinfo (menubasistext (124)){} ELIF pos (meldung, "inkonsistent") > 0{} THEN menuinfo (menubasistext (125)){} ELIF pos (meldung, "Lesen unmoeglich") > 0{} COR pos (meldung, "Schreiben unmoeglich") > 0{} THEN menuinfo (menubasistext (126)){} ELIF pos (meldung, "Archiv heisst") > 0 AND pos (meldung, "?????") > 0{} THEN menuinfo (menubasistext (127)){} ELIF pos (meldung, "Archiv heisst") > 0{} THEN menuinfo (menubasistext (128)){} ELIF pos (meldung, "Schreibfehler") > 0 CAND pos (meldung, "Archiv") > 0{}
+ THEN menuinfo (menubasistext (129)){} ELIF pos (meldung, "Lesefehler") > 0{} THEN menuinfo (menubasistext (130)){} ELIF pos (meldung, "Kommando") > 0 AND pos (meldung, "unbekannt") > 0{} THEN menuinfo (menubasistext (131)){} ELIF pos (meldung, "falscher Auftrag fuer Task") > 0{} THEN menuinfo (menubasistext (132)){} ELIF meldung = menubasistext (41){} THEN menuinfo (menubasistext (133)){} ELIF meldung = menubasistext (42){} THEN menuinfo (menubasistext (134)){}
+ ELIF pos (meldung, "Collector") > 0 AND pos(meldung, "fehlt") > 0{} THEN menuinfo (menubasistext (135)){} ELIF pos (meldung, "kein Zugriffsrecht auf Task") > 0{} THEN menuinfo (menubasistext (132)){} ELIF pos (meldung, "nicht initialisiert") > 0{} THEN menuinfo (menubasistext (136)){} ELIF pos (meldung, "ungueltiger Format-Code") > 0{} THEN menuinfo (menubasistext (137)){} ELSE menuinfo (invers (meldung)){} FI{}END PROC melde zieltaskerror;{}PROC menu archiv notizort setzen (INT CONST wert):{}
+ SELECT wert OF{} CASE 1,2,3,4,5 : notizort := wert{} OTHERWISE notizort := 3{} END SELECT{}END PROC menu archiv notizort setzen;{}PROC menu archiv grundeinstellung (INT CONST ort):{} menu archiv zieltask aendern ("ARCHIVE", station (myself), TRUE);{} menu archiv notizort setzen (ort);{} zieltask anzeigen{}END PROC menu archiv grundeinstellung;{}PROC menu archiv zieltask einstellen:{} TEXT VAR taskname :: "";{} INT VAR stationsnr, auswahl;{} BOOL VAR ist amanager;{} erfrage daten;{}
+ kontrolliere daten;{} menu archiv zieltask aendern (taskname, stationsnr, ist amanager);{} refresh submenu;{} zieltask anzeigen.{} erfrage daten:{} auswahl := menualternative (menubasistext (51), menubasistext (52),{} menubasistext (53), 5, TRUE);{} SELECT auswahl OF{} CASE 1, 101 : menu archiv zieltask aendern{} ("ARCHIVE", station (myself), TRUE );{} ausstieg{} CASE 2, 102 : menu archiv zieltask aendern{}
+ (name (father), station (myself), FALSE);{} ausstieg{} CASE 3, 103 : menu archiv zieltask aendern{} ("PUBLIC", station (myself), FALSE);{} ausstieg{} CASE 4, 104 : handeinstellung{} OTHERWISE ausstieg{} END SELECT.{} ausstieg:{} refresh submenu;{} zieltask anzeigen;{} LEAVE menu archiv zieltask einstellen.{} handeinstellung:{} taskname := menuanswer (menubasistext (81), zieltaskname, 5);{}
+ stationsnr := int (menuanswer (menubasistext (82),{} text (station (myself)), 5));{} ist amanager := menuyes (menubasistext (83), 5).{} kontrolliere daten:{} IF compress (taskname) = ""{} OR compress (taskname) = "-"{} OR taskname = name (myself){} THEN menuinfo (menubasistext (64));{} LEAVE menu archiv zieltask einstellen{} FI.{}END PROC menu archiv zieltask einstellen;{}PROC menu archiv zieltask aendern (TEXT CONST taskname,{}
+ INT CONST stationsnr,{} BOOL CONST ist archivmanager):{} menufootnote (menubasistext (21) + menubasistext (23));{} gib ggf archiv frei;{} IF ist archivmanager{} THEN archivmanager einstellen{} ELSE sonstige task einstellen{} FI;{} aktiviere gueltige archivmenupunkte.{} gib ggf archiv frei:{} IF archiv gehoert mir{} THEN archivreservierung aufgeben{} FI.{} archivmanager einstellen:{} zieltask ist archivmanager := TRUE;{}
+ zieltaskname := taskname;{} stationsnummer := stationsnr;{} kontakt mit zieltask erfolgt := FALSE;{} aktueller archivname := "";{} archiv gehoert mir := FALSE;{} letzte funktion := 11.{} sonstige task einstellen:{} zieltask ist archivmanager := FALSE;{} zieltaskname := taskname;{} stationsnummer := stationsnr;{} aktueller archivname := "";{} archiv gehoert mir := FALSE;{}
+ letzte funktion := 6.{}END PROC menu archiv zieltask aendern;{}PROC menu archiv reservieren:{} TEXT VAR archivname :: "", meldung :: "";{} kontrolliere einstellung;{} menufootnote (menubasistext (21) + menubasistext (24));{} versuche archiv zu reservieren (meldung);{} werte meldung aus;{} archiv anmelden (archivname, meldung, TRUE);{} IF archivname = ""{} THEN behandle archivfehler{} ELSE aktueller archivname := archivname{} FI;{} aktiviere gueltige archivmenupunkte;{}
+ refresh submenu;{} zieltask anzeigen.{} kontrolliere einstellung:{} IF NOT zieltask ist archivmanager{} THEN aktiviere gueltige archivmenupunkte;{} refresh submenu;{} LEAVE menu archiv reservieren{} ELIF NOT kontakt mit zieltask erfolgt{} THEN versuche kontakt herzustellen{} FI.{} versuche kontakt herzustellen:{} TEXT VAR fehler :: "";{} IF NOT task ist kommunikativ (fehler){} THEN melde zieltaskerror (fehler);{} melde rigoros ab;{}
+ LEAVE menu archiv reservieren{} ELSE kontakt mit zieltask erfolgt := TRUE{} FI.{} werte meldung aus:{} IF meldung <> ""{} THEN melde zieltaskerror (meldung);{} melde rigoros ab;{} LEAVE menu archiv reservieren{} FI.{} behandle archivfehler:{} melde zieltaskerror (meldung);{} archivreservierung aufgeben;{} melde rigoros ab{}END PROC menu archiv reservieren;{}PROC melde rigoros ab:{} aktueller archivname := "";{} archiv gehoert mir := FALSE;{}
+ kontakt mit zieltask erfolgt := FALSE{}END PROC melde rigoros ab;{}PROC versuche archiv zu reservieren (TEXT VAR fehler):{} IF NOT kontakt mit zieltask erfolgt{} THEN fehler := menubasistext (44);{} archiv gehoert mir := FALSE;{} LEAVE versuche archiv zu reservieren{} FI;{} disable stop;{} IF eigene station{} THEN reserve ("beknackter archivename",/zieltaskname ){} ELSE reserve ("beknackter archivename", stationsnummer/zieltaskname){} FI;{} IF is error{} THEN fehler := errormessage;{}
+ melde rigoros ab;{} clear error{} ELSE archiv gehoert mir := TRUE;{} fehler := "";{} FI;{} enable stop{}END PROC versuche archiv zu reservieren;{}PROC archiv anmelden (TEXT VAR archivname, fehler, BOOL CONST mit anfrage):{} ueberpruefe archivbesitz;{} fuehre archivanmeldung aus.{} ueberpruefe archivbesitz:{} IF NOT archiv gehoert mir OR NOT kontakt mit zieltask erfolgt{} THEN fehler := menubasistext (45);{} melde rigoros ab;{} LEAVE archiv anmelden{}
+ FI.{} fuehre archivanmeldung aus:{} IF mit anfrage{} THEN frage nach eingelegter diskette und melde an{} ELSE melde archiv unter richtigem namen an{} FI.{} frage nach eingelegter diskette und melde an:{} IF menuyes (menubasistext (84), 5){} THEN menufootnote (menubasistext (21) + menubasistext (25));{} melde archiv unter richtigem namen an{} ELSE fehler := menubasistext (46);{} aktueller archivname := "";{} LEAVE archiv anmelden{}
+ FI.{} melde archiv unter richtigem namen an:{} disable stop;{} IF eigene station{} THEN reserve ("beknackter archivename",/zieltaskname);{} list (/zieltaskname);{} ELSE reserve ("beknackter archivename", stationsnummer/zieltaskname);{} list (stationsnummer/zieltaskname){} FI;{} IF is error{} THEN fehler := errormessage;{} behandle die fehlermeldung{} ELSE archivname := "beknackter archivename";{} fehler := "";{} enable stop{}
+ FI.{} behandle die fehlermeldung:{} IF subtext (fehler, 1, 14) = menubasistext (61){} CAND subtext (fehler, 16, 20) <> menubasistext (62){} THEN clear error; enable stop;{} archivname := subtext (fehler, 16, length (fehler) - 1);{} melde archiv nun wirklich richtig an;{} fehler := "";{} enable stop{} ELIF subtext (fehler, 1, 14) = menubasistext (61){} CAND subtext (fehler, 16, 20) = menubasistext (62){} THEN clear error; enable stop;{}
+ archivname := "";{} fehler := menubasistext (62){} ELSE clear error; enable stop;{} archivname := ""{} FI.{} melde archiv nun wirklich richtig an:{} IF eigene station{} THEN reserve (archivname,/zieltaskname);{} ELSE reserve (archivname, stationsnummer/zieltaskname){} FI.{}END PROC archiv anmelden;{}PROC menu archiv neue diskette:{} ueberpruefe reservierung;{} melde neue diskette an.{} ueberpruefe reservierung:{} IF NOT (archiv gehoert mir AND kontakt mit zieltask erfolgt){}
+ THEN melde zieltaskerror (menubasistext (47));{} LEAVE menu archiv neue diskette{} FI.{} melde neue diskette an:{} TEXT VAR archivname :: "", meldung :: "";{} menufootnote (menubasistext (21) + menubasistext (26));{} archiv anmelden (archivname, meldung, FALSE);{} IF archivname = ""{} THEN behandle archivfehler{} ELSE aktueller archivname := archivname{} FI;{} zieltask anzeigen.{} behandle archivfehler:{} melde zieltaskerror (meldung);{} aktueller archivname := "".{}
+END PROC menu archiv neue diskette;{}PROC menu archiv schreiben:{} dateioperation mit zieltask (schreiben);{} regenerate menuscreen{}END PROC menu archiv schreiben;{}PROC menu archiv checken:{} dateioperation mit zieltask (checken);{} regenerate menuscreen{}END PROC menu archiv checken;{}PROC menu archiv schreibcheck:{} dateioperation mit zieltask (schreibcheck);{} regenerate menuscreen{}END PROC menu archiv schreibcheck;{}PROC menu archiv holen:{} dateioperation mit zieltask (holen);{} regenerate menuscreen{}
+END PROC menu archiv holen;{}PROC menu archiv loeschen:{} dateioperation mit zieltask (loeschen);{} regenerate menuscreen{}END PROC menu archiv loeschen;{}PROC dateioperation mit zieltask (INT CONST wahl):{} ueberpruefe kommunikationsbasis und sinnhaftigkeit;{} lasse dateien auswaehlen;{} operiere mit ausgewaehlten dateien.{} ueberpruefe kommunikationsbasis und sinnhaftigkeit:{} IF unzulaessiger zieltaskname{} THEN LEAVE dateioperation mit zieltask{} ELIF zieltaskname = name (myself){}
+ THEN melde zieltaskerror (menubasistext (48));{} LEAVE dateioperation mit zieltask{} ELIF zieltask ist archivmanager AND NOT archiv gehoert mir{} THEN melde zieltaskerror (menubasistext (47));{} LEAVE dateioperation mit zieltask{} ELIF NOT zieltask ist archivmanager{} AND (wahl = checken OR wahl = schreibcheck){} THEN gib hinweis auf unmoeglich;{} LEAVE dateioperation mit zieltask{} ELIF NOT zieltask ist archivmanager{}
+ THEN stelle kontakt mit zieltask her{} ELIF wahl < schreiben OR wahl > loeschen{} THEN LEAVE dateioperation mit zieltask{} FI.{} stelle kontakt mit zieltask her:{} TEXT VAR fehler :: "";{} IF task ist kommunikativ (fehler){} THEN kontakt mit zieltask erfolgt := TRUE{} ELSE melde zieltaskerror (fehler);{} LEAVE dateioperation mit zieltask{} FI.{} gib hinweis auf unmoeglich:{} menuinfo (menubasistext (121) + taskname + menubasistext (122)).{}
+ taskname:{} IF eigene station{} THEN zieltaskname{} ELSE text (stationsnummer) + "/" + zieltaskname{} FI.{} lasse dateien auswaehlen:{} THESAURUS VAR angekreuzte;{} disable stop;{} IF wahl = schreiben OR wahl = schreibcheck{} THEN angekreuzte := menusome (ALL myself, operationshinweis,{} ankreuzhinweis, FALSE){} ELSE angekreuzte := menusome (zieltaskthesaurus, operationshinweis,{} ankreuzhinweis, FALSE){}
+ FI;{} fehlerbehandlung.{} zieltaskthesaurus:{} IF eigene station{} THEN ALL /zieltaskname{} ELSE ALL (stationsnummer/zieltaskname){} FI.{} ankreuzhinweis:{} menubasistext (91) + operationskennzeichnung (wahl) + menubasistext (92).{} operationshinweis:{} operationsbezeichnung (wahl) + zieltaskhinweis.{} operiere mit ausgewaehlten dateien:{} bereite bildschirm vor;{} steige ggf bei leerem thesaurus aus;{} IF wahl = schreiben OR wahl = schreibcheck{} THEN zuerst loeschen{}
+ FI;{} IF wahl = schreibcheck{} THEN fehlerfall := FALSE;{} dateioperation ausfuehren (angekreuzte, schreiben, FALSE);{} IF NOT fehlerfall{} THEN dateioperation ausfuehren (angekreuzte, checken, TRUE){} FI{} ELSE dateioperation ausfuehren (angekreuzte, wahl, TRUE){} FI.{} bereite bildschirm vor:{} show menuwindow.{} steige ggf bei leerem thesaurus aus:{} IF NOT not empty (angekreuzte){} THEN menuwindowline (2);{} menuwindowout (menubasistext (94));{}
+ menuwindowstop;{} LEAVE dateioperation mit zieltask{} FI.{} zuerst loeschen:{} menuwindowout (menuwindowcenter (menubasistext (21) + menubasistext (31)));{} menuwindowline;{} IF not empty (angekreuzte){} THEN disable stop;{} THESAURUS CONST zu loeschende ::{} angekreuzte / zieltaskthesaurus;{} fehlerbehandlung;{} biete ggf dateien zum loeschen an{} ELSE menuwindowpage{} FI.{} biete ggf dateien zum loeschen an:{}
+ IF not empty (zu loeschende){} THEN menuwindowout (menuwindowcenter (invers (menubasistext (108))));{} menuwindowline;{} menuwindowout (menuwindowcenter (menubasistext (109)));{} menuwindowline (2);{} dateien rausschmeissen{} ELSE menuwindowpage{} FI.{} dateien rausschmeissen:{} command dialogue (FALSE);{} biete dateien einzeln zum loeschen an;{} menuwindowpage;{} command dialogue (TRUE).{} biete dateien einzeln zum loeschen an:{}
+ INT VAR z, index;{} FOR z FROM 1 UPTO highest entry (zu loeschende) REP{} disable stop;{} IF name (zu loeschende, z) <> ""{} THEN stelle frage und fuehre aus{} FI;{} fehlerbehandlung{} PER.{} stelle frage und fuehre aus:{} IF menuwindowyes ("'" + name (zu loeschende, z) + "' "{} + menubasistext (111)){} THEN erase (name (zu loeschende, z), task (zieltaskname)){} ELSE menuwindowout (menubasistext (110));{} menuwindowline;{}
+ delete (angekreuzte, name (zu loeschende, z), index);{} pause (20){} FI.{} fehlerbehandlung:{} IF is error{} THEN regenerate menuscreen;{} melde zieltaskerror (errormessage);{} clear error; enable stop;{} LEAVE dateioperation mit zieltask{} FI.{}END PROC dateioperation mit zieltask;{}PROC dateioperation ausfuehren (THESAURUS CONST angekreuzte,{} INT CONST wahl,{} BOOL CONST mit schlussbemerkung):{}
+ INT VAR spalte :: 1, zeile :: 3, k, anzahl :: 0;{} menuwindowout (menuwindowcenter (invers (operationsbezeichnung (wahl){} + zieltaskhinweis)));{} command dialogue (FALSE);{} fuehre einzelne operationen aus;{} command dialogue (TRUE);{} IF mit schlussbemerkung{} THEN schreibe schlussbemerkung{} ELSE menuwindowpage{} FI.{} fuehre einzelne operationen aus:{} FOR k FROM 1 UPTO highest entry (angekreuzte) REP{} IF name (angekreuzte, k) <> ""{}
+ THEN disable stop;{} bildschirmausgabe;{} operation ausfuehren;{} anzahl INCR 1;{} fehlerbehandlung{} FI{} PER.{} bildschirmausgabe:{} spalte := 1;{} IF remaining menuwindowlines < 2{} THEN menuwindowpage; zeile := 1{} ELSE zeile INCR 1{} FI;{} menuwindowcursor (spalte, zeile);{} ergaenzter dateiname.{} ergaenzter dateiname:{} INT VAR windowcolumn, windowrow;{} SELECT wahl OF{} CASE schreiben : menuwindowout (menubasistext (105) + dateiname){}
+ CASE checken : get menuwindowcursor (windowcolumn, windowrow);{} menuwindowout (dateiname + menubasistext (106));{} menuwindowcursor (windowcolumn, windowrow);{} CASE holen : menuwindowout (menubasistext (107) + dateiname){} END SELECT.{} dateiname:{} " """ + name (angekreuzte, k) + """ ".{} operation ausfuehren:{} IF eigene station{} THEN fuehre eigenstationoperation aus{} ELSE fuehre fremdstationoperation aus{} FI.{}
+ fuehre eigenstationoperation aus:{} SELECT wahl OF{} CASE schreiben : save (name (angekreuzte, k), /zieltaskname){} CASE checken : check (name (angekreuzte, k), /zieltaskname);{} bestaetige{} CASE holen : ueberschreiben erfragen eigene station{} CASE loeschen : loeschen erfragen eigene station{} END SELECT.{} ueberschreiben erfragen eigene station:{} IF exists (name (angekreuzte, k)){} THEN menuwindowline;{} IF menuwindowyes (dateiname + menubasistext (112)){}
+ THEN zeile INCR 2;{} menuwindowline;{} forget (name (angekreuzte, k), quiet);{} fetch (name (angekreuzte, k), /zieltaskname){} FI{} ELSE fetch (name (angekreuzte, k), /zieltaskname){} FI.{} loeschen erfragen eigene station:{} IF menuwindowyes (dateiname + menubasistext (111)){} THEN erase (name (angekreuzte, k), /zieltaskname){} FI.{} fuehre fremdstationoperation aus:{} SELECT wahl OF{} CASE schreiben : save (name (angekreuzte, k), ziel){}
+ CASE checken : check (name (angekreuzte, k), ziel); bestaetige{} CASE holen : ueberschreiben erfragen fremde station{} CASE loeschen : loeschen erfragen fremde station{} END SELECT.{} ueberschreiben erfragen fremde station:{} IF exists (name (angekreuzte, k)){} THEN menuwindowline;{} IF menuwindowyes (dateiname + menubasistext (112)){} THEN zeile INCR 2;{} menuwindowline;{} forget (name (angekreuzte, k), quiet);{}
+ fetch (name (angekreuzte, k), ziel){} FI{} ELSE fetch (name (angekreuzte, k), ziel){} FI.{} loeschen erfragen fremde station:{} IF menuwindowyes (dateiname + menubasistext (111)){} THEN erase (name (angekreuzte, k), ziel){} FI.{} ziel:{} stationsnummer/zieltaskname.{} bestaetige:{} IF NOT is error{} THEN menuwindowout (dateiname + menubasistext (114)){} FI.{} schreibe schlussbemerkung:{} IF remaining menuwindowlines < 7{} THEN menuwindowpage; menuwindowline{}
+ ELSE menuwindowline (2){} FI;{} IF anzahl > 0{} THEN menuwindowout (menubasistext (93) +{} operationskennzeichnung (wahl)){} ELSE menuwindowout (menubasistext (94)){} FI;{} menuwindowstop.{} fehlerbehandlung:{} IF is error{} THEN fehlerfall := TRUE;{} regenerate menuscreen;{} melde zieltaskerror (errormessage);{} clear error; enable stop;{} LEAVE dateioperation ausfuehren{} FI.{}END PROC dateioperation ausfuehren;{}
+TEXT PROC operationsbezeichnung (INT CONST nr):{} SELECT nr OF{} CASE schreiben : menubasistext (95){} CASE checken : menubasistext (97){} CASE schreibcheck : menubasistext (99){} CASE holen : menubasistext (101){} CASE loeschen : menubasistext (103){} OTHERWISE ""{} END SELECT{}END PROC operationsbezeichnung;{}TEXT PROC operationskennzeichnung (INT CONST nr):{} SELECT nr OF{} CASE schreiben : menubasistext (96){} CASE checken : menubasistext (98){}
+ CASE schreibcheck : menubasistext (100){} CASE holen : menubasistext (102){} CASE loeschen : menubasistext (104){} OTHERWISE ""{} END SELECT{}END PROC operationskennzeichnung;{}BOOL PROC not empty (THESAURUS CONST t):{} INT VAR i;{} FOR i FROM 1 UPTO highest entry (t) REP{} IF name (t, i) <> ""{} THEN LEAVE not empty WITH TRUE{} FI{} PER;{} FALSE{}END PROC not empty;{}TEXT PROC zieltaskhinweis:{} IF zieltaskname = "ARCHIVE"{} THEN "(" + menubasistext (78) + ")"{}
+ ELIF zieltaskname = name (father){} THEN "(" + menubasistext (79) + ")"{} ELSE menubasistext (80) + zieltaskname + ")"{} FI{}END PROC zieltaskhinweis;{}PROC menu archiv verzeichnis:{} forget("Interne Dateiliste bei Archivoperation", quiet);{} ueberpruefe kommunikationsbasis;{} liste dateien der zieltask auf;{} regenerate menuscreen.{} ueberpruefe kommunikationsbasis:{} IF unzulaessiger zieltaskname{} THEN LEAVE menu archiv verzeichnis{} ELIF zieltaskname = name (myself){}
+ THEN LEAVE ueberpruefe kommunikationsbasis{} ELIF zieltask ist archivmanager AND NOT archiv gehoert mir{} THEN melde zieltaskerror (menubasistext (47));{} LEAVE menu archiv verzeichnis{} ELIF NOT zieltask ist archivmanager{} THEN stelle kontakt mit zieltask her{} FI.{} stelle kontakt mit zieltask her:{} TEXT VAR fehler :: "";{} IF task ist kommunikativ (fehler){} THEN kontakt mit zieltask erfolgt := TRUE{} ELSE melde zieltaskerror (fehler);{}
+ LEAVE menu archiv verzeichnis{} FI.{} liste dateien der zieltask auf:{} erstelle liste;{} gib liste aus;{} forget ("Interne Dateiliste bei Archivoperation", quiet).{} erstelle liste:{} menufootnote (menubasistext (21) + menubasistext (28));{} FILE VAR f :: sequential file (output, "Interne Dateiliste bei Archivoperation");{} disable stop;{} IF eigene station{} THEN list (f, /zieltaskname){} ELSE list (f, stationsnummer/zieltaskname){} FI;{} IF is error{}
+ THEN melde zieltaskerror (errormessage);{} forget ("Interne Dateiliste bei Archivoperation", quiet);{} clear error; enable stop;{} LEAVE menu archiv verzeichnis{} FI;{} enable stop.{} gib liste aus:{} modify (f);{} IF NOT (zieltaskname = name (myself)){} THEN to line (f, 1);{} insert record (f);{} notiere kopfzeile;{} headline (f, menubasistext (43));{} ELSE entferne eigenen namen aus der liste{} FI;{}
+ to line (f, 1);{} cursor on; menuwindowshow (f); cursor off.{} notiere kopfzeile:{} IF zieltask ist archivmanager{} THEN write record (f, headline (f));{} ELSE write record (f, zieltaskbezeichnung){} FI.{} entferne eigenen namen aus der liste:{} TEXT VAR zeile :: ""; INT VAR i;{} FOR i FROM lines (f) DOWNTO 1 REP{} to line (f, i);{} read record (f, zeile);{} IF pos (zeile, "Interne Dateiliste bei Archivoperation") > 0{} THEN delete record (f);{}
+ LEAVE entferne eigenen namen aus der liste{} FI{} PER{}END PROC menu archiv verzeichnis;{}PROC menu archiv verzeichnis drucken:{} forget ("Interne Dateiliste bei Archivoperation", quiet);{} ueberpruefe kommunikationsbasis;{} erstelle listing;{} drucke listing aus.{} ueberpruefe kommunikationsbasis:{} IF unzulaessiger zieltaskname{} THEN LEAVE menu archiv verzeichnis drucken{} ELIF zieltaskname = name (myself){} THEN LEAVE ueberpruefe kommunikationsbasis{}
+ ELIF zieltask ist archivmanager AND NOT archiv gehoert mir{} THEN melde zieltaskerror (menubasistext (47));{} LEAVE menu archiv verzeichnis drucken{} ELIF NOT zieltask ist archivmanager{} THEN stelle kontakt mit zieltask her{} FI.{} stelle kontakt mit zieltask her:{} TEXT VAR fehler :: "";{} IF task ist kommunikativ (fehler){} THEN kontakt mit zieltask erfolgt := TRUE{} ELSE melde zieltaskerror (fehler);{} LEAVE menu archiv verzeichnis drucken{}
+ FI.{} erstelle listing:{} LET dummy name pos = 18;{} FILE VAR listfile; INT VAR i; TEXT VAR record :: "";{} TEXT CONST head :: 70 * "=", end :: 70 * "-";{} IF menuno (menubasistext (90), 5){} THEN LEAVE menu archiv verzeichnis drucken{} FI;{} menufootnote (menubasistext (21) + menubasistext (29));{} disable stop;{} listfile := sequential file (output, "Interne Dateiliste bei Archivoperation");{} IF eigene station{} THEN list (listfile, /zieltaskname){} ELSE list (listfile, stationsnummer/zieltaskname){}
+ FI;{} IF is error{} THEN melde zieltaskerror (errormessage);{} forget ("Interne Dateiliste bei Archivoperation", quiet);{} clear error; enable stop;{} LEAVE menu archiv verzeichnis drucken{} FI;{} enable stop.{} drucke listing aus:{} schreibe dateikopf;{} loesche dummy names;{} schreibe fuss;{} drucke und loesche listing.{} schreibe dateikopf:{} modify (listfile);{} to line (listfile, 1);{} FOR i FROM 1 UPTO 6 REP insert record (listfile) PER;{}
+ to line (listfile, 1);{} write record (listfile, "#type (""elanlist"")#"); down (listfile);{} write record (listfile, "#start (2.5,0.0)##limit (20,5)#"{} + "#pagelength (26.0)#"); down (listfile);{} write record (listfile, head); down (listfile);{} schreibe erkennungszeile; down (listfile);{} write record (listfile, " Listing vom " + date + ", "{} + time of day + " Uhr"); down (listfile);{} write record (listfile, head).{}
+ schreibe erkennungszeile:{} IF zieltask ist archivmanager{} THEN write record (listfile, "Archiv: " + headline (listfile)){} ELSE write record (listfile, "Task : " + taskbezeichnung){} FI.{} taskbezeichnung:{} IF eigene station{} THEN zieltaskname{} ELSE text (stationsnummer) + "/" + zieltaskname{} FI.{} loesche dummy names:{} to line (listfile, 8);{} WHILE NOT eof (listfile) REP{} read record (listfile, record);{} IF (record SUB dummy name pos) = "-"{}
+ OR pos (record, "Interne Dateiliste bei Archivoperation") > 0{} THEN delete record (listfile){} ELSE down (listfile){} FI{} PER.{} schreibe fuss:{} output (listfile);{} putline (listfile, end).{} drucke und loesche listing:{} menufootnote (menubasistext (21) + menubasistext (30));{} disable stop;{} print ("Interne Dateiliste bei Archivoperation");{} IF is error{} THEN melde zieltaskerror (errormessage);{} clear error; enable stop;{}
+ forget ("Interne Dateiliste bei Archivoperation", quiet);{} LEAVE menu archiv verzeichnis drucken{} FI;{} enable stop;{} forget ("Interne Dateiliste bei Archivoperation", quiet){}END PROC menu archiv verzeichnis drucken;{}TEXT PROC zieltaskbezeichnung:{} IF eigene station{} THEN menubasistext (77) + taskbezeichnung{} ELSE menubasistext (76) + text (stationsnummer) + " " +{} menubasistext (77) + zieltaskname{} FI.{} taskbezeichnung:{} IF zieltaskname = "ARCHIVE"{}
+ THEN menubasistext (78){} ELIF zieltaskname = name (father){} THEN menubasistext (79) + " (" + zieltaskname + ")"{} ELSE zieltaskname{} FI{}END PROC zieltaskbezeichnung;{}BOOL PROC unzulaessiger zieltaskname:{} IF compress (zieltaskname) = "" OR compress (zieltaskname) = "-"{} THEN TRUE{} ELSE FALSE{} FI{}END PROC unzulaessiger zieltaskname;{}PROC menu archiv initialisieren:{} TEXT VAR archivname :: "", meldung :: "";{} klaere zieltaskart;{} formatiere ggf;{}
+ initialisiere ggf.{} klaere zieltaskart:{} IF NOT zieltask ist archivmanager{} THEN menuinfo (menubasistext (121) + zieltaskname +{} menubasistext (122));{} LEAVE menu archiv initialisieren{} FI.{} formatiere ggf:{} IF menuyes (menubasistext (85), 5){} THEN nimm archiv in beschlag;{} fuehre formatierung aus{} FI.{} nimm archiv in beschlag:{} stelle archivbesitz sicher;{} IF aktueller archivname <> ""{} THEN archivname := aktueller archivname{}
+ ELSE archivname := menubasistext (75){} FI;{} IF eigene station{} THEN reserve (archivname,/zieltaskname){} ELSE reserve (archivname, stationsnummer/zieltaskname){} FI;{} aktueller archivname := archivname;{} archiv gehoert mir := TRUE;{} zieltask anzeigen.{} stelle archivbesitz sicher:{} IF NOT archiv gehoert mir OR NOT kontakt mit zieltask erfolgt{} THEN versuche kommunikation;{} versuche archiv zu reservieren (meldung);{} werte meldung aus{}
+ FI.{} versuche kommunikation:{} TEXT VAR fehler :: "";{} IF NOT task ist kommunikativ (fehler){} THEN melde zieltaskerror (fehler);{} melde rigoros ab;{} LEAVE menu archiv initialisieren{} ELSE kontakt mit zieltask erfolgt := TRUE{} FI.{} werte meldung aus:{} IF meldung <> ""{} THEN melde zieltaskerror (meldung);{} aktueller archivname := "";{} zieltask anzeigen;{} LEAVE menu archiv initialisieren{} FI.{}
+ fuehre formatierung aus:{} INT VAR auswahl :: menualternative (menubasistext (54),{} menubasistext (55),{} menubasistext (56), 5, TRUE);{} IF auswahl = 0{} THEN LEAVE fuehre formatierung aus{} FI;{} IF auswahl > 100{} THEN auswahl DECR 100{} FI;{} command dialogue (FALSE);{} disable stop;{} menufootnote (menubasistext (21) + menubasistext (27));{} IF eigene station{} THEN formatiere auf eigener station{}
+ ELSE formatiere auf fremder station{} FI;{} IF is error{} THEN melde zieltaskerror (errormessage);{} clear error; enable stop;{} command dialogue (TRUE);{} LEAVE formatiere ggf{} ELSE enable stop;{} command dialogue (TRUE);{} aktiviere gueltige archivmenupunkte;{} refresh submenu;{} zieltask anzeigen{} FI.{} formatiere auf eigener station:{} IF auswahl < 5{} THEN format (auswahl, /zieltaskname){}
+ ELSE format (/zieltaskname){} FI.{} formatiere auf fremder station:{} IF auswahl < 5{} THEN format (auswahl, stationsnummer/zieltaskname){} ELSE format (stationsnummer/zieltaskname){} FI.{} initialisiere ggf:{} stelle archivbesitz sicher;{} archiv anmelden (archivname, meldung, FALSE);{} IF archivname <> ""{} THEN aktueller archivname := archivname;{} archiv gehoert mir := TRUE;{} aktiviere gueltige archivmenupunkte;{} refresh submenu;{}
+ zieltask anzeigen;{} frage nach ueberschreiben{} ELIF meldung = menubasistext (63) OR meldung = menubasistext (62){} THEN frage nach initialisieren{} ELSE melde zieltaskerror (meldung);{} aktueller archivname := "";{} zieltask anzeigen;{} LEAVE menu archiv initialisieren{} FI.{} frage nach ueberschreiben:{} IF menuyes (menubasistext (86) + archivname + menubasistext (87), 5){} THEN erfrage neuen namen und initialisiere{}
+ ELSE LEAVE menu archiv initialisieren{} FI.{} frage nach initialisieren:{} IF menuyes (menubasistext (88), 5){} THEN erfrage neuen namen und initialisiere{} ELSE LEAVE menu archiv initialisieren{} FI.{} erfrage neuen namen und initialisiere:{} TEXT VAR neuer name := compress(menuanswer (menubasistext (89),{} aktueller archivname, 5));{} IF neuer name <> ""{} THEN archivname := neuer name{} ELIF neuer name = "" AND archivname = ""{}
+ THEN archivname := menubasistext (75){} FI;{} command dialogue (FALSE);{} disable stop;{} IF eigene station{} THEN reserve (archivname, /zieltaskname);{} clear (/zieltaskname){} ELSE reserve (archivname, stationsnummer/zieltaskname);{} clear (stationsnummer/zieltaskname){} FI;{} IF is error{} THEN melde zieltaskerror (errormessage);{} clear error; enable stop;{} command dialogue (TRUE);{} melde rigoros ab;{}
+ archivreservierung aufgeben;{} aktiviere gueltige archivmenupunkte;{} refresh submenu;{} zieltask anzeigen;{} LEAVE menu archiv initialisieren{} ELSE enable stop; command dialogue (TRUE);{} aktueller archivname := archivname;{} archiv gehoert mir := TRUE;{} aktiviere gueltige archivmenupunkte;{} refresh submenu;{} zieltask anzeigen{} FI{}END PROC menu archiv initialisieren;{}PROC archive (TEXT CONST archive name,task, INT CONST station):{}
+ call (reserve code, archive name, station/task){}END PROC archive;{}PROC menu archiv reservierung aufgeben:{} IF archiv gehoert mir{} THEN menufootnote (menubasistext (21) + menubasistext (22));{} archivreservierung aufgeben;{} FI;{} erase menunotice;{} old menufootnote{}END PROC menu archiv reservierung aufgeben;{}PROC archivreservierung aufgeben:{} command dialogue (FALSE);{} disable stop;{} IF eigene station{} THEN release (/zieltaskname){} ELSE release (stationsnummer/zieltaskname);{}
+ FI;{} IF is error{} THEN clear error{} FI;{} enable stop;{} command dialogue (TRUE);{} archiv gehoert mir := FALSE;{} aktueller archivname := ""{}END PROC archivreservierung aufgeben;{}BOOL PROC eigene station:{} IF stationsnummer = 0 OR stationsnummer = station (myself){} THEN TRUE{} ELSE FALSE{} FI{}END PROC eigene station;{}PROC aktiviere gueltige archivmenupunkte:{} IF zieltask ist archivmanager AND NOT archiv gehoert mir{} THEN aktiviere nur grundfunktionen{}
+ ELSE aktiviere alle momentan gueltigen punkte{} FI.{} aktiviere alle momentan gueltigen punkte:{} IF letzte funktion = 11{} THEN activate (1); activate (2);{} activate (4); activate (5); activate (6); activate (7); activate (8);{} activate (10); activate (11);{} activate (13); activate (14);{} ELIF letzte funktion = 6{} THEN deactivate (1); deactivate (2);{} activate (4); deactivate (5); deactivate (6); activate (7); activate (8);{}
+ activate (10); activate (11);{} deactivate (13); activate (14);{} FI.{} aktiviere nur grundfunktionen:{} activate (1); deactivate (2);{} deactivate (4); deactivate (5); deactivate (6); deactivate (7); deactivate (8);{} deactivate (10); deactivate (11);{} activate (13); activate (14).{}END PROC aktiviere gueltige archivmenupunkte;{}PROC zieltask anzeigen:{} IF zieltask ist archivmanager{} THEN schreibe taskname und archivname{} ELSE schreibe taskname{}
+ FI.{} schreibe taskname:{} write menunotice (menubasistext (59) + ""13"" + name der task, notizort).{} schreibe taskname und archivname:{} write menunotice (menubasistext (59) + ""13"" + name der task +{} ""13"" + menubasistext (60) + ""13"" + archivname,{} notizort).{} name der task:{} IF zieltaskname = "ARCHIVE" AND eigene station{} THEN " " + menubasistext (71){} ELIF zieltaskname = "PUBLIC" AND eigene station{} THEN " " + menubasistext (72){}
+ ELIF zieltaskname = name (father){} THEN " " + menubasistext (73){} ELSE " " + ggf gekuerzter zieltaskname{} FI.{} ggf gekuerzter zieltaskname:{} TEXT VAR interner name;{} IF eigene station{} THEN interner name := zieltaskname;{} ELSE interner name := text (stationsnummer) + "/" + zieltaskname{} FI;{} IF length (interner name) < 20{} THEN ""15"" + interner name + " "14""{} ELSE ""15"" + subtext (interner name, 1 , 18) + ".." + " "14""{} FI.{}
+ archivname:{} IF NOT archiv gehoert mir OR aktueller archivname = ""{} THEN " " + menubasistext (74){} ELSE " "15"" + ggf gekuerzter archivname + " "14""{} FI.{} ggf gekuerzter archivname:{} IF eigene station AND length (aktueller archivname) > 20{} THEN subtext (aktueller archivname, 1, 18) + ".."{} ELIF NOT eigene station AND length (aktueller archivname) > 17{} THEN subtext (aktueller archivname, 1, 15) + ".."{} ELSE aktueller archivname{} FI.{}
+END PROC zieltask anzeigen;{}BOOL PROC task ist kommunikativ (TEXT VAR fehler):{} INT VAR antwort;{} DATASPACE VAR dummy space := nilspace;{} IF zieltask ist archivmanager{} THEN schicke reservierungscode{} ELSE schicke listcode{} FI.{} schicke reservierungscode:{} disable stop;{} IF eigene station{} THEN pingpong (/zieltaskname, reserve code, dummy space, antwort);{} ELSE pingpong (stationsnummer/zieltaskname, reserve code,{} dummy space, antwort){}
+ FI;{} werte antwort aus.{} schicke listcode:{} disable stop;{} IF eigene station{} THEN pingpong (/zieltaskname, list code, dummy space, antwort);{} ELSE pingpong (stationsnummer/zieltaskname, list code,{} dummy space, antwort){} FI;{} werte antwort aus.{} werte antwort aus:{} IF is error{} THEN clear error{} FI;{} BOUND TEXT VAR inhalt := dummy space;{} enable stop;{} IF antwort = 0 THEN fehler := ""{} ELIF antwort = -1 THEN fehler := menubasistext (41){}
+ ELIF antwort = -2 THEN fehler := menubasistext (42){} ELSE fehler := inhalt{} FI;{} forget (dummy space);{} IF antwort = ack{} THEN kontakt mit zieltask erfolgt := TRUE; TRUE{} ELSE kontakt mit zieltask erfolgt := FALSE; FALSE{} FI{}END PROC task ist kommunikativ;{}END PACKET ls dialog 6;{}
+
diff --git a/dialog/ls-DIALOG 7 b/dialog/ls-DIALOG 7
new file mode 100644
index 0000000..467f531
--- /dev/null
+++ b/dialog/ls-DIALOG 7
@@ -0,0 +1,54 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG 7 **
+ ** Dateihandling **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+PACKET ls dialog 7 DEFINES{} menu dateien verzeichnis,{} menu dateien loeschen,{} menu dateien drucken,{} menu dateien kopieren,{} menu dateien umbenennen,{} menu dateien speicherplatz,{} menu dateien aufraeumen:{}LET filetype = 1003,{} maxlaenge = 60,{} breite = 40,{} niltext = "";{}TEXT CONST dateibez :: "Dateiliste bei internen Operationen";{}PROC menu dateien verzeichnis:{} forget (dateibez, quiet);{} liste dateien auf;{}
+ regenerate menuscreen.{} liste dateien auf:{} erstelle liste;{} gib liste aus;{} forget (dateibez, quiet).{} erstelle liste:{} menufootnote (menubasistext (21) + menubasistext (28));{} FILE VAR f :: sequential file (output, dateibez);{} list (f); modify (f);{} headline (f, menubasistext (43));{} to line (f, 1); insert record (f);{} write record (f, menubasistext (161));{} entferne eigenen namen aus der liste.{} entferne eigenen namen aus der liste:{} TEXT VAR zeile :: ""; INT VAR i;{}
+ FOR i FROM lines (f) DOWNTO 1 REP{} to line (f, i); read record (f, zeile);{} IF pos (zeile, dateibez) > 0{} THEN delete record (f);{} LEAVE entferne eigenen namen aus der liste{} FI{} PER.{} gib liste aus:{} to line (f, 1); cursor on; menuwindowshow (f); cursor off{}END PROC menu dateien verzeichnis;{}PROC menu dateien loeschen:{} lasse dateien auswaehlen;{} loesche ausgewaehlte dateien;{} regenerate menuscreen.{} lasse dateien auswaehlen:{} IF NOT not empty (ALL myself){}
+ THEN noch keine datei;{} LEAVE menu dateien loeschen{} ELSE biete auswahl an{} FI.{} biete auswahl an:{} THESAURUS VAR angekreuzte :={} menuanswersome ( center (breite, invers (menubasistext(162))) +{} menubasistext (163), "", ALL myself,{} menubasistext (162), menubasistext (91) +{} menubasistext (104) + menubasistext (92), FALSE).{} loesche ausgewaehlte dateien:{} show menuwindow;{} steige ggf bei leerem thesaurus aus;{}
+ menuwindowout (menuwindowcenter (invers (menubasistext (162))));{} menuwindowline (2);{} command dialogue (FALSE);{} fuehre einzelne operation aus;{} command dialogue (TRUE);{} schlage ggf neue seite auf;{} menuwindowout (menubasistext (93) + menubasistext (104));{} menuwindowstop.{} fuehre einzelne operation aus:{} INT VAR k;{} FOR k FROM 1 UPTO highest entry (angekreuzte) REP{} IF name (angekreuzte, k) = niltext{} THEN LEAVE fuehre einzelne operation aus{}
+ ELIF NOT exists (name (angekreuzte, k)){} THEN menuwindowout (" """ + name (angekreuzte, k) + """");{} menuwindowline;{} menuwindowout (menubasistext (188)); menuwindowline;{} LEAVE fuehre einzelne operation aus{} ELSE disable stop;{} IF menuwindowyes (" """ + name (angekreuzte, k) + """ "{} + menubasistext (111)){} THEN forget (name (angekreuzte, k), quiet){} FI;{}
+ fehlerbehandlung{} FI{} PER.{} steige ggf bei leerem thesaurus aus:{} IF NOT not empty (angekreuzte){} THEN menuwindowline (2);{} menuwindowout (menubasistext (94));{} menuwindowstop;{} regenerate menuscreen;{} LEAVE menu dateien loeschen{} FI.{} schlage ggf neue seite auf:{} IF remaining menuwindowlines < 7{} THEN menuwindowpage; menuwindowline{} ELSE menuwindowline (2){} FI.{} fehlerbehandlung:{} IF is error{}
+ THEN regenerate menuscreen;{} menuinfo (invers (errormessage));{} clear error; enable stop;{} LEAVE menu dateien loeschen{} FI{}END PROC menu dateien loeschen;{}PROC menu dateien drucken:{} lasse programme auswaehlen;{} drucke programme;{} regenerate menuscreen.{} lasse programme auswaehlen:{} IF NOT not empty (ALL myself){} THEN noch keine datei;{} LEAVE menu dateien drucken{} ELSE biete auswahl an{} FI.{} biete auswahl an:{}
+ THESAURUS VAR angekreuzte :={} menuanswersome ( center (breite, invers (menubasistext(164))) +{} menubasistext (163), "", ALL myself,{} menubasistext (164), menubasistext (91) +{} menubasistext (165) + menubasistext (92), FALSE).{} drucke programme:{} show menuwindow;{} steige ggf bei leerem thesaurus aus;{} menuwindowout (menuwindowcenter (invers (menubasistext (164))));{} menuwindowline (2);{} command dialogue (FALSE);{}
+ fuehre einzelne operation aus;{} command dialogue (TRUE);{} schlage ggf neue seite auf;{} menuwindowout (menubasistext (93) + menubasistext (165));{} menuwindowstop.{} fuehre einzelne operation aus:{} INT VAR k;{} FOR k FROM 1 UPTO highest entry (angekreuzte) REP{} IF name (angekreuzte, k) = niltext{} THEN LEAVE fuehre einzelne operation aus{} ELIF NOT exists (name (angekreuzte, k)){} THEN menuwindowout (" """ + name (angekreuzte, k) + """");{}
+ menuwindowline;{} menuwindowout (menubasistext (188)); menuwindowline;{} LEAVE fuehre einzelne operation aus{} ELSE disable stop;{} menuwindowout ( " """ + name (angekreuzte, k) + """ "{} + menubasistext (166));{} menuwindowline;{} print (name (angekreuzte, k));{} fehlerbehandlung{} FI{} PER.{} steige ggf bei leerem thesaurus aus:{} IF NOT not empty (angekreuzte){}
+ THEN menuwindowline (2);{} menuwindowout (menubasistext (94));{} menuwindowstop;{} regenerate menuscreen;{} LEAVE menu dateien drucken{} FI.{} schlage ggf neue seite auf:{} IF remaining menuwindowlines < 7{} THEN menuwindowpage; menuwindowline{} ELSE menuwindowline (2){} FI.{} fehlerbehandlung:{} IF is error{} THEN regenerate menuscreen;{} menuinfo (invers (errormessage));{} clear error; enable stop;{}
+ LEAVE menu dateien drucken{} FI.{}END PROC menu dateien drucken;{}PROC menu dateien kopieren:{} ermittle alten dateinamen;{} erfrage neuen dateinamen;{} kopiere ggf die datei.{} ermittle alten dateinamen:{} IF NOT not empty (ALL myself){} THEN noch keine datei;{} LEAVE menu dateien kopieren{} ELSE hole den namen{} FI.{} hole den namen:{} TEXT VAR alter name :={} menuanswerone ( center (breite, invers (menubasistext(167))) +{} menubasistext (163), "", ALL myself,{}
+ menubasistext (167), menubasistext (168) +{} menubasistext (169) + menubasistext (170), TRUE);{} IF alter name = niltext{} THEN LEAVE menu dateien kopieren{} ELIF NOT exists (alter name){} THEN menuinfo (menubasistext (188));{} LEAVE menu dateien kopieren{} FI.{} erfrage neuen dateinamen:{} TEXT VAR neuer name :: menuanswer (ausgabe, alter name, 5).{} ausgabe:{} ueberschrift + menubasistext (171) + bisheriger name{}
+ + menubasistext (172).{} ueberschrift:{} center (maxlaenge, invers (menubasistext (167))) + ""13""13"".{} bisheriger name:{} ""13""13" " + invers (alter name) + ""13""13"".{} kopiere ggf die datei:{} IF neuer name = niltext{} THEN menuinfo (invers (menubasistext (173)));{} LEAVE menu dateien kopieren{} ELIF exists (neuer name){} THEN mache vorwurf;{} LEAVE menu dateien kopieren{} ELSE copy (alter name, neuer name){}
+ FI.{} mache vorwurf:{} menuinfo (menubasistext (174)).{}END PROC menu dateien kopieren;{}PROC menu dateien umbenennen:{} ermittle alten dateinamen;{} erfrage neuen dateinamen;{} benenne ggf die datei um.{} ermittle alten dateinamen:{} IF NOT not empty (ALL myself){} THEN noch keine datei;{} LEAVE menu dateien umbenennen{} ELSE hole den namen{} FI.{} hole den namen:{} TEXT VAR alter name :={} menuanswerone ( center (breite, invers (menubasistext(175))) +{}
+ menubasistext (163), "", ALL myself,{} menubasistext (175), menubasistext (168) +{} menubasistext (176) + menubasistext (170), TRUE);{} IF alter name = niltext{} THEN LEAVE menu dateien umbenennen{} ELIF NOT exists (alter name){} THEN menuinfo (menubasistext (188));{} LEAVE menu dateien umbenennen{} FI.{} erfrage neuen dateinamen:{} TEXT VAR neuer name :: menuanswer (ausgabe, alter name, 5).{} ausgabe:{}
+ ueberschrift + menubasistext (171) + bisheriger name{} + menubasistext (177).{} ueberschrift:{} center (maxlaenge, invers (menubasistext (175))) + ""13""13"".{} bisheriger name:{} ""13""13" " + invers (alter name) + ""13""13"".{} benenne ggf die datei um:{} IF neuer name = niltext{} THEN menuinfo (invers (menubasistext (173)));{} LEAVE menu dateien umbenennen{} ELIF exists (neuer name){} THEN mache vorwurf;{} LEAVE menu dateien umbenennen{}
+ ELSE rename (alter name, neuer name){} FI.{} mache vorwurf:{} menuinfo (menubasistext (174)).{}END PROC menu dateien umbenennen;{}PROC menu dateien speicherplatz:{} lasse dateinamen auswaehlen;{} ermittle den speicherplatz;{} regenerate menuscreen.{} lasse dateinamen auswaehlen:{} IF NOT not empty (ALL myself){} THEN noch keine datei;{} LEAVE menu dateien speicherplatz{} ELSE biete auswahl an{} FI.{} biete auswahl an:{} THESAURUS VAR angekreuzte :={}
+ menuanswersome ( center (breite, invers (menubasistext(178))) +{} menubasistext (163), "", ALL myself,{} menubasistext (178), menubasistext (179), FALSE).{} ermittle den speicherplatz:{} show menuwindow;{} steige ggf bei leerem thesaurus aus;{} menuwindowout (menuwindowcenter (invers (menubasistext (178))));{} menuwindowline (2);{} command dialogue (FALSE);{} fuehre einzelne operation aus;{} command dialogue (TRUE);{} schlage ggf neue seite auf;{}
+ menuwindowout (menubasistext (180));{} menuwindowstop.{} fuehre einzelne operation aus:{} INT VAR k;{} FOR k FROM 1 UPTO highest entry (angekreuzte) REP{} IF name (angekreuzte, k) = niltext{} THEN LEAVE fuehre einzelne operation aus{} ELIF NOT exists (name (angekreuzte, k)){} THEN menuwindowout (" """ + name (angekreuzte, k) + """");{} menuwindowline;{} menuwindowout (menubasistext (188)); menuwindowline;{} LEAVE fuehre einzelne operation aus{}
+ ELSE disable stop;{} menuwindowout ( " """ + name (angekreuzte, k) + """ "{} + menubasistext (181){} + speicherplatz (name (angekreuzte, k)));{} menuwindowline;{} fehlerbehandlung{} FI{} PER.{} steige ggf bei leerem thesaurus aus:{} IF NOT not empty (angekreuzte){} THEN menuwindowline (2);{} menuwindowout (menubasistext (94));{} menuwindowstop;{} regenerate menuscreen;{}
+ LEAVE menu dateien speicherplatz{} FI.{} schlage ggf neue seite auf:{} IF remaining menuwindowlines < 7{} THEN menuwindowpage; menuwindowline{} ELSE menuwindowline (2){} FI.{} fehlerbehandlung:{} IF is error{} THEN regenerate menuscreen;{} menuinfo (invers (errormessage));{} clear error; enable stop;{} LEAVE menu dateien speicherplatz{} FI.{}END PROC menu dateien speicherplatz;{}TEXT PROC speicherplatz (TEXT CONST dateiname):{}
+ DATASPACE VAR ds :: old (dateiname);{} INT CONST platz :: storage (ds);{} forget (ds);{} " " + text (platz) + menubasistext (182){}END PROC speicherplatz;{}PROC menu dateien aufraeumen:{} lasse dateinamen auswaehlen;{} raeume die dateien auf;{} regenerate menuscreen.{} lasse dateinamen auswaehlen:{} IF NOT not empty (ALL myself){} THEN noch keine datei;{} LEAVE menu dateien aufraeumen{} ELSE biete auswahl an{} FI.{} biete auswahl an:{} THESAURUS VAR angekreuzte :={}
+ menuanswersome ( center (breite, invers (menubasistext(183))) +{} menubasistext (163), "", ALL myself,{} menubasistext (183), menubasistext (91) +{} menubasistext (184) + menubasistext (92), FALSE).{} raeume die dateien auf:{} show menuwindow;{} steige ggf bei leerem thesaurus aus;{} menuwindowout (menuwindowcenter (invers (menubasistext (183))));{} menuwindowline (2);{} command dialogue (FALSE);{} fuehre einzelne operation aus;{}
+ command dialogue (TRUE);{} schlage ggf neue seite auf;{} menuwindowout (menubasistext (93) + menubasistext (184));{} menuwindowstop.{} fuehre einzelne operation aus:{} INT VAR k;{} FOR k FROM 1 UPTO highest entry (angekreuzte) REP{} IF name (angekreuzte, k) = niltext{} THEN LEAVE fuehre einzelne operation aus{} ELIF NOT exists (name (angekreuzte, k)){} THEN menuwindowout (" """ + name (angekreuzte, k) + """");{} menuwindowline;{} menuwindowout (menubasistext (188)); menuwindowline;{}
+ LEAVE fuehre einzelne operation aus{} ELIF dateityp ist ok{} THEN disable stop;{} menuwindowline;{} menuwindowout ( " """ + name (angekreuzte, k) + """ "{} + menubasistext (185) );{} menuwindowline; menuwindowout (" ");{} reorganize (name (angekreuzte, k));{} fehlerbehandlung{} ELSE menuwindowout ( " """ + name (angekreuzte, k) + """ "{} + menubasistext (186)){}
+ FI{} PER.{} dateityp ist ok:{} type (old (name (angekreuzte, k))) = filetype.{} steige ggf bei leerem thesaurus aus:{} IF NOT not empty (angekreuzte){} THEN menuwindowline (2);{} menuwindowout (menubasistext (94));{} menuwindowstop;{} regenerate menuscreen;{} LEAVE menu dateien aufraeumen{} FI.{} schlage ggf neue seite auf:{} IF remaining menuwindowlines < 7{} THEN menuwindowpage; menuwindowline{} ELSE menuwindowline (2){}
+ FI.{} fehlerbehandlung:{} IF is error{} THEN regenerate menuscreen;{} menuinfo (invers (errormessage));{} clear error; enable stop;{} LEAVE menu dateien aufraeumen{} FI.{}END PROC menu dateien aufraeumen;{}PROC noch keine datei:{} menuinfo (menubasistext ( 187)){}END PROC noch keine datei;{}END PACKET ls dialog 7;{}
+
diff --git a/dialog/ls-DIALOG MENUKARTEN MANAGER b/dialog/ls-DIALOG MENUKARTEN MANAGER
new file mode 100644
index 0000000..67799ea
--- /dev/null
+++ b/dialog/ls-DIALOG MENUKARTEN MANAGER
@@ -0,0 +1,28 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG **
+ ** MENUKARTEN-MANAGER **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+PACKET ls dialog manager DEFINES{} ls dialog manager:{}LET fetch code = 11,{} save code = 12,{} exists code = 13,{} list code = 15,{} continue code = 100;{}LET mm taskname = "ls-MENUKARTEN",{} gibt es schon = "Die Task 'ls-MENUKARTEN' existiert schon!",{} verweis = "Unzulässiger Zugriff auf die Task 'ls-MENUKARTEN'!";{}PROC ls dialog manager:{} stelle richtigen tasknamen ein;{} global manager{} (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) ls dialog manager){}
+END PROC ls dialog manager;{}PROC stelle richtigen tasknamen ein:{} IF name (myself) <> mm taskname{} THEN nimm umbenennung vor{} FI.{} nimm umbenennung vor:{} IF NOT exists task (mm taskname){} THEN rename myself (mm taskname){} ELSE errorstop (gibt es schon){} FI.{}END PROC stelle richtigen tasknamen ein;{}PROC ls dialog manager (DATASPACE VAR ds, INT CONST order, phase,{} TASK CONST order task):{} IF order task = supervisor{} OR order = fetch code{}
+ OR order = save code{} OR order = exists code{} OR order = list code{} OR order = continue code{} THEN free manager (ds, order, phase, order task){} ELSE errorstop (verweis){} FI{}END PROC ls dialog manager;{}END PACKET ls dialog manager;{}
+
diff --git a/dialog/ls-DIALOG MM-gen b/dialog/ls-DIALOG MM-gen
new file mode 100644
index 0000000..ef05853
--- /dev/null
+++ b/dialog/ls-DIALOG MM-gen
@@ -0,0 +1,27 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG **
+ ** MENUKARTEN MANAGER **
+ ** Generator-Programm **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+LET dateiname = "ls-DIALOG MENUKARTEN MANAGER",{} archivname = "gs-dialog";{}gib bildschirmhinweis;{}hole generatordatei vom archiv;{}insertiere die datei;{}do ("ls dialog manager").{}gib bildschirmhinweis:{} page;{} putline (" "15"ls-DIALOG MENUKARTEN MANAGER - Generierung "14"").{}hole generatordatei vom archiv:{} IF NOT exists (dateiname){} THEN cursor (1, 5); out (""4"");{} putline ("Bitte warten... Ich hole eine Datei von der Diskette!");{} archive (archivname);{}
+ fetch (dateiname, archive);{} release (archive){} FI.{}insertiere die datei:{} cursor (1, 5); out (""4"");{} putline ("Bitte warten... Ich insertiere!");{} check off; insert (dateiname); check on;{} forget ("ls-DIALOG MM/gen", quiet);{} forget (dateiname, quiet).{}
+
diff --git a/dialog/ls-DIALOG decompress b/dialog/ls-DIALOG decompress
new file mode 100644
index 0000000..96d9340
--- /dev/null
+++ b/dialog/ls-DIALOG decompress
@@ -0,0 +1,150 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG - DECOMPRESS **
+ ** **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+PACKET ls dialog decompress DEFINES
+
+ komprimiere,
+ dekomprimiere:
+
+LET verweis = "Angegebene Datei existiert nicht!",
+ falscher typ = "Angegebenen Datei hat falschen Typ!",
+ filetype = 1003;
+
+PROC komprimiere (TEXT CONST dateiname):
+ INT VAR zeiger;
+ ueberpruefe existenz;
+ ueberpruefe dateityp;
+ initialisiere;
+ FOR zeiger FROM 1 UPTO 24 REP
+ getline (ein, eingabezeile);
+ putline (aus, eingabezeile);
+ PER;
+ WHILE NOT eof (ein) REP
+ getline (ein, eingabezeile);
+ zaehler INCR 1; cout (zaehler);
+ zwischenzeile := abgeschnitten (eingabezeile);
+ haenge zeilentrenner an;
+ haenge zwischenzeile an ausgabezeile;
+ schreibe ausgabezeile ggf weg
+ PER;
+ schreibe ausgabezeile weg;
+ mache ausgabedatei zur eingabedatei.
+
+ ueberpruefe existenz:
+ IF NOT exists (dateiname)
+ THEN errorstop (verweis);
+ FI.
+
+ ueberpruefe dateityp:
+ IF type (old (dateiname)) <> filetype
+ THEN errorstop (falscher typ)
+ FI.
+
+ initialisiere:
+ FILE VAR ein := sequential file (input, dateiname);
+ FILE VAR aus := sequential file (output, "KOMPRIM");
+ maxlinelength (aus, 600);
+ INT VAR zaehler :: 1;
+ TEXT VAR eingabezeile :: "", zwischenzeile :: "", ausgabezeile :: "".
+
+ haenge zeilentrenner an:
+ IF zwischenzeile <> ""
+ THEN zwischenzeile CAT "{}"
+ FI.
+
+ haenge zwischenzeile an ausgabezeile:
+ ausgabezeile CAT zwischenzeile.
+
+ schreibe ausgabezeile ggf weg:
+ IF length (ausgabezeile) > 500
+ THEN schreibe ausgabezeile weg
+ FI.
+
+ schreibe ausgabezeile weg:
+ IF ausgabezeile <> ""
+ THEN putline (aus, ausgabezeile);
+ ausgabezeile := ""
+ FI.
+
+mache ausgabedatei zur eingabedatei:
+ forget (dateiname, quiet);
+ rename ("KOMPRIM", dateiname).
+END PROC komprimiere;
+
+TEXT PROC abgeschnitten (TEXT CONST zeile):
+ TEXT VAR t :: zeile;
+ WHILE (t SUB length (t)) = " " REP
+ t := subtext (t, 1, length (t) - 1)
+ PER;
+ t
+END PROC abgeschnitten;
+
+PROC dekomprimiere (TEXT CONST dateiname):
+ INT VAR zeiger;
+ ueberpruefe existenz;
+ ueberpruefe dateityp;
+ initialisiere;
+ FOR zeiger FROM 1 UPTO 24 REP
+ getline (ein, eingabezeile);
+ putline (aus, eingabezeile);
+ PER;
+ WHILE NOT eof (ein) REP
+ getline (ein, eingabezeile);
+ zerlege zeile
+ PER;
+ forget (dateiname, quiet);
+ rename ("DEKOMPRIM", dateiname).
+
+ ueberpruefe existenz:
+ IF NOT exists (dateiname)
+ THEN errorstop (verweis)
+ FI.
+
+ ueberpruefe dateityp:
+ IF type (old (dateiname)) <> filetype
+ THEN errorstop (falscher typ)
+ FI.
+
+ initialisiere:
+ FILE VAR ein := sequential file (input, dateiname);
+ FILE VAR aus := sequential file (output, "DEKOMPRIM");
+ INT VAR zaehler :: 1;
+ TEXT VAR eingabezeile :: "", ausgabezeile :: "".
+
+ zerlege zeile:
+ WHILE eingabezeile <> "" REP
+ nimm das erste stueck und schreibe es weg;
+ entferne den zeilentrenner
+ PER.
+
+ nimm das erste stueck und schreibe es weg:
+ ausgabezeile := subtext (eingabezeile, 1, pos (eingabezeile, "{}") - 1);
+ putline (aus, ausgabezeile);
+ zaehler INCR 1;
+ cout (zaehler).
+
+ entferne den zeilentrenner:
+ eingabezeile := subtext (eingabezeile, pos (eingabezeile, "{}") + 2).
+END PROC dekomprimiere;
+END PACKET ls dialog decompress;
+
diff --git a/dialog/ls-DIALOG-gen b/dialog/ls-DIALOG-gen
new file mode 100644
index 0000000..e085616
--- /dev/null
+++ b/dialog/ls-DIALOG-gen
@@ -0,0 +1,34 @@
+(*
+
+ *********************************************************
+ *********************************************************
+ ** **
+ ** ls-DIALOG **
+ ** GENERATORPROGRAMM **
+ ** Version 1.2 **
+ ** **
+ ** (Stand: 04.11.88) **
+ ** **
+ ** **
+ ** Autor: Wolfgang Weber, Bielefeld **
+ ** **
+ ** **
+ ** Copyright (C) 1987, 1988 Eva Latta-Weber, Bielefeld **
+ ** **
+ ** Copyright (C) 1988 ERGOS GmbH, Siegburg **
+ ** **
+ *********************************************************
+ *********************************************************
+
+ *)
+
+LET mm taskname = "ls-MENUKARTEN",{} datei 1 = "ls-DIALOG 1",{} datei 2 = "ls-DIALOG 2",{} datei 3 = "ls-DIALOG 3",{} datei 4 = "ls-DIALOG 4",{} datei 5 = "ls-DIALOG 5",{} datei 6 = "ls-DIALOG 6",{} datei 7 = "ls-DIALOG 7",{} menukarte = "ls-MENUKARTE:Archiv";{}PROC stelle existenz des mm sicher:{} cursor (1, 5); out (""4"");{} IF NOT exists (task (mm taskname)){} THEN errorstop ("Unbedingt erst den 'MENUKARTEN-MANAGER' generieren!");{} FI{}
+END PROC stelle existenz des mm sicher;{}PROC vom archiv (TEXT CONST datei):{} cursor (1,5); out (""4"");{} out (" """); out (datei); putline (""" wird geholt.");{} fetch (datei, archive){}END PROC vom archiv;{}PROC hole (TEXT CONST datei):{} IF NOT exists (datei) THEN vom archiv (datei) FI{}END PROC hole;{}PROC in (TEXT CONST datei):{} hole (datei);{} cursor (1, 5); out (""4"");{} out (" """); out (datei); out (""" wird übersetzt: ");{} insert (datei);{} forget (datei, quiet);{}END PROC in;{}
+PROC schicke (TEXT CONST datei):{} cursor (1, 5); out (""4"");{} out (" """); out(datei);{} out (""" wird zum MENUKARTEN-MANAGER geschickt!");{} command dialogue (FALSE);{} save (datei, task (mm taskname));{} command dialogue (TRUE);{} forget (datei, quiet){}END PROC schicke;{}INT VAR size, used;{}BOOL VAR einzeln;{}storage (size, used);{}einzeln := size - used < 500;{}forget ("ls-DIALOG/gen", quiet);{}wirf kopfzeile aus;{}stelle existenz des mm sicher;{}hole die dateien;{}insertiere die dateien;{}
+mache global manager aus der task.{}wirf kopfzeile aus:{} page;{} putline (" "15"ls-DIALOG - Automatische Generierung "14"").{}hole die dateien:{} IF NOT exists (datei 1) COR NOT exists (datei 2){} COR NOT exists (datei 3) COR NOT exists (datei 4){} COR NOT exists (datei 5) COR NOT exists (datei 6){} COR NOT exists (datei 7) COR NOT exists (menukarte){} THEN hole dateien vom archiv{} FI.{}hole dateien vom archiv:{} cursor (1,3);{} IF yes ("Ist das Archiv angemeldet und die 'ls-DIALOG' - Diskette eingelegt"){}
+ THEN lese ein{} ELSE line (2);{} errorstop ("Ohne die Diskette kann ich das System nicht generieren!"){} FI.{}lese ein:{} cursor (1, 3); out (""4"");{} out (" "15"Bitte die Diskette eingelegt lassen! "14"");{} IF NOT einzeln{} THEN hole (datei 1);{} hole (datei 2);{} hole (datei 3);{} hole (datei 4);{} hole (datei 5);{} hole (datei 6);{} hole (datei 7);{} hole (menukarte);{} cursor (1, 3); out(""4"");{}
+ out (" "15"Die Diskette wird nicht mehr benötigt! "14"");{} release (archive){} FI.{}insertiere die dateien:{} check off;{} in (datei 1);{} in (datei 2);{} in (datei 3);{} in (datei 4);{} in (datei 5);{} in (datei 6);{} in (datei 7);{} schicke (menukarte);{} IF einzeln THEN release (archive) FI;{} check on.{}mache global manager aus der task:{} global manager.{}
+
+
+
+
diff --git a/dialog/ls-MENUKARTE:Archiv b/dialog/ls-MENUKARTE:Archiv
new file mode 100644
index 0000000..c859d22
--- /dev/null
+++ b/dialog/ls-MENUKARTE:Archiv
Binary files differ
diff --git a/doc/basic/basic handbuch.1 b/doc/basic/basic handbuch.1
new file mode 100644
index 0000000..2e604cb
--- /dev/null
+++ b/doc/basic/basic handbuch.1
@@ -0,0 +1,1075 @@
+____________________________________________________________________________
+
+
+#on("b")##on ("u")#
+#center#Betriebssystem E U M E L
+#off ("u")#
+
+
+#center#Basic
+
+
+
+
+#off("b")#
+#center#Lizenzfreie Software der
+#on ("b")#
+
+#center#Gesellschaft für Mathematik und Datenverarbeitung mbH,
+#center#5205 Sankt Augustin
+
+
+#off("b")#
+#center#Die Nutzung der Software ist nur im Schul- und Hochschulbereich für
+#center#nichtkommerzielle Zwecke gestattet.
+
+#center#Gewährleistung und Haftung werden ausgeschlossen
+
+
+____________________________________________________________________________
+#page#
+#page nr ("%", 1)#
+#head#
+EUMEL-BASIC-Compiler Inhalt %
+#end#
+
+Inhalt
+
+1 Einleitung 3
+
+2 Installation des BASIC-Compilers 4
+
+3 Aufruf und Steuerung des BASIC-Compilers 5
+
+4 Umgang mit dem BASIC-Compiler 7
+4.1 Erläuterungen zur Syntax 7
+4.2 Datentypen und Konstanten 10
+4.3 Variablen und Felder 12
+4.4 Operatoren 14
+4.5 Funktionen 19
+4.6 Typanpassung 22
+4.7 Aufruf von EUMEL-Prozeduren in BASIC-Programmen 23
+
+5 Steuerung der Bildschirmausgaben 25
+
+6 Grenzen des Compilers 26
+
+7 Fehlerbehandlung 28
+7.1 Fehler zur Übersetzungszeit 28
+7.2 Fehler zur Laufzeit 30
+
+8 Übersicht über die Anweisungen und Funktionen 31
+
+9 Anpassung von Programmen an den EUMEL-BASIC-Compiler 96
+9.1 Unterschiede zwischen BASIC-Interpretern
+ und dem EUMEL-BASIC-Compiler 96
+9.2 Abweichungen von ISO 6373-1984 (Minimal-BASIC) 97
+9.3 Anpassung von Microsoft-BASIC Programmen
+ an den EUMEL-BASIC-Compiler 98
+
+Anhang A: Reservierte Wörter 100
+Anhang B: Vom Scanner erkannte Symboltypen 103
+Anhang C: Übersicht über die Fehlermeldungen 106
+Anhang D: ELAN-Prozeduren des Compilers 113
+#page#
+
+
+#page nr ("%", 3)#
+#head#
+EUMEL-BASIC-Compiler 1. Einleitung %
+
+#end#
+
+1. Einleitung
+
+
+BASIC entspricht heute nicht mehr den Vorstellungen von einer modernen Program­
+miersprache. Dennoch wurde für das EUMEL-Betriebssystem ein Compiler für BASIC
+entwickelt. Er soll vor allem dazu dienen, schon bestehende BASIC-Programme -
+gegebenenfalls nach entsprechender Anpassung - auch unter EUMEL verfügbar zu
+machen.
+Der Compiler ist weitgehend an die ISO-Norm 6373 für Minimal-BASIC angelehnt.
+Die Syntax und Bedeutung der Anweisungen orientiert sich in den meisten Fällen an
+Microsoft-BASIC. Anweichungen treten insbesondere an den Stellen auf, an denen
+Prinzipien des Betriebssystems EUMEL verletzt würden.
+Verglichen mit dem ELAN-Compiler des EUMEL-Systems ist der BASIC-Compiler
+beim Übersetzen recht langsam. Auch aus diesem Grund scheint es nicht sinnvoll,
+den BASIC-Compiler zur Neuentwicklung größerer Programme einzusetzen.
+
+Sinn dieses Handbuchs ist es vor allem, Kenntnisse über den Umgang mit dem
+EUMEL-BASIC-Compiler zu vermitteln. Das Handbuch ist auf keinen Fall als Ein­
+führung in die Programmiersprache BASIC gedacht, sondern es soll dem Benutzer mit
+BASIC-Erfahrung die Arbeit mit dem EUMEL-BASIC-Compiler ermöglichen und
+erleichtern. Neben Erfahrung in BASIC setzt dieses Buch an einigen Stellen auch
+Grundkenntnisse über das EUMEL-System voraus.
+
+
+
+Zur #ib(4)#Notation#ie(4)# in dieser Beschreibung
+
+Bei der Beschreibung der Anweisungen und Funktionen und auch an anderen Stellen
+werden in dieser Beschreibung Syntaxregeln für BASIC-Programme oder Teile davon
+angegeben. Dabei werden folgende Zeichen mit besonderer Bedeutung verwendet:
+
+[ ] optionale Angabe
+[...] beliebig häufige Wiederholung der letzten optionalen Angabe
+| alternative Angabe, d.h. entweder die letzte links stehende Angabe oder
+ die nächste rechts stehende Angabe, aber nicht beide
+< > in spitzen Klammern stehende Begriffe sind entweder definiert (z.B. <Va­
+ riable>) oder werden hinter der Syntaxregel erläutert
+
+Die Notation der exportierten ELAN-Prozeduren des Compilers (besonders in An­
+hangD) entspricht der in den EUMEL-Handbüchern üblichen Prozedurkopf-
+Schreibweise.
+#page#
+#head#
+EUMEL-BASIC-Compiler 2. Installation des BASIC-Compilers %
+
+#end#
+
+2. #ib(3)#Installation des BASIC-Compilers#ie(3)#
+
+
+Der EUMEL-BASIC-Compiler wird auf zwei Disketten mit jeweils 360 KByte
+Speicherkapazität ausgeliefert.
+Auf der Diskette "BASIC.1" befindet sich das #ib(3)#Generatorprogramm#ie(3)#("gen.BASIC") zur
+Installation des EUMEL-BASIC-Systems.
+Legen Sie diese Diskette in das Laufwerk ihres Rechners ein und geben Sie in der
+Task, in der das BASIC-System installiert werden soll, folgende Zeile nach 'gib
+kommando :' (oder 'maintenance :') ein:
+
+archive ("BASIC.1"); fetch ("gen.BASIC", archive); run
+
+Lassen Sie die Diskette 'BASIC.1' im Laufwerk und antworten Sie auf die Frage
+"Archiv "BASIC.1" eingelegt(j/n)?" mit "j". Das Generatorprogramm holt nun einige
+Dateien von der Diskette. Nach Zugriff auf das Archiv erscheint die Meldung "Archiv
+abgemeldet!" und die Frage "Archiv 'BASIC.2' eingelegt(j/n)?". Legen Sie nun statt
+des Archivs 'BASIC.1' das Archiv 'BASIC.2' in das Laufwerk ein und drücken Sie bitte
+wiederum "j". Nach weiteren Archivoperationen erscheint dann wieder die Meldung
+"Archiv abgemeldet". Sie können nun die Diskette "BASIC.2" aus dem Laufwerk
+entnehmen.
+Das Generatorprogramm insertiert nun alle Programme des BASIC-Systems in der
+Task. Dieser Vorgang nimmt einige Zeit in Anspruch. Zum Abschluß erscheint die
+Meldung "BASIC-System installiert".
+Der EUMEL-BASIC-Compiler steht Ihnen nun in der Task (und in nachfolgend
+eingerichteten Söhnen) zur Verfügung.
+#page#
+#head#
+EUMEL-BASIC-Compiler 3. Aufruf und Steuerung des BASIC-Compilers %
+
+#end#
+
+3. #ib(4)#Aufruf und #ib(3)#Steuerung des BASIC-Compilers#ie(3)##ie(4)#
+
+
+
+
+Übersetzen von BASIC-Programmen
+
+Ein BASIC-Programm, das vom Compiler übersetzt werden soll, muß sich dazu in
+einer EUMEL-Textdatei befinden (Syntax vgl. Kap. 4.). Steht das BASIC-Programm
+zum Beispiel in der Datei "Programm.17+4", so wird der Compiler mit
+
+ #ib(3)#basic#ie(3)# ("Programm.17+4")
+
+zum Übersetzen dieses Programms aufgerufen.
+In einem Vordurchlauf werden die Zeilennummern des Programms auf Richtigkeit
+überprüft. Beim eigentlichen Compilerdurchlauf wird das BASIC-Programm dann mit
+Hilfe des EUMEL-Coders in einen von der EUMEL-0-Maschine ausführbaren Code
+übersetzt.
+
+Das Programm wird mit 'check on' (Zeilennummergenerierung) übersetzt.
+Ein 'runagain' wie bei ELAN-Programmen ist bei BASIC-Programmen zur Zeit
+leider nicht möglich.
+
+
+
+Insertieren von BASIC-Programmen
+
+Der BASIC-Compiler kann BASIC-Programme auch insertieren. Das ganze Pro­
+gramm bildet dabei eine Prozedur, die nach dem Insertieren wie eine 'normale'
+ELAN-Prozedur aufgerufen werden kann.
+Zum Insertieren wird der Compiler mit einem zusätzlichen Text-Parameter aufge­
+rufen:
+
+ #ib(3)#basic#ie(3)# ("Programm.17+4", "blackjack")
+
+Das Programm wird übersetzt und, falls keine Fehler gefunden wurden, fest einge­
+tragen ('insertiert'). Gestartet wird das Programm aber nicht.
+"blackjack" ist nun der Prozedurname, unter dem das BASIC-Programm nach erfolg­
+reichem Insertieren aufgerufen werden kann.
+Bei 'packets' erscheint jetzt der Eintrag 'BASIC.blackjack' in der Liste der insertierten
+Pakete, und ein 'help ("blackjack")' zeigt, daß eine Prozedur 'blackjack' nun tatsäch­
+lich in der Task bekannt ist. Die Prozedur 'bulletin' funktioniert für insertierte
+BASIC-Programme nicht. Sie ist aber auch nicht nötig, da das 'Paket' mit dem
+BASIC-Programm ohnehin nur eine Prozedur enthält und ihr Name ja schon aus
+dem Namen des Paketes hervorgeht.
+
+#on ("b")#
+Beachten Sie:
+ - Der Prozedurname muß der Syntax für ELAN-Prozedurnamen entsprechen, darf
+ aber #on ("b")#keine Leerzeichen enthalten.
+ - Die BASIC-Programme können über den Prozedurnamen nur aufgerufen wer­
+ den; die Übergabe von Parametern ist ebenso wie Wertlieferung nicht möglich.
+ - Jedes Insertieren belegt Speicherplatz im Codebereich der Task. Weil der Coder
+ und der Compiler ebenfalls recht viel Code belegen, kann es (vor allem, wenn
+ die BASIC-Programme lang sind) schnell zu einem Code-Überlauf kommen
+ (Compiler Error 305). Es sollten daher nur die Programme insertiert werden, für
+ die dies wirklich nötig ist.
+ - Achten Sie bei der Wahl des Namens für die gelieferte Prozedur darauf, daß sie
+ nicht ungewollt Prozeduren des Betriebssystems überdecken. (Der Aufruf 'ba­
+ sic("tadellos","help")' wäre z.B. gar nicht tadellos, denn 'help' wäre nach dem
+ Insertieren überdeckt).
+ - Auch beim Insertieren werden die BASIC-Programme mit 'check on' übersetzt.
+#off ("b")#
+
+
+Ausgabe der übersetzten Zeilen während des
+Compilierens
+Mit '#ib(3)#basic list#ie(3)# (TRUE)' wird der Compiler so eingestellt, daß beim Übersetzen die
+aktuelle Programmzeile ausgegeben wird. Diese Ausgabe kann auch mit '#ib(3)#sysout#ie(3)#'
+umgeleitet werden. Zum Beispiel:
+
+ sysout ("Fehlerprotokoll"); basic ("Programm.17+4")
+
+Dies kann beim #ib(3)#Debugging#ie(3)# von BASIC-Programmen eine wertvolle Hilfe sein, da in
+der Ausgabedatei die Fehler sofort hinter der betreffenden Programmzeile vermerkt
+werden. Das 'sysout' muß in Monitortasks ('gib kommando:') direkt vor dem Aufruf
+des Compilers gegeben werden, weil der Monitor 'sysout' sonst wieder zurücksetzt.
+
+Mit 'basic list (FALSE)' kann die Ausgabe der Programmzeilen beim Übersetzen
+wieder ausgeschaltet werden.
+
+#page#
+#head#
+EUMEL-BASIC-Compiler 4. Umgang mit dem BASIC-Compiler %
+
+#end#
+
+4. Umgang mit dem BASIC-Compiler
+
+
+
+4.1. Erläuterungen zur #ib(3)#Syntax#ie(3)#
+
+
+Ein zu übersetzendes Programm muß dem BASIC-Compiler in Form einer
+#ib(3)#EUMEL-Textdatei#ie(3)# übergeben werden. (Es gelten somit auch die für EUMEL-Text­
+dateien üblichen Begrenzungen, z.B. höchstens 32000 Zeichen pro Zeile und höch­
+stens 4075 Dateizeilen pro Datei.)
+BASIC-Programme setzen sich aus Programmzeilen zusammen; jede Dateizeile der
+#ib(3)#Programmdatei#ie(3)# bildet eine BASIC-Programmzeile. Die Syntax für ein Programm sieht
+damit so aus:
+
+
+<Programmzeile>[<Programmzeile>][...]EOF
+
+Dabei bedeutet #ib(3)#EOF (end of file)#ie(3)# das Ende der Programmdatei.
+
+Eine #ib(3)#Programmzeile#ie(3)# hat folgende Syntax:
+
+
+[<Zeilennummer>][<Anweisung>][:<Anweisung>][...][:]EOL
+
+Die #ib(3)#Zeilennummer#ie(3)# dient unter anderem als Sprungadresse an den Anfang der Pro­
+grammzeile während der Laufzeit des Programms (vgl. 'GOTO' und 'GOSUB'). Sie ist
+fakultativ (d.h. sie muß nicht geschrieben werden). Durch sparsame Verwendung von
+Zeilennummern (nämlich nur da, wo sie benötigt werden) kann eine gewisse Steige­
+rung der #ib(3)#Übersichtlichkeit von BASIC-Programmen#ie(3)# erreicht werden. Hat eine Pro­
+grammzeile keine Zeilennummer, so wird bei Fehlermeldungen (sowohl während der
+Übersetzung als auch zur Laufzeit des Programms) die letzte Zeilennummer mit
+angegeben, die davor auftrat.
+Zeilennummern dürfen im Bereich von 1 bis 32767 liegen und müssen unbedingt in
+aufsteigender Reihenfolge vergeben werden. Zeilennummern dürfen keine Leerzeichen
+enthalten und müssen mit einem Leerzeichen abgeschlossen werden. Um spätere
+Ergänzungen zu ermöglichen, ist eine Numerierung im Abstand zehn empfehlenswert.
+
+Hier ein Beispiel, wie ein BASIC-Programm in einer EUMEL-Datei aussehen
+könnte:
+
+
+...........................Einmaleins............................
+10 CLS: PRINT "Kleines Einmaleins"
+ FOR zahl% = 1 TO 10
+ PRINT
+ 'Erzeugung einer Zeile
+ FOR faktor% = 1 TO 10
+ PRINT TAB (faktor% * 5);
+ PRINT USING "\#\#\#"; faktor% * zahl%;
+ NEXT faktor%
+ NEXT zahl%
+
+
+
+
+Die Syntax der Anweisungen, die vom EUMEL-BASIC-Compiler übersetzt werden
+können, ist ausführlich im Kapitel 8 beschrieben.
+
+Der #ib(3)#Doppelpunkt#ie(3)# dient als Trennzeichen zwischen Anweisungen. Ihm muß nicht
+unbedingt eine Anweisung folgen. Er kann somit als explizites "Ende der
+Anweisung"-Symbol aufgefaßt werden (#ib(3)#EOS, "end of statement"#ie(3)#).
+
+#ib(3)#EOL (end of line)#ie(3)# ist das Ende einer Dateizeile. (Dieses "Zeichen" ist ebenso wie
+EOF beim Editieren der Datei nicht sichtbar.)
+Das #ib(3)#Hochkomma#ie(3)# ("'", Code 39) wird vom Compiler ebenfalls als EOL interpretiert.
+Alle dem Hochkomma in der Dateizeile folgenden Zeichen werden überlesen. Dies
+ermöglicht das Schreiben von Kommentaren ohne Verwendung der
+'REM'-Anweisung.
+
+Es sei hier bereits bemerkt, daß sich durch die Realisierung des Übersetzers als
+#on ("b")#Compiler gewisse Unterschiede gegenüber Interpretern #off ("b")#ergeben (siehe hierzu Kap. 9).
+Der wesentliche Unterschied ist, daß der Interpreter dem Programmtext analog zum
+Programmablauf folgt, der Compiler das Programm aber von vorne bis hinten Zeile für
+Zeile übersetzt. Dies hat zur Folge, daß z.B. die Dimensionierungen von Feldvariablen
+#on ("b")#textuell vor der Verwendung der Variablen stattfinden müssen#off ("b")# und nicht, wie bei
+Interpretern, nur im Ablauf des Programms vorher ausgeführt werden müssen.
+
+
+
+Weitere Schreibregeln
+
+#on ("b")#
+1. #ib(3)#Groß-/Kleinschreibung#ie(3)##off ("b")#
+Für den BASIC-Compiler bestehen zwischen kleinen und großen Buchstaben keiner­
+lei Unterschiede, es sei denn es handelt sich um Textdenoter (Textkonstanten).
+Daher können alle #ib(3)#Schlüsselwörter#ie(3)# und #ib(3)#Variablennamen#ie(3)# mit kleinen oder großen
+Buchstaben geschrieben werden. Aus der Tatsache, daß zwischen großen und kleinen
+Buchstaben nicht unterschieden wird, folgt aber bespielsweise auch, daß die Variab­
+lennamen (vgl. 4.3.) 'hallo' und 'HALLO' ein und dieselbe Variable bezeichnen.
+
+#on ("b")#
+2. #ib(3)#Reservierte Wörter#ie(3)##off ("b")#
+Der BASIC-Compiler erkennt eine ganze Reihe #on("i")#reservierter Wörter#off("i")#. Es handelt sich
+hierbei im wesentlichen um die Namen der Anweisungen und Funktionen. Sie sollten
+im eigenen Interesse darauf achten, daß sich sowohl vor als auch hinter reservier­
+ten Wörtern stets mindestens ein #on ("b")##ib(3)#Leerzeichen#ie(3)##off ("b")# (Blank) befindet. Der #ib(3)#Scanner#ie(3)# (ver­
+gleiche AnhangB) erkennt zwar manchmal die reservierten Wörter auch ohne Leer­
+zeichen, aber unter bestimmten Umständen kann es auch zu erkannten oder - noch
+schlimmer - vom Compiler unerkannten Fehlern kommen.
+Hierzu zwei Beispiele:
+Die Anweisung 'IF a > b THENPRINT "größer"' führt beim Compilieren zur Fehler­
+meldung "Syntaxfehler: THEN oder GOTO erwartet".
+Wesentlich gefährlicher ist da schon die Programmzeile
+ "LEThallo = 3 : PRINT hallo",
+denn die unerwartete Wirkung ist die Ausgabe von "0" auf dem Bildschirm. Der Wert
+"3" wurde nämlich nicht der Variablen mit dem Namen "hallo" zugewiesen, sondern
+einer Variablen namens "LEThallo".
+
+#on ("b")#
+3. Bedeutung der #ib(3)#Leerstelle#ie(3)# ("Blank") für den Compiler#off("b")#
+Wie schon aus dem vorhergehenden Punkt ersichtlich kann das Fehlen von trennen­
+den Leerstellen unschöne Effekte haben, denn der #ib(3)#Scanner#ie(3)# (vgl. AnhangB) des
+BASIC-Compilers erkennt anhand der Leerstelle (Code 32) beim Durchlauf durch das
+Programm, daß ein #ib(3)#Symbol#ie(3)# zu Ende ist.
+Es kommt somit immer dann zu Fehlern, wenn zwei Symbole (z.B. reservierte Wörter,
+Konstanten, Variablen etc.) nicht durch Leerzeichen getrennt sind, und der Scanner
+sie als ein Symbol "versteht".
+Beispiel:
+ "a = 3 : b = 4 : PRINT a b" erzeugt die Ausgabe "34".
+ "a = 3 : b = 4 : PRINT ab" erzeugt hingegen die Ausgabe "0", denn der
+Compiler sieht "ab" als #on ("b")#einen Variablennamen an. #off ("b")#
+
+
+
+4.2. #ib(3)#Datentypen#ie(3)# und #ib(3)#Konstanten#ie(3)#
+
+
+Der EUMEL-BASIC-Compiler unterscheidet grundsätzlich zwischen zwei Daten­
+typen, nämlich zwischen #ib(3)#Texte#ie(3)#n und #ib(3)#Zahlen#ie(3)#.
+
+#on ("b")#
+#ib(3)#Datentyp TEXT#ie(3)# #off ("b")#
+Texte dürfen alle Zeichen enthalten (Codes 0 bis 255) und bis zu 32000 Zeichen lang
+sein.
+Die zugehörigen Konstanten werden von #ib(3)#Anführungszeichen#ie(3)# begrenzt, z.B.:
+ "Anzahl Einträge: "
+ "2.32 DM"
+ "General-Musik-Direktor"
+Anführungszeichen (Code 34) dürfen #on("i")#innerhalb#off("i")# von Text-Konstanten nicht vor­
+kommen.
+
+Bei Zahlen unterscheidet der Compiler noch zwischen #ib(3)#INTs#ie(3)# (#ib(3)#Ganzzahlen#ie(3)#) und REALs
+(#ib(3)#Gleitkommazahlen#ie(3)#). Diese entsprechen im Hinblick auf den Wertebereich genau den
+in ELAN bekannten INTs und REALs.
+
+#on ("b")#
+#ib(3)#Datentyp INT#ie(3)# #off ("b")#
+INT-Werte dürfen zwischen -32768 und 32767 liegen. INT-Konstanten dürfen aber
+#on("i")#nur#off("i")# aus Ziffern und einem optionalen '%'-Zeichen am Ende bestehen. Das bedeutet,
+daß die INT-Konstanten im Bereich von 0 bis 32767 liegen können.
+Ein nachgestelltes '%'-Zeichen kennzeichnet eine Konstante nochmals explizit als
+INT. (Diese Option wurde aus Kompatibilitätsgründen implementiert.)
+
+#on ("b")#
+#ib(3)#Datentyp REAL#ie(3)# #off ("b")#
+REALs können Werte zwischen -9.999999999999*10#u#126#e# und
+9.999999999999*10#u#126#e# annehmen.
+Die kleinste positive von Null verschiedene Zahl ist 9.999999999999*10#u#-126#e#.
+Der kleinste REAL-Wert mit x + 1.0 > 1.0 ist gleich 10#u#-12#e#.
+REAL-Konstanten werden gebildet aus Vorkommastellen, Dezimalpunkt, Nachkom­
+mastellen, Zeichen "E" oder "D" (jeweils auch klein) für den #ib(3)#Exponent#ie(3)#en gefolgt vom
+Vorzeichen und den Ziffern des Exponenten.
+Dabei müssen nicht für jede REAL-Konstante alle diese Elemente benutzt werden.
+Unverzichtbar sind #on("i")#entweder#off("i")# der Dezimalpunkt #on("i")#oder#off("i")# der Exponent. Ebenso müssen
+zumindest entweder Vor- oder Nachkommastellen vorhanden sein.
+
+Beispiele für gültige REAL-Konstanten sind:
+ 0.
+ .01
+ 1E-17
+ 2.9979D8
+ .3e-102
+ 100.e+7
+
+Nicht erlaubt sind dagegen folgende Schreibweisen für REAL-Konstanten:
+ e12 (#ib(3)#Mantisse#ie(3)# fehlt)
+ 100 (ist INT-Konstante)
+ . (weder Vor- noch Nachkommastellen)
+ .E-12 (dito)
+ 1exp-3 ('exp' nicht erlaubt)
+ -1.99e30 (Mantisse hat Vorzeichen)
+
+Das letzte Beispiel zeigt, daß auch vor REAL-Konstanten keine #ib(3)#Vorzeichen#ie(3)# erlaubt
+sind. Da normalerweise keine REAL-Konstanten, sondern vielmehr numerische
+Ausdrücke verlangt werden, können durch Voranstellen des Operators '-' (vgl. 4.4.)
+auch #ib(3)#negative Zahlenwerte#ie(3)# leicht erzeugt werden.
+
+An REAL-Konstanten darf eines der Zeichen "!" und "\#" angehängt werden. Diese
+Option wurde aus Kompatibilitätsgründen eingebaut. Wird ein "!" oder "\#" an eine
+INT-Konstante angehängt, so verwandelt es diese in eine REAL-Konstante.
+Beispiel: 10000! oder 10000\# entspricht 10000. oder 1E4
+
+
+#page#
+
+4.3. Variablen und Felder
+
+
+Variablen
+
+Der BASIC-Compiler stellt für die in 4.2. vorgestellten Datentypen TEXT, INT und
+REAL auch Variablen zur Verfügung.
+Die #ib(3)#Variablennamen#ie(3)# müssen folgenden Bedingungen genügen:
+- Ein Variablenname muß mit einem Buchstaben beginnen.
+- Variablennamen dürfen ab der zweiten Stelle außer Buchstaben auch Ziffern, Dezi­
+ malpunkte sowie die Zeichen "!", "\#", "$" und "%" enthalten. Leerzeichen dürfen
+ in Variablennamen dagegen nicht vorkommen.
+- Variablennamen dürfen nicht mit FN beginnen (vgl. 4.5. benutzer-definierte Funk­
+ tionen).
+- #ib(3)#Reservierte Wörter#ie(3)# (siehe Anhang A) dürfen kein Variablenname sein. Als Teiltexte
+ dürfen reservierte Wörter aber in Variablennamen enthalten sein (auch am Anfang).
+
+Variablennamen dürfen beliebig lang sein, und alle Zeichen eines Variablennamens
+sind signifikant.
+
+Welchen Typ eine Variable hat, entscheidet der Compiler nach folgenden #ib(3)#Kriterien#ie(3, " für den Typ einer Variablen")# (in
+der Reihenfolge ihrer Beachtung):
+- Ist das letzte Zeichen des Namens ein "!" oder "\#", so bezeichnet er eine
+ REAL-Variable.
+- Ist das letzte Zeichen ein "%", so handelt es sich um eine INT-Variable.
+- Ist das letzte Zeichen des Namens ein "$", so ist die Variable vom Typ TEXT.
+- Liegt das erste Zeichen des Namens im Bereich der mit einer #ib(3)#DEFINT#ie(3)#-Anweisung
+ (vgl. Kap. 8) festgelegten Buchstaben, so ist die Variable eine INT-Variable.
+- Liegt das erste Zeichen im Bereich der mit einer #ib(3)#DEFSTR#ie(3)#-Anweisung (vgl. Kap. 8)
+ festgelegten Buchstaben, so handelt es sich um eine TEXT-Variable.
+- Wenn keine der obigen Bedingungen erfüllt ist, dann bezeichnet der Name eine
+ Variable des Datentyps REAL.
+
+Variablen, denen noch kein Wert zugewiesen wurde, haben den Inhalt null (bei INT
+und REAL) beziehungsweise Leertext (bei TEXT).
+
+
+
+Felder (#ib(4)#Arrays#ie(4)#)
+
+Ein Feld (Array) ist eine Ansammlung von mehreren Variablen gleichen Typs. Jedes
+Feld hat einen Namen. Für die #ib(3)#Feldnamen#ie(3)# gelten die gleichen Regeln wie für die
+Namen von normalen Variablen. Auch die Datentypen werden nach den gleichen
+Kriterien bestimmt wie bei einfachen Variablen.
+In einem Feld können die Elemente in bis zu 100 #ib(3)#Dimensionen#ie(3)# abgelegt werden. Auf
+ein Element eines Feldes wird über den Feldnamen und den Index / die #ib(3)#Indizes#ie(3)# des
+Elements zugegriffen. Beim Zugriff auf das Element müssen so viele Indizes ange­
+geben werden, wie das Feld Dimensionen hat.
+Beispiel:
+Das Feld 'tabelle' habe zwei Dimensionen. Mit 'tabelle (3, 5)' wird auf das Element
+mit dem Index 3 in der ersten Dimension und dem Index 5 in der zweiten Dimension
+zugegriffen.
+
+Beim ersten Zugriff auf ein Element eines Feldes wird anhand der Zahl der Indizes
+die Anzahl der Dimensionen festgestellt und das Feld so eingerichtet, daß in jeder
+Dimension der größte Index zehn ist.
+Soll ein Feld mit anderen größten Indizes eingerichtet werden, so muß hierzu die
+#ib(3)#DIM#ie(3)#-Anweisung verwendet werden (siehe Kapitel 8).
+
+Der kleinste Index ist voreingestellt auf null, kann aber mit der #ib(3)#OPTION BASE#ie(3)#-
+Anweisung (vgl. Kap. 8) auch auf eins eingestellt werden.
+
+Die Elemente eines Feldes sind, wie auch die einfachen Variablen, mit den Werten
+null (INT und REAL) beziehungsweise Leertext (TEXT) vorbesetzt, sofern ihnen noch
+nichts zugewiesen wurde.
+
+#page#
+
+4.4. Operatoren
+
+Nachfolgend sind alle Operatoren aufgelistet, die vom EUMEL-BASIC-Compiler
+übersetzt werden.
+
+
+Arithmetische #ib(4)#Operatoren#ie(4, ", arithmetische")#
+
+#ib(3)##ie(3, "+")##ib(3)##ie(3, "-")##ib(3)##ie(3, "*")##ib(3)##ie(3, "/")#
+#ib(3)##ie(3, "\")##ib(3)##ie(3, "MOD")##ib(3)##ie(3, "^")#
+
+ Operand(en) Zweck Ergebnistyp
+
+ + INT positives Vorzeichen INT
+ REAL positives Vorzeichen REAL
+
+ INT, INT INT-Addition INT
+ REAL, REAL REAL-Addition REAL
+
+ - INT negatives Vorzeichen INT
+ REAL negatives Vorzeichen REAL
+
+ INT, INT INT-Subtraktion INT
+ REAL, REAL REAL-Subtraktion REAL
+
+ * INT, INT INT-Multiplikation INT
+ REAL, REAL REAL-Multiplikation REAL
+
+ / (INT, INT) #linefeed (0.5)#
+ REAL-Division REAL
+ REAL, REAL #linefeed (1.0)#
+
+ \ INT, INT #linefeed (0.5)#
+ INT-Division INT
+ (REAL, REAL) #linefeed (1.0)#
+
+MOD INT, INT INT-Divisionsrest INT
+ REAL, REAL Divisionsrest nach REAL
+ Runden auf Ganzzahl (nicht INT)
+
+ ^ (INT, INT) #linefeed (0.5)#
+ Potenzierung REAL
+ REAL, REAL #linefeed (1.0)#
+
+
+#on ("b")#
+Hinweis: #off ("b")#
+Wird ein Operator mit numerischen Operanden unterschiedlichen Typs (also INT und
+REAL) aufgerufen, so wird der INT-Operand nach REAL konvertiert und der Operator
+mit den beiden REAL-Operanden aufgerufen.
+Sind die Operandtypen in Klammern angegeben, so werden vor Ausführung der Ope­
+ration die Operanden zu den nicht eingeklammerten Typen konvertiert.
+Da jede #ib(3)#Konvertierung#ie(3)# Zeit benötigt, sollte der Benutzer darauf achten, daß möglichst
+wenig konvertiert werden muß.
+Hierzu ein (etwas extremes, aber nicht seltenes) Beispiel:
+Der Aufruf a%\b bewirkt zunächst eine Konvertierung von a% nach REAL:
+CDBL(a%)\b. Intern wird die Berechnung dann aber wieder mit INTs ausgeführt:
+CINT(CDBL(a%))\CINT(b). Das Ergebnis wird also erst nach drei Konvertierungen
+geliefert. Schreibt man dagegen sofort a%\CINT(b), dann reicht eine Konvertierung
+aus.
+
+Es muß außerdem bei den Operatoren +, - und * für INTs darauf geachtet werden,
+daß das Ergebnis innerhalb des INT-Wertebereichs liegen muß, da es sonst zu
+einem #ib(3)#INT-Überlauf#ie(3)# kommt.
+
+
+
+Text-Operator #ib(4)#+#ie(4)#
+
+#ib(3)##ie(3, "Operatoren, Text-")#
+Für Text-Manipulationen wird der Operator '+' mit zwei TEXT-Operanden zur
+Verfügung gestellt. Mit '+' werden zwei Texte aneinandergehängt (konkateniert).
+
+
+
+Vergleichsoperatoren#ib(4)##ie(4, "Operatoren, Vergleichs-")#
+
+Im EUMEL-BASIC gibt es folgende Vergleichsoperatoren:
+
+#ib(3)#=#ie(3)# gleich
+#ib(3)#<>#ie(3)# ungleich
+#ib(3)#<#ie(3)# kleiner
+#ib(3)#>#ie(3)# größer
+#ib(3)#<=#ie(3)# kleiner oder gleich
+#ib(3)#>=#ie(3)# größer oder gleich
+
+Bei den numerischen Datentypen werden mit den Vergleichsoperatoren die Zahlen­
+werte verglichen.
+Sollen ein INT und ein REAL verglichen werden, dann wird der INT vorher nach
+REAL konvertiert und ein REAL-Vergleich vorgenommen.
+
+Bei Texten dienen die Vergleichsoperatoren zum Vergleich der Zeichencodes. Dies
+ermöglicht zum Beispiel ein alphabetisches Sortieren von Wörtern, mit der Einschrän­
+kung, daß Groß- und Kleinbuchstaben unterschiedliche Zeichencodes haben (ver­
+gleiche EUMEL-Zeichensatz-Tabelle im Benutzerhandbuch) und somit verschieden
+eingeordnet werden.
+Es gilt a$ < b$, wenn die Zeichenkette in a$ codemäßig vor der Zeichenkette in b$
+ steht: "a" < "b" (TRUE) "aa"< "a" (FALSE)
+
+
+Die Vergleichsoperatoren liefern, je nachdem ob die Aussage wahr oder falsch ist, die
+INT-Werte 0 (falsch) oder -1 (wahr).
+Anhand des Ergebnisses einer Vergleichsoperation kann zum Beispiel der Programm­
+ablauf gesteuert werden (siehe Kapitel 8, IF-Anweisung).
+
+
+
+Logische Operatoren
+
+#ib(3)##ie(3, "Operatoren, logische")#
+Die logischen Operatoren haben zwei Aufgaben:
+1. logische (Boolsche) Verknüpfung von #ib(3)#Wahrheitswerte#ie(3)#n, die zum Beispiel von
+ Vergleichsoperationen geliefert werden und
+2. bitweise Ausführung von logischen Verknüpfungen auf den internen (Zweierkom­
+ plement-) Darstellungen von INT-Werten.
+
+Da für beide Aufgaben die gleichen Operatoren benutzt werden, wurden für die Wahr­
+heitswerte die INT-Werte 0 für falsch (Bitmuster: 0000000000000000) und -1 für
+wahr (Bitmuster: 1111111111111111) gewählt.
+
+ Operand(en) Zweck insbesondere gilt
+
+#ib(3)#NOT#ie(3)# INT #linefeed (0.5)# NOT0->-1
+ #ib(3)#Negation#ie(3)#
+ (REAL) #linefeed (1.0)# NOT-1->0
+
+#ib(3)#AND#ie(3)# INT, INT #ib(3)#UND-Verknüpfung#ie(3)# 0AND0->0
+ 0AND-1->0
+ -1AND0->0
+ -1AND-1->-1
+
+ #ib(3)#OR#ie(3)# INT, INT #ib(3)#ODER-Verknüpfung#ie(3)# 0OR0->0
+ 0OR-1->-1
+ -1OR0->-1
+ -1OR-1->-1
+
+#ib(3)#XOR#ie(3)# INT, INT #ib(3)#Exklusiv-ODER-Verknüpfung#ie(3)# 0XOR0->0
+ 0XOR-1->-1
+ -1XOR0->-1
+ -1XOR-1->0
+
+#ib(3)#EQV#ie(3)# INT, INT #ib(3)#Äquivalenz-Verknüpfung#ie(3)# 0EQV0->-1
+ 0EQV-1->0
+ -1EQV0->0
+ -1EQV-1->-1
+
+#ib(3)#IMP#ie(3)# INT, INT #ib(3)#Implikations-Verknüpfung#ie(3)# 0IMP0->-1
+ 0IMP-1->-1
+ -1IMP0->0
+ -1IMP-1->-1
+
+
+
+Prioritäten der Operanden
+
+
+Hier die Übersicht über alle Operatoren in der Reihenfolge ihrer Ausführung
+
+
+ Operator Priorität
+
+ ^ Potenzierung 13
+ +, - positives/negatives Vorzeichen 12
+ *, / Multiplikation, REAL-Division 11
+ \ INT-Division 10
+ MOD Divisionsrest- (MOD-) Operation 9
+ +, - Addition, Subtraktion 8
+ =, <>, <, >, <=, >= Vergleichsoperatoren 7
+ NOT Negation 6
+ AND UND-Verknüpfung 5
+ OR ODER-Verknüpfung 4
+ XOR Exklusiv-ODER-Verknüpfung 3
+ EQV Äquivalenz-Verknüpfung 2
+ IMP Implikations-Verknüpfung 1
+
+
+Die Reihenfolge der Auswertung von Ausdrücken kann durch Klammern geändert
+werden.
+
+Beachten Sie, daß der Operator '=' in BASIC die Funktion eines Vergleichsoperators
+und des #ib(3)#Zuweisungsoperators#ie(3)##ib(3)##ie(3, "Operator, Zuweisungs-")# (siehe Kapitel 8, LET-Anweisung) hat.
+
+#page#
+
+4.5. #ib(3)#Funktionen#ie(3)#
+
+
+
+Standard-Funktionen
+
+Der EUMEL-BASIC-Compiler unterstützt eine ganze Reihe von Funktionen. Diese
+Funktionen liefern Werte und können in Ausdrücken zusammen mit Konstanten,
+Variablen und Operatoren verwendet werden.
+Viele der eingebauten Funktionen arbeiten mit Argumenten, das heißt es werden den
+Funktionen Werte übergeben.
+In Kapitel 8 dieses Handbuches sind alle Funktionen ausführlich beschrieben.
+Beispiele für #ib(3)#Funktionsaufrufe#ie(3)#:
+ SQR (17) Dieser Ausdruck liefert die Wurzel von 17 als REAL.
+ RIGHT$ (text$, 5) Dieser Ausdruck liefert die letzten fünf Textzeichen
+#right#aus 'text$' als TEXT.
+
+
+
+Benutzer-definierte Funktionen
+
+Neben der Verwendung der standardmäßig verfügbaren Funktionen besteht für den
+Benutzer die Möglichkeit, selbst Funktionen innerhalb eines Programms zu definieren.
+
+#on ("b")#
+#ib(3)#Definition benutzer-definierter Funktionen#ie(3)# #off ("b")#
+Hierzu dient die #ib(3)#DEF FN#ie(3)#-Anweisung (vergleiche Kapitel 8).
+Die Syntax der DEF FN-Anweisung lautet:
+
+DEFFN<Name>[(<Parameter>[,<Parameter>][...])]=
+#right#<Funktionsdefinition>
+
+<Name>: Zeichenfolge, die der Syntax für Variablennamen ent­
+ sprechen muß.
+ FN<Name> bilden zusammen den Namen der neuen
+ Funktion.
+<#ib(3)#Parameter#ie(3)#>: Zeichenfolge, die der Syntax für Variablennamen ent­
+ sprechen muß.
+<Funktionsdefinition>: Ausdruck, der Konstanten, Variablen, die Parameter der
+ Funktion und Aufrufe anderer Funktionen enthalten
+ darf.
+
+- Die benutzer-definierten Funktionen ("user functions") liefern, genau wie die
+ Standard-Funktionen, Werte.
+- Das letzte Zeichen des Funktionsnamens gibt den Typ des Wertes an, den die
+ Funktion liefert. Soll die Funktion einen TEXT liefern, so muß der Name mit "$"
+ enden. Soll ein INT geliefert werden, muß der Name mit "%" enden. Für alle
+ anderen Endungen wird eine REAL-liefernde Funktion eingetragen.
+- Die Syntax der Parameternamen entspricht der Syntax für die Namen von einfachen
+ Variablen.
+- Die Parameter haben nur bei der Definition Gültigkeit. Hierbei 'überdecken' sie (für
+ diese Zeile) eventuell im BASIC-Programm vorhandene gleichnamige Variablen.
+- Jeder Parameter darf in der Parameterliste nur einmal vorkommen.
+- Bezeichnet der Funktionsname eine TEXT-liefernde Funktion, so muß auch die
+ Funktionsdefinition ein Ergebnis vom Typ TEXT liefern. Zwischen INTs und REALs
+ findet eine Typanpassung statt.
+- Eine Funktion darf nicht in ihrer eigenen Definition erscheinen.
+- Eine Funktion ist allein durch ihren Namen gekennzeichnet. Generische Funktionen
+ (gleicher Name, aber unterschiedliche Parameter) können somit nicht definiert wer­
+ den.
+
+Beispiele für gültige Funktionsdefinitionen:
+ DEF FNPI = 3.1415927
+ DEF FNumfang (radius) = 2.0 * FNPI * radius (Enthält Aufruf von FNPI)
+ DEF FNhallo$ (dummy$) = "Hallo " + name$ (name$ kommt im
+ #right#BASIC-Programm vor)
+ DEF FNheavyside% (x) = ABS (SGN (x) = 1)
+
+Beispiele für ungültige Funktionsdefinitionen:
+ DEF FNfunct (a, b, a) = a ^ 2 + b (a kommt zweimal als Parameter vor)
+ DEF FNfr (x) = x * FNfr (x - 1) (rekursive Definition)
+
+
+#on ("b")#
+#ib(3)#Aufruf benutzer-definierter Funktionen#ie(3)# #off ("b")#
+
+FN<Name> [ ( <Argument> [, <Argument>] [...] ) ]
+
+<#ib(3)#Argument#ie(3)#> : Ausdruck, der für den entsprechenden Parameter bei der Evaluation
+ (Auswertung) der Funktion eingesetzt werden soll
+
+- Beim Funktionsaufruf werden die Argumente in der Reihenfolge ihres Auftretens für
+ die Parameter eingesetzt. Für TEXT-Parameter müssen die Argumente ebenfalls
+ TEXTe liefern. Zwischen INTs und REALs findet eine Typanpassung statt.
+- Die Anzahl der Argumente muß genau mit der Anzahl der Parameter übereinstim­
+ men.
+- Für in der Funktionsdefinition vorkommende Variablen wird der zum Zeitpunkt des
+ Funktionsaufruf gültige Wert eingesetzt.
+- Die Definition der Funktion muß dem ersten Aufruf der Funktion textuell voraus­
+ gehen.
+- Eine Definition gilt für alle textuell folgenden Aufrufe, bis die Funktion wieder neu
+ definiert wird.
+
+Beispiele für korrekte Funktionsaufrufe (bezogen auf obige Beispiel-Definitionen):
+ PRINT FNPI / 2.0 (Ausgabe: 1.570796)
+ PRINT FNumfang (20) (Ausgabe: 125.6637)
+ LET name$ = "Purzelbär":PRINT FNhallo$ ("") (Ausgabe: Hallo Purzelbär)
+ PRINT heavyside% (-17.3) (Ausgabe: 0)
+
+Beispiele für falsche Funktionsaufrufe (bezogen auf obige Beispiel-Definitionen):
+ PRINT FNPI (10) (kein Argument erwartet)
+ PRINT FNumfang (Argument erwartet)
+ PRINT FNhallo$ (zahl%) (Falscher Typ des Arguments)
+ PRINT FNheavyside (17.4, -12.3) (Zu viele Argumente)
+
+
+#page#
+
+4.6. #ib(3)#Typanpassung#ie(3)#
+
+
+In BASIC wird, im Gegensatz zu ELAN, nicht sehr streng zwischen den numerischen
+Datentypen unterschieden, sondern es finden häufig automatische Typanpassungen
+statt. Zu solchen Typanpassungen kommt es vor allem bei der Zuweisung, bei Opera­
+toren und bei Funktionen, aber auch bei einigen Anweisungen.
+Die automatische Typanpassung hat zwei Nachteile:
+1. Die Typkonvertierung von INT nach REAL und umgekehrt kostet Zeit während der
+ Programmausführung.
+2. Es kann zu sehr unangenehmen Laufzeitfehlern kommen, wenn eine REAL-
+ INT-#ib(3)#Konvertierung#ie(3)# mit Fehler abbricht, weil der REAL-Wert außerhalb des
+ INT-Wertebereichs liegt.
+
+Allgemein gilt also, daß sich der Programmierer auch in BASIC über die Typen der
+verwendeten Objekte im klaren sein sollte. Außerdem ist zu beachten, daß bei Konver­
+tierungen von REAL nach INT immer gerundet wird.
+
+Genaueres zur Typanpassung bei der Zuweisung finden Sie in Kapitel 8 bei der
+LET-Anweisung.
+Über Typkonvertierung bei Operatoren informiert Kapitel 4.4.
+Informationen über die Funktionen betreffenden Typkonvertierungen befinden sich am
+Anfang von Kapitel 8 und direkt bei der Beschreibung der jeweiligen Funktionen
+(ebenfalls in Kapitel 8).
+
+#page#
+
+4.7. Aufruf von EUMEL-Prozeduren in
+ BASIC-Programmen
+
+
+
+Der EUMEL-BASIC-Compiler bietet die Möglichkeit, insertierte ELAN-Prozeduren
+(und auch insertierte BASIC-Programme) in BASIC-Programmen aufzurufen. Hierzu
+werden die beiden Anweisungen #ib(3)#CALL#ie(3)# und #ib(3)#CHAIN#ie(3)# (identisch) sowie die Funktion
+#ib(3)#USR#ie(3)# zur Verfügung gestellt.
+Mit der CALL-Anweisung (siehe auch Kapitel 8) können Prozeduren aufgerufen
+werden, die keinen Wert liefern und nur die BASIC-Datentypen INT, REAL und/oder
+TEXT als Parameter benötigen.
+Beispiele:
+ CALL list
+ CALL taskstatus ("PUBLIC")
+ CALL cursor (10, 21)
+ CALL getcursor (x%, y%)
+
+Das letzte Beispiel zeigt, daß auch #ib(3)#VAR-Parameter#ie(3)# im ELAN-Sinne übergeben
+werden können.
+
+Die Funktion USR dient im Gegensatz zu CALL zum Aufruf von #ib(3)#wertliefernden Pro­
+zeduren#ie(3)#. Die Prozeduren dürfen allerdings nur einen der BASIC-Datentypen INT,
+REAL oder TEXT liefern. Es gilt auch bei USR, wie bei CALL, daß die aufgerufenen
+Prozeduren nur Parameter der Typen INT, REAL oder TEXT haben dürfen. </