summaryrefslogtreecommitdiff
path: root/app/mpg/2.2/src/PUBLIC.insert
blob: 9fb98a63ee99a33ad0883f633a890955d32e0b9a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
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
91
92
93
94
95
96
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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
(* Rainer Kottmann  *) 
(* Klaus Bovermann  *) 
(* Lutz Prechelt    *) 
(* Carsten Weinholz *)
(* 19.06.87         *) 
 
(* Pakete :   1. mpg test elan programs 
              2. mpg archive system    <---  **************************
              3. mpg some              <---  Sind für seperaten Hamster 
              4. mpg dm                <---  notwendig.
              5. mpg tools             <---  **************************
              6. mpg target handling 
              7. mpg print cmd 
              8. edit monitor 
              9. mpg global manager *) 
 
(************************* ELAN TEST ****************************) 
 
PACKET mpg test elan programs DEFINES elan test :

LET  scan end           = 7,
     in comment         = 8,
     in text            = 9,
     bold               = 2,
     char               = 4,
     delimiter          = 6,
     limit              = 77,
     max denoter length = 255,
     end bolds     = "ENDIFIENDSELECTENDREPEATPERENDPROCEDURENDPACKETENDOP",
     w                  = "WARNING: ",
     e                  = "ERROR  : ";

INT  VAR zeile;
FILE VAR err;
TEXT VAR last error;


PROC elan test :
  elan test (last param)
END PROC elan test;

PROC elan test (TEXT CONST datei) :
  INT  VAR byte :: 0, kbyte :: 0, (* Byte/Kilobyte der EUMEL Datei      *)
           sbyte:: 0, skbyte:: 0, (* Byte/Kilobyte des Elan Quelltextes *)
           denoter length :: 0, units :: 0, typ, scan operations :: 0,
           round brackets :: 0, square brackets :: 0; (* Klammerzaehler *) 
  TEXT VAR in, symbol;
  FILE VAR inputfile :: sequential file (input , datei);
  err := note file;
  zeile := 0;
  last error := "";
  scan (""); next symbol (in);
  WHILE NOT eof (inputfile) REP
    naechste zeile;
    analyse;
    in := incharety
  UNTIL in <> "" PER;
  IF in <> ""
  THEN putline (err, "***  ELAN TEST VORZEITIG ABGEBROCHEN ***")  FI;
  last error := "";
  ausgabe der enddaten;
  modify (inputfile);
  note edit (inputfile);
  line.

naechste zeile :
  getline (inputfile , in);
  continue scan (in);
  byte  INCR LENGTH in;
  kbyte INCR byte DIV 1000;
  byte  := byte MOD 1000;
  zeile INCR 1; cout (zeile);
  IF LENGTH in > limit
  THEN error (w + "line exceeding screen")
  FI.

analyse :
  REPEAT
    next symbol (symbol, typ);
    scan operations INCR 1;
    analysiere symbol
  UNTIL typ >= scan end
  PER;
  IF typ = in comment
  THEN error (w + "comment exceeding line")
  FI;
  IF typ = in text
  THEN denoter length INCR LENGTH symbol;
       IF denoter length > max denoter length
       THEN error (e + "text denoter too long (" + text (denoter length) +
                       " characters)")
       ELSE error (w + "text denoter exceeding source line")
       FI
  ELSE denoter length := 0
  FI;
  skbyte INCR sbyte DIV 1000;
  sbyte  := sbyte MOD 1000.

analysiere symbol :
  IF   typ = scan end    THEN test brackets
  ELIF typ = delimiter   THEN delimiters
  ELIF typ = char
  THEN denoter length INCR LENGTH symbol;
       IF denoter length > max denoter length
       THEN error (e + "text denoter too long (" + text (denoter length) +
                       " characters)")
       FI
  ELIF typ = bold CAND pos (endbolds, symbol) <> 0 
  THEN unitend
  FI;
  sbyte INCR LENGTH symbol.

test brackets :
  IF round brackets <> 0
  THEN error (w + text (round brackets) + " ""("" open")
  FI;
  IF square brackets <> 0
  THEN error (w + text (square brackets) + " ""["" open")
  FI.

delimiters :
  IF   symbol = ";" OR (symbol = "." AND is refinement)
  THEN unitend
  ELIF symbol = "(" THEN round  brackets INCR 1
  ELIF symbol = ")" THEN round  brackets DECR 1
  ELIF symbol = "[" THEN square brackets INCR 1
  ELIF symbol = "]" THEN square brackets DECR 1
  FI.

unitend :
  units INCR 1;
  IF round brackets <> 0
  THEN error (e + text (round brackets) + " ""("" open at end of unit");
    round brackets := 0
  FI;
  IF square brackets <> 0
  THEN error (e + text (square brackets) + " ""["" open at end of unit");
    square brackets := 0
  FI.

is refinement :   FALSE.    (* vorlaeufig *)

ausgabe der enddaten :
  line (err);
  putline (err, 77 * "=");
  putline (err, "EUMEL - Datei     :  " + text (zeile) + " Zeilen ,  " +
                bytes (kbyte, byte));
  putline (err, "Elan  - Quelltext :  " + text (units) + " Units  ,  " + 
                bytes (skbyte, sbyte));
  putline (err, text (scan operations) +
                " Scanner - Operationen durchgefuehrt.");
  putline (err, 77 * "=").
END PROC elan test;
 
PROC error (TEXT CONST error message) :
  IF error message = last error
  THEN putline (err, "dito   " + text (zeile));
       IF online THEN put (zeile); putline ("dito")  FI;
       LEAVE error  FI;
  last error := error message;
  putline (err, "EOLN " + text (zeile) + "  " + error message);
  IF online THEN put (zeile); putline (error message)  FI
END PROC error;

TEXT PROC bytes (INT CONST kilobytes, bytes) :
  TEXT VAR t :: text (kilobytes);
  IF   bytes < 10  THEN t CAT "00"
  ELIF bytes < 100 THEN t CAT "0"
  FI;
  t CAT text (bytes);
  t CAT " Byte";
  t
END PROC bytes

END PACKET mpg test elan programs;

(************************* ARCHIV **********************************)
 
PACKET mpg archive system DEFINES reserve, archive, release, 
                                  archiv, archiv name,archiv error,
                                  archiv angemeldet,
                                  from, to,
                                  pla : 
 
 
LET archive 0 code      = 90,
    archive 1 code      = 91,
    altos archive 0     =  0,
    altos archive 1     =  1,
    bicos archive 0     =  2, 
    altos station       =  1, 
    free code           = 20,
    reserve code        = 19, 
    type                = "#type (""micron"")#",
    configurator        = "configurator";

BOOL VAR angemeldet;
TEXT VAR err :: "";

(************************ Standard - Prozeduren ****************************)
(* Erlaubt jedoch nur eine ARCHIVE-Task                                    *)
 
PROC reserve (TASK CONST task): 
  reserve ("", task) 
END PROC reserve; 
 
PROC reserve (TEXT CONST msg, TASK CONST task): 
   IF task = archive 
      THEN angemeldet := TRUE 
   FI; 
   call (reserve code, msg, task) 
END PROC reserve; 
 
PROC archive (TEXT CONST name): 
   reserve (name, archive) 
END PROC archive; 
 
PROC archive (TEXT CONST name, INT CONST station): 
   reserve (name,station/archive) 
END PROC archive; 
 
PROC archive (TEXT CONST name, TASK CONST task): 
   reserve (name, task) 
END PROC archive; 

PROC release (TASK CONST task): 
   call (free code, "", task); 
   IF task = archive 
      THEN angemeldet := FALSE 
   FI 
END PROC release; 
 
PROC release : 
  release (archive);
END PROC release; 

PROC archiv (INT CONST nr): 
   SELECT nr OF 
     CASE altos archive 0, altos archive 1: altos anmelden 
     CASE bicos archive 0                 : archiv
     OTHERWISE unbekannte laufwerksnummer 
   END SELECT. 
 
   altos anmelden: 
     IF station (myself) <> altos station 
        THEN unbekannte laufwerksnummer
     ELSE reserve (archive); 
          SELECT nr OF 
            CASE altos archive 0: call (archive 0 code, "",task(configurator)) 
            CASE altos archive 1: call (archive 1 code, "",task(configurator)) 
          END SELECT; 
          archiv
     FI. 

   unbekannte laufwerksnummer:
     errorstop ("Unbekannte Laufwerksnummer") 
END PROC archiv;

PROC archiv :
  angemeldet := TRUE;
  TEXT CONST name :: archiv name;
  IF err = ""
    THEN display ("Gefundenes Archiv: """ + name + """");
    ELSE errorstop (err)
  FI;
  display (""13""10"").
 
END PROC archiv;
 
BOOL PROC archiv angemeldet: 
   angemeldet 
END PROC archiv angemeldet; 
 
TEXT PROC archiv name: 
  TEXT VAR name :: ""; 
  THESAURUS VAR th;
  IF NOT angemeldet 
   THEN errorstop ("Archiv nicht angemeldet");"" 
   ELSE angemeldet := FALSE;
        err := "";
        disable stop;
        archive ("");
        IF is error 
         THEN err := errormessage; 
              LEAVE archiv name WITH "" 
        FI;
        th := ALL archive; 
        richtigen namen suchen;
        clear error;
        enable stop;
        archive (name); 
        angemeldet := TRUE;
        name
  FI.
 
richtigen namen suchen:
  IF subtext (error message, 1, 13) = "Archiv heisst"
    THEN name := subtext (error message, 16, LENGTH error message - 1)
    ELSE err  := error message
  FI
END PROC archiv name; 
 
TEXT PROC archiv error: 
  err 
END PROC archiv error;
 
PROC from (TEXT CONST name) :
  fetch (name, archive)
END PROC from; 
 
PROC to (TEXT CONST name) : 
  BOOL CONST cd :: command dialogue;
  command dialogue (FALSE);
  save (name, archive);
  command dialogue (cd)
END PROC to;

PROC to : 
  to (last param) 
END PROC to;

PROC from (THESAURUS CONST nameset): 
  fetch (nameset, archive) 
END PROC from; 
 
PROC to (THESAURUS CONST nameset): 
  BOOL CONST cd :: command dialogue;
  command dialogue (FALSE);
  save (nameset, archive);
  command dialogue (cd)
END PROC to; 
 
PROC pla:
  LET dummy name pos = 18;

  FILE VAR listfile;
  INT  VAR i;
  TEXT CONST head :: 70 * "=",
             end  :: 70 * "_";
  TEXT VAR   record;
  WHILE yes ("Archiv eingelegt") REP
    print archive listing
  PER;
  release.

print archive listing:
  archiv;
  listfile := sequential file (output , "PLA");
  list (listfile, archive);
  print head;
  erase dummy names;
  print bottom;
  print and erase listing.

print head :
  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); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, "ARCHIVNAME: "+headline (listfile) + "  " +
                time of day  +"  " + date ); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, " "); down (listfile);
  write record (listfile, "Date      Store  Contents").

erase dummy names :
  to line (listfile, 6);
  WHILE NOT eof (listfile) REP
    read record (listfile, record);
    IF (record SUB dummy name pos) = "-"
      THEN delete record (listfile)
      ELSE down (listfile) 
    FI 
  PER.

print bottom :
   output (listfile);
   putline (listfile, end).

print and erase listing :
  modify (listfile);
  edit (listfile);
  line (3);
  IF yes ("Archivlisting drucken")
    THEN print ("PLA")
  FI;
  forget ("PLA", quiet)
END PROC pla

END PACKET mpg archive system;
 
(************************ MPG SOME TOOLS *********************) 

PACKET mpg some                      (*************************) 
                                     (* Klaus Bovermann       *) 
                                     (* Andreas Dieckmann     *) 
                                     (* Thomas Clermont       *) 
                                     (* Version 3.2           *) 
                                     (* EUMEL   1.8.1         *) 
                                     (* Datum:  21.10.87      *) 
                                     (*************************) 
  
DEFINES some, SOME,                  (* in mehreren Versionen *) 
        one,                         (* in mehreren Versionen *) 
        inchar,                      (*                       *) 
        center,                      (* Hilfsroutinen         *) 
        invers ,                     (*                       *) 
        edit some,                   (* fuer Anfaenger        *) 
        edit one,                    (* fuer Anfaenger        *) 

        reorganize:                  (* auf Thesaurus         *)
 
LET max bild laenge = 80; 
 
TEXT PROC center (TEXT CONST n): 
  center (n," ",max bild laenge - 1) 
END PROC center; 
 
TEXT PROC center (TEXT CONST n,fuell zeichen,INT CONST max text laenge): 
  TEXT VAR fuell text :: 
       ((max text laenge - length (n)) DIV 2) * fuell zeichen; 
  fuelltext CAT (n + fuelltext); 
  IF (LENGTH fuelltext) - max text laenge = 0 
   THEN fuelltext 
   ELSE fuelltext + fuellzeichen 
  FI 
END PROC center; 
 
TEXT PROC invers (TEXT CONST n): 
  mark ein + n + " " + mark aus 
END PROC invers; 
 
PROC inchar (TEXT VAR t, TEXT CONST allowed chars): 
  enable stop;
  REP getchar (t);                 (* Auslesen nur aus virtuellem Puffer *) 
      IF pos (allowed chars,t) = 0 
         THEN out (""7"") 
      FI 
  UNTIL pos (allowed chars,t) <> 0 PER
END PROC inchar; 
 
(*********************************************************************) 
 
LET min zeilen          =   3,
    bildschirm          =  24, 
    min x size          =  30,
    max entries         = 200; 
 
LET trennzeichen                      = ""222"",   (* ESC # *) 
    zeichenstring                     = ""1""27""3""10""13"x"12"o?"11"", 
    oben unten rubout o return x      = ""3""10""12"o"13"x", 
    q eins neun a return x rubout o s = "q19a"13"x"12"os"; 
 
LET mark ein          = ""15"", 
    mark aus          = ""14""; 
  
LET stdtext1 = "Auswahl einer Datei ",
    stdtext2 = "Auswahl mehrerer Dateien ",
    stdhelp  = "( Bei Unklarheiten bitte <?> )";
 
LET hop   = 1, 
    esc   = 2, 
    obe   = 3, 
    unt   = 4, 
    ank   = 5, 
    ank 1 = 6, 
    aus   = 7, 
    aus 1 = 8, 
    fra   = 9, 
    ins   = 10; 
 
LET filetype = 1003; 
 
INT  VAR anzahl,               begin x,begin y,
         kopf zeilen ,         size  x,size y,
         max eintraege,        
         realc, 
         virtc; 
 
TEXT VAR string, 
         weitertext,
         niltext,
         kopfzeilen text, 
         kz1,  
         kz2;  
 
BOOL VAR raender, 
         auswahlende, 
         abbruch; 
 
ROW max entries TEXT VAR eintrag; 
 
THESAURUS VAR gesamt liste; 
FILE VAR tools info; 
DATASPACE VAR tools info ds; 
 
INITFLAG VAR init tools info; 
 
(******************* Grundlegende Prozedur *************************) 
 
THESAURUS PROC einzelne (THESAURUS CONST t, BOOL CONST viele, 
                         TEXT CONST k1,
                         INT CONST x begin,y begin, 
                                   x size ,y size): 
   begin x    := x begin; 
   begin y    := y begin; 
   size x     := x size;
   size y     := y size;
   kz1        := k1; 
   string     := ""; 
   raender    := FALSE;
   gen kopf zeilen; 
   IF groesster editor > 0 
      THEN INT VAR x,y; 
           get edit cursor (x,y) ; 
           IF bildschirm - kopfzeilen - min zeilen + 1 < y 
              THEN begin y       := 1; 
                   size y        := 24;
                   begin x       := 1;
                   size x        := 79
              ELSE begin y       := y; 
                   size y        := bildschirm - y + 1;
                   max eintraege := size y - min zeilen - kopfzeilen;
                   IF (80 - x) < min x size OR col = 1
                     THEN begin x        := 1; 
                          size x         := 79
                     ELSE raender        := TRUE; 
                          begin x        := x;
                          size x         := 80 - x - 2
                   FI
           FI;
           gen kopfzeilen
   FI; 
   IF (size y - kopf zeilen) < min zeilen OR 
                     begin y < 0          OR 
      (begin y + size y - 1) > bildschirm OR
      (begin x + size x - 1) > 79
      THEN errorstop ("Fenster zu klein") 
   FI; 
   init weitertext;
   init niltext;
   THESAURUS VAR ausgabe :: empty thesaurus; 
   gesamt liste := t; 
   INT VAR i; 
   anzahl := 0; 
   FOR i FROM 1 UPTO highest entry (t) REP 
     IF name (t,i) <> "" 
        THEN anzahl INCR 1; 
             eintrag [anzahl] := name (t,i) 
     FI 
   PER; 
   IF anzahl = 0 THEN LEAVE einzelne WITH ausgabe FI; 
   bild aufbauen; 
   abbruch := FALSE; 
   kreuze an (viele); 
   IF abbruch 
      THEN LEAVE einzelne WITH ausgabe 
   FI; 
   cursor (begin x,begin y + size y - 1); 
   out (niltext); (* Folgende Ausgaben werden sonst unleserlich *) 
   ausgabe erzeugen; 
   ausgabe. 
  
ausgabe erzeugen: 
  TEXT VAR nam; 
  WHILE string <> "" REP 
        nam := subtext (string,1,3); 
        string := subtext (string,5); 
        insert (ausgabe, eintrag [int (nam)]) 
  PER 
END PROC einzelne; 
 
PROC realcursor setzen: 
  cursor (begin x,kopf zeilen + realc + begin y); 
  IF raender
   THEN out ("|")
  FI;
  out (marke (virtc, TRUE) + 6 * ""8"") 
END PROC real cursor setzen; 
 
TEXT PROC marke (INT CONST zeiger, BOOL CONST mit cursor): 
  INT VAR pl :: nr (zeiger); 
  IF pl = 0 
     THEN leer 
     ELSE mit zahl 
  FI. 
 
mit zahl: 
  IF mit cursor 
     THEN (3-length(text(pl))) * "-" + text (pl) + "-> " 
     ELSE text (pl,3) + " > " 
  FI. 
 
leer: 
  IF mit cursor 
     THEN "----> " 
     ELSE 6 * " " 
  FI 
END PROC marke; 
 
PROC init weitertext: 
  weitertext := "----> " + mark ein + "weitere  Eintraege " + mark aus  
                         + ((size x - 27) * "-") 
END PROC init weitertext; 
 
PROC init niltext: 
  IF size x > 78 
    THEN niltext := ""5"" 
    ELSE IF raender 
           THEN niltext := ((size x + 2) * " " + (size x + 2) * ""8"")
           ELSE niltext := (size x * " " + size x * ""8"")
         FI
  FI
END PROC init niltext; 
 
PROC bild (INT CONST anfang): 
  INT VAR i; 
  gib oberlinie aus; 
  FOR i FROM anfang UPTO grenze REP 
     cursor (begin x,kopfzeilen + begin y + i - anfang + 1);
     rand;
     out (marke (i, FALSE)); 
     IF LENGTH ("""" + eintrag [i] + """") <= (size x - 6) 
       THEN out (text ("""" + eintrag [i] + """",size x - 6)) 
       ELSE out (text ("""" + eintrag [i],size x - 10) + " ...")
     FI;
     rand
  PER; 
  gib unterlinie aus; 
  IF grenze < (anfang + max eintraege)
     THEN FOR i FROM 0 UPTO (anfang + max eintraege - anzahl - 1) REP
           cursor (begin x,begin y + kopfzeilen + i +
                           grenze - anfang + min zeilen);
           out (niltext) 
          PER
  FI. 
  
gib oberlinie aus: 
  cursor (begin x,kopfzeilen + begin y); 
  rand;
  IF realc = virtc 
     THEN out (size x * "-") 
     ELSE out (weitertext) 
  FI;
  rand.
  
gib unterlinie aus: 
  cursor (begin x,begin y + grenze - anfang + kopfzeilen + min zeilen - 1);
  rand;
  IF anzahl <= (anfang + max eintraege)
     THEN out (size x * "-") 
     ELSE out (weitertext) 
  FI;
  rand.
 
grenze: 
  min (anzahl,anfang + max eintraege).
 
END PROC bild; 
 
PROC gen kopfzeilen: 
  kopfzeilen := 0; 
  kopfzeilen text := ""; 
  kopfzeilen text CAT code (0);
  IF   pos (kz1,trenn zeichen) > 0 
       THEN analysiere kopfzeile 
  ELIF kz1 <> "" AND length (kz1) <= size x
       THEN kopfzeilen text := kz1 + code (1);
            kopf zeilen := 1 
  ELIF kz1 <> "" 
       THEN analysiere kopfzeile 
  FI; 
  IF kopfzeilen > size y - min zeilen 
     THEN kopfzeilen := size y - min zeilen 
  FI; 
  max eintraege := size y - kopfzeilen - min zeilen.
 
analysiere kopfzeile: 
   kz2 := compress (kz1); 
   BOOL VAR mark is on :: FALSE;
   TEXT VAR einschub;
   REP kopf zeilen INCR 1; 
       kontrolliere pos; 
       einschub := subtext(kz2,1,pos (kz2,trennzeichen)-1);
       kontrolliere auf markiert;
       kopfzeilen text CAT einschub;
       kopfzeilen text CAT code (kopf zeilen);
       kz2 := compress (subtext(kz2,pos (kz2,trennzeichen) + 1));
   UNTIL NOT (length (kz2) > size x OR pos (kz2,trennzeichen) > 0 )PER; 
   IF kz2 <> "" 
      THEN einschub := kz2; 
           kontrolliere auf markiert; 
           kopfzeilen text CAT einschub;
           kopf zeilen INCR 1 
   FI; 
   kopfzeilentext CAT code (kopfzeilen).
 
muss noch getrennt werden: 
 (pos (kz2,trennzeichen) > size x OR  pos (kz2,trennzeichen) = 0)
                                  AND length (kz2) > size x. 

kontrolliere pos: 
  IF muss noch getrennt werden
     THEN trenne kopfzeile
  FI. 
 
trenne kopfzeile: 
  INT VAR i; 
  FOR i FROM size x DOWNTO (size x DIV 2) REP
  UNTIL (kz2 SUB i) = " " PER; 
  kz2 := subtext (kz2,1,i) + trennzeichen + subtext (kz2,i+1).
 
kontrolliere auf markiert: 
  IF mark is on 
    THEN kopfzeilen text CAT mark ein;
         IF pos (einschub,mark aus) > 0 AND pos (einschub,mark ein) = 0
           THEN mark is on := FALSE 
         FI 
    ELSE IF pos (einschub,mark ein) > 0 
           THEN IF pos (einschub,mark aus) = 0 
                  THEN einschub CAT mark aus; 
                       mark is on := TRUE 
                FI
         FI 
  FI. 
 
END PROC gen kopfzeilen; 
 
PROC zeige kopfzeilen:
 INT VAR i; 
 FOR i FROM 1 UPTO kopfzeilen REP 
  cursor (begin x,begin y + i - 1); 
  rand;
  out (niltext);
  out (center (subtext (kopfzeilen text,pre code + 1,post code - 1) 
               ," ",size x));
  rand
 PER. 
 
 post code: 
  pos (kopfzeilen text,code (i)). 
 
 pre code: 
  pos (kopfzeilen text,code (i - 1)). 
 
END PROC zeige kopfzeilen; 
 
PROC  bild aufbauen: 
  zeige kopfzeilen;
  virtc := 1; 
  realc := 1; 
  bild (1);
  realcursor setzen 
END PROC bild aufbauen; 
 
PROC kreuze an (BOOL CONST viele): 
  auswahlende := FALSE; 
  REP zeichen lesen; 
      zeichen interpretieren 
  UNTIL auswahlende 
  PER. 
 
zeichen lesen: 
  TEXT VAR zeichen; 
  inchar (zeichen, zeichenstring). 
 
zeichen interpretieren: 
  SELECT pos (zeichenstring, zeichen) OF 
    CASE hop   : hoppen (viele) 
    CASE esc   : esc kommandos (viele) 
    CASE obe   : nach oben 
    CASE unt   : nach unten 
    CASE ank   : ankreuzen (viele,FALSE); evtl aufhoeren 
    CASE ank 1 : ankreuzen (viele,TRUE ); evtl aufhoeren 
    CASE aus   : auskreuzen 
    CASE aus 1 : auskreuzen       
    CASE fra   : info (viele) 
    CASE ins   : eintrag einfuegen; 
                 IF string <> ""
                    THEN evtl aufhoeren 
                 FI
  END SELECT. 
 
evtl aufhoeren: 
  IF NOT viele 
     THEN LEAVE kreuze an 
  FI 
END PROC kreuze an; 
 
PROC hoppen (BOOL CONST viele): 
  zweites zeichen lesen; 
  zeichen interpretieren. 
 
zweites zeichen lesen: 
  TEXT VAR zz; 
  getchar (zz). 
 
zeichen interpretieren: 
  SELECT pos (oben unten rubout o return x , zz) OF 
    CASE 0   : out (""7"") 
    CASE 1   : hop nach oben 
    CASE 2   : hop nach unten 
    CASE 3,4 : alles loeschen  
    CASE 5   : bild nach oben 
    CASE 6   : IF viele THEN rest ankreuzen ELSE out (""7"") FI 
  END SELECT.  
  
bild nach oben: 
  realc := 1; 
  bild (virtc); 
  realcursor setzen. 
 
rest ankreuzen: 
  INT VAR i; 
  FOR i FROM 1 UPTO anzahl REP 
    IF nr (i) = 0 
       THEN string CAT textstr (i) 
    FI 
  PER; 
  bild aktualisieren;  
  realcursor setzen.  
 
alles loeschen: 
  string := ""; 
  bild aktualisieren; 
  realcursor setzen. 
 
hop nach oben: 
  IF   ganz oben 
       THEN out (""7"") 
  ELIF oben auf der seite 
       THEN raufblaettern 
       ELSE top of page 
  FI. 
 
ganz oben: 
  virtc = 1. 
 
oben auf der seite: 
  realc = 1. 
 
raufblaettern: 
  virtc DECR (max eintraege + 1); 
  virtc := max (virtc, 1); 
  bild (virtc); 
  realcursor setzen. 
 
top of page: 
  loesche marke; 
  virtc DECR (realc - 1); 
  realc := 1; 
  realcursor setzen. 
 
hop nach unten: 
  IF   ganz unten 
       THEN out (""7"") 
  ELIF unten auf der seite 
       THEN runterblaettern 
       ELSE bottom of page 
  FI. 
 
ganz unten: 
  virtc = anzahl. 
 
unten auf der seite: 
  realc > maxeintraege . 
 
runterblaettern: 
  INT VAR alter virtc :: virtc; 
  virtc INCR (max eintraege + 1); 
  virtc := min (virtc, anzahl); 
  realc := virtc - alter virtc; 
  bild (alter virtc + 1); 
  realcursor setzen. 
 
bottom of page: 
  loesche marke; 
  alter virtc := virtc; 
  virtc INCR (max eintraege + 1 - realc); 
  virtc := min (anzahl, virtc); 
  realc INCR (virtc - alter virtc); 
  realcursor setzen 
END PROC hoppen; 
 
PROC esc kommandos (BOOL CONST viele): 
  TEXT VAR zz; 
  getchar (zz);  
  SELECT pos(q eins neun a return x rubout o s, zz) OF 
    CASE 0   : out (""7"") 
    CASE 1   : auswahlende := TRUE 
    CASE 2   : zeige anfang 
    CASE 3   : zeige ende 
    CASE 4   : abbruch := TRUE; auswahlende := TRUE 
    CASE 5,6 : IF viele 
                  THEN ankreuzen bis ende 
                  ELSE out (""7"") 
               FI 
    CASE 7,8 : IF viele 
                  THEN loeschen bis ende 
                  ELSE out (""7"") 
               FI 
    CASE 9   : liste nach nummern ordnen 
  END SELECT. 
  
liste nach nummern ordnen : 
   THESAURUS VAR dummy thesaurus :: empty thesaurus; 
   TEXT VAR nam,dummy string :: ""; 
   cursor (begin x,begin y + screen ende + kopfzeilen + minzeilen - 1);
   rand;
   out (center(invers("Bitte warten !"),"-",size x)); 
   rand;
   i := 0; 
   WHILE string <> "" REP 
       i INCR 1; 
       nam := subtext (string,1,3); 
       string := subtext (string,5); 
       insert (dummy thesaurus, eintrag [int (nam)]); 
       dummy string CAT textstr (i) 
   PER; 
   anzahl := 0; 
   string := dummy string; 
   gesamt liste := dummy thesaurus + gesamt liste; 
   FOR i FROM 1 UPTO highest entry (gesamt liste) REP 
      IF name (gesamt liste,i) <> "" 
         THEN anzahl INCR 1; 
              eintrag [anzahl] := name (gesamt liste,i) 
      FI 
   PER; 
   bild aufbauen. 
 
loeschen bis ende: 
  INT VAR j; 
  FOR j FROM virtc UPTO anzahl REP 
    INT VAR posi :: nr (j); 
    IF posi <> 0 
       THEN rausschmeissen 
    FI 
  PER; 
  bild aktualisieren; 
  realcursor setzen. 
 
rausschmeissen: 
  string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1). 
 
ankreuzen bis ende: 
  INT VAR i; 
  FOR i FROM virtc UPTO anzahl REP 
    IF nr (i) = 0 
       THEN string CAT textstr (i) 
    FI 
  PER; 
  bild aktualisieren;  
  realcursor setzen.  
 
zeige anfang:  
  IF virtc = 1 
     THEN out (""7"") 
     ELIF virtc = realc 
     THEN loesche marke; 
          virtc := 1; 
          realc := 1; 
          realcursor setzen 
     ELSE virtc := 1; 
          realc := 1; 
          bild (1); 
          realcursor setzen 
  FI. 
 
zeige ende: 
  IF   virtc = anzahl 
       THEN out (""7"") 
  ELIF ende auf screen 
       THEN loesche marke;  
            realc INCR (anzahl - virtc);  
            virtc := anzahl; 
            realcursor setzen 
       ELSE virtc := anzahl;        
          realc := max eintraege + 1;                                
          bild (anzahl - maxeintraege); 
          realcursor setzen 
  FI. 
  
ende auf screen: 
  (realc + anzahl - virtc) < maxeintraege + 1. 
 
screen ende:
  min (realc + anzahl - virtc - 1,max eintraege).

END PROC esc kommandos; 
 
PROC ankreuzen (BOOL CONST viele,xo): 
  INT VAR pl :: nr (virtc); 
  IF pl <> 0 
     THEN out (""7""); 
          cursor setzen; 
          LEAVE ankreuzen 
  FI; 
  string CAT textstr (virtc); 
  IF viele 
     THEN cursor setzen 
  FI. 
 
 cursor setzen: 
  IF xo 
   THEN realcursor setzen 
   ELSE IF virtc < anzahl 
         THEN nach unten 
        FI; 
        IF virtc = anzahl 
         THEN realcursor setzen 
        FI 
  FI 
END PROC ankreuzen; 
 
PROC auskreuzen : 
  INT VAR posi :: nr (virtc); 
  IF posi = 0 
     THEN out (""7""); LEAVE auskreuzen 
  FI; 
  rausschmeissen; 
  loesche marke; 
  bild aktualisieren; 
  realcursor setzen. 
 
rausschmeissen: 
  string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1)  
END PROC auskreuzen; 
 
PROC eintrag einfuegen : 
  IF anzahl = max entries 
     THEN out (""7""); 
          LEAVE eintrag einfuegen 
  FI; 
  mache platz frei; 
  trage ein; 
  baue richtiges bild auf. 
 
mache platz frei: 
  INT VAR i; 
  FOR i FROM anzahl DOWNTO virtc REP 
     eintrag [i+1] := eintrag [i] 
  PER; 
  eintrag [virtc] := """"; 
  ruecke kreuze einen weiter; 
  anzahl INCR 1; 
  string CAT textstr (virtc); 
  baue richtiges bild auf. 
 
trage ein: 
  TEXT VAR exit char;
  realcursor setzen;
  out (marke (virtc,TRUE));
  out ("""");
  push (""11""); 
  editget (ein,max text length,size x - 7,"","",exit char);
  IF (ein SUB length (ein)) = """"
     THEN ein := subtext (ein,1,length (ein) - 1) 
  FI; 
  IF ein = "" 
     THEN auskreuzen; 
          setze eintraege zurueck 
     ELSE realcursor setzen;
          out (6 * ""2"" + text ("""" + ein + """",size x - 7))
  FI.            
 
ein: 
  eintrag [virtc]. 
 
setze eintraege zurueck: 
  FOR i FROM virtc UPTO anzahl-1 REP 
      eintrag [i] := eintrag [i+1]; 
      change (string,textstr (i+1),textstr (i)) 
  PER; 
  anzahl DECR 1. 
 
ruecke kreuze einen weiter: 
  FOR i FROM anzahl DOWNTO virtc REP 
      change (string,textstr (i),textstr (i+1)) 
  PER. 
 
baue richtiges bild auf: 
   bild (virtc - (realc - 1)); 
   realcursor setzen 
END PROC eintrag einfuegen; 
 
PROC bild aktualisieren: 
  INT VAR ob, un, i; 
  ob := virtc - (realc - 1); 
  un := min (ob + max eintraege, anzahl); 
  FOR i FROM ob UPTO un REP 
     cursor (begin x,kopfzeilen + begin y + i - ob + 1);
     rand;
     out (marke (i, FALSE))
  PER 
END PROC bild aktualisieren; 
 
PROC nach oben: 
  IF noch nicht oben   (* virtuell *) 
     THEN gehe nach oben 
     ELSE out (""7"") 
  FI. 
 
noch nicht oben: 
  virtc > 1. 
 
gehe nach oben: 
  IF realc = 1 
     THEN scroll down 
     ELSE cursor up 
  FI. 
 
scroll down: 
  virtc DECR 1; 
  bild (virtc); 
  realcursor setzen. 
 
cursor up: 
  loesche marke; 
  virtc DECR 1; 
  realc DECR 1; 
  realcursor setzen 
END PROC nach oben; 
 
PROC nach unten: 
  IF noch nicht unten  (* virtuell *)  
     THEN gehe nach unten 
     ELSE out (""7"") 
  FI. 
 
noch nicht unten: 
  virtc < anzahl. 
 
gehe nach unten: 
  IF realc > maxeintraege 
     THEN scroll up 
     ELSE cursor down 
  FI. 
 
scroll up: 
  virtc INCR 1; 
  bild (virtc - maxeintraege); 
  realcursor setzen. 
 
cursor down: 
  loesche marke; 
  virtc INCR 1; 
  realc INCR 1; 
  realcursor setzen 
END PROC nach unten; 
 
PROC loesche marke: 
  cursor (begin x,kopf zeilen + realc + begin y); 
  rand;
  out (marke (virtc, FALSE)) 
END PROC loesche marke; 
 
TEXT PROC textstr (INT CONST nr): 
  text (nr,3) + "!" 
END PROC textstr; 
 
INT PROC nr (INT CONST zeiger): 
  IF pos (string, textstr (zeiger)) = 0 
     THEN 0 
     ELSE (pos (string,textstr (zeiger)) DIV 4) + 1 
  FI  
END PROC nr; 
 
PROC rand: 
 IF raender 
   THEN out ("|") 
 FI 
END PROC rand; 
 
PROC info (BOOL CONST mehrere moeglich): 
   IF NOT initialized (init tools info) 
      THEN initialisiere tools info 
   FI; 
   modify (tools info); 
   IF mehrere moeglich 
      THEN head line (tools info," INFO : Auswahl mehrerer Dateien "); 
      ELSE head line (tools info," INFO : Auswahl einer Datei "); 
   FI; 
   to line (tools info,1); 
   col (tools info,1);
   IF raender 
     THEN open editor (groesster editor + 1,tools info,FALSE, 
                                     begin x,begin y,size x + 2,size y) 
     ELSE open editor (groesster editor + 1,tools info,FALSE, 
                                     begin x,begin y,size x,size y)
   FI;
   edit (groesster editor,"q19",PROC (TEXT CONST) std kommando interpreter); 
   zeige kopfzeilen;
   bild (virtc - (realc - 1));
   realcursor setzen
END PROC info;  
 
(******************** Herausgereichte, abgeleitete Prozeduren ***********) 
 
THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile, 
                     INT CONST start x,start y,x size,y size): 
  einzelne (t,TRUE,kopf zeile,start x,start y,x size,y size) 
END PROC some; 

THESAURUS PROC some (THESAURUS CONST t,
                     INT CONST start x,start y,x size,y size): 
  some  (t,invers (std text 2 + std help),start x,start y,x size,y size) 
END PROC some; 
 
THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile, 
                     INT CONST start y,ende y): 
   einzelne (t,TRUE,kopf zeile,1,start y,79,ende y - start y + 1)
END PROC some; 
 
THESAURUS PROC some (THESAURUS CONST t,INT CONST start y,ende y): 
   some (t,invers(stdtext 2 + std help),1,start y,79,ende y - start y + 1)
END PROC some; 

THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile): 
   some (t,kopf zeile,1,bildschirm) 
END PROC some; 
 
THESAURUS PROC some (THESAURUS CONST t): 
  some (t,invers(stdtext 2 + std help),1,bildschirm) 
END PROC some; 
  
THESAURUS PROC some: 
  some (all,invers(stdtext 2 + std help),1,bildschirm) 
END PROC some; 
 
THESAURUS PROC some (TEXT CONST te): 
  some (ALL te) 
END PROC some; 
 
THESAURUS PROC some (TASK CONST quelle): 
  some (ALL quelle) 
END PROC some; 
 
THESAURUS OP SOME (THESAURUS CONST th): 
  some (th) 
END OP SOME; 
 
THESAURUS OP SOME (TASK CONST ta): 
  some (ALL ta) 
END OP SOME; 
 
THESAURUS OP SOME (TEXT CONST te): 
  some (ALL te) 
END OP SOME; 
 
TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile, 
                     INT CONST start x,start y,x size,y size): 
  name(einzelne (t,FALSE,kopf zeile,start x,start y,x size,y size),1) 
END PROC one; 

TEXT PROC one (THESAURUS CONST t,
               INT CONST start x,start y,x size,y size): 
  one (t,invers (std text 1 + std help),start x,start y,x size,y size) 
END PROC one; 

TEXT PROC one (THESAURUS CONST t, TEXT CONST t1, 
               INT CONST start y,ende y): 
  name (einzelne (t,FALSE, t1,1,start y,79,ende y - start y + 1), 1) 
END PROC one; 
 
TEXT PROC one (THESAURUS CONST t, 
               INT CONST start y,ende y): 
  one (t,invers (std text 1+ std help),1,start y,79,ende y - start y + 1) 
END PROC one; 

TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile): 
   one (t,kopf zeile,1,bildschirm) 
END PROC one;

TEXT PROC one (THESAURUS CONST t): 
  one (t,invers(stdtext 1 + std help),1,bildschirm) 
END PROC one; 
  
TEXT PROC one (TASK CONST quelle): 
  one (ALL quelle) 
END PROC one; 
 
TEXT PROC one: 
  one (all) 
END PROC one; 
 
TEXT PROC one (TEXT CONST te): 
  one (ALL te) 
END PROC one; 
   
PROC edit one :
  TEXT CONST datei :: one (all,invers(stdtext 1 + "zum Editieren") 
                               + trennzeichen + stdhelp,
                               1,bildschirm); 
  IF datei <> "" CAND (NOT exists (datei) 
                       COR type (old (datei)) = filetype) 
     THEN IF groesster editor > 0 
              THEN ueberschrift neu; 
                   bild neu
          FI;
          edit (datei) 
  FI  
END PROC edit one; 
 
PROC edit some:
  THESAURUS CONST tt :: some (all,invers(stdtext 2 + "zum Editieren") 
                                  + trennzeichen + stdhelp, 
                                  1,bildschirm); INT VAR i; 
  FOR i FROM 1 UPTO highest entry (tt) REP 
    TEXT VAR datei :: name (tt,i); 
    IF datei <> "" CAND (NOT exists (datei) 
                         COR type (old (datei)) = filetype) 
       THEN IF groesster editor > 0 
              THEN ueberschrift neu; 
                   bild neu                   
            FI; 
            edit (datei) 
    FI 
 PER 
END PROC edit some; 

PROC reorganize (THESAURUS CONST t): 
  page; 
  do (PROC (TEXT CONST) do reorganize,t) 
END PROC reorganize; 
 
PROC do reorganize (TEXT CONST name): 
 IF type (old(name)) = file type 
  THEN put ("Datei " + center (invers("""" + name + """")," ",30) 
                     + " wird reorganisiert :"); 
       FILE VAR file :: sequential file (modify,name);
       IF segments (file) = 1
         THEN put (lines (file))
         ELSE reorganize (name) 
       FI
  ELSE put ("      " + center (invers("""" + name + """")," ",30) 
                     + " ist keine Datei.") 
 FI; 
 line 
END PROC do reorganize ; 
 
PROC initialisiere tools info : 
   tools info ds := nilspace; 
   tools info := sequential file (output, tools info ds); 
   putline (tools info,""15"   Mit den angekreuzten Namen wird die gewaehlte Operation ausgefuehrt     "14"");
      line (tools info); 
   putline (tools info,"        "15"   Positionierungen: "14" "); 
      line (tools info); 
   putline (tools info,"              Oben         : zum vorausgehenden Namen");
   putline (tools info,"              Unten        : zum folgenden Namen    ");
   putline (tools info,"              HOP Oben     : zum ersten  Namen der (vorigen) Seite");
   putline (tools info,"              HOP Unten    : zum letzten Namen der (vorigen) Seite");
   putline (tools info,"              HOP RETURN   : aktuelle Zeile wird erste Zeile");
   putline (tools info,"              ESC 1        : zum ersten  Namen der Liste");
   putline (tools info,"              ESC 9        : zum letzten Namen der Liste");
   putline (tools info,"              ESC s        : Liste nach Nummern ordnen");
      line (tools info); 
   putline (tools info,"        "15"   Auswahl treffen: "14" "); 
      line (tools info); 
   putline (tools info,"              ( Folgende Befehle sind nur bei einer )");
   putline (tools info,"              ( Auswahl von mehreren Namen Möglich. )");
      line (tools info); 
   putline (tools info,"              RETURN bzw. x: diesen Namen ankreuzen     ");
   putline (tools info,"              RUBOUT bzw. o: Kreuz vor dem Namen loeschen");
   putline (tools info,"              HOP x        : alle Namen ankreuzen      ");
   putline (tools info,"              HOP o        : alle Kreuze loeschen     ");
   putline (tools info,"              ESC x        : alle folgenden Namen ankreuzen");
   putline (tools info,"              ESC o        : alle folgenden Kreuze loeschen");
   putline (tools info,"              RUBIN        : einen neuen Namen eintragen");
      line (tools info); 
   putline (tools info,"              ( Nur dieser Befehl kann benutzt werden , wenn )");
   putline (tools info,"              ( die Auswahl eines ! Namens möglich ist.      )");
      line (tools info); 
   putline (tools info,"              RETURN bzw. x: diesen Namen auswaehlen");
      line (tools info); 
   putline (tools info,"         "15"  Auswahl verlassen: "14""); 
      line (tools info); 
   putline (tools info,"                ESC q        : Auswaehlen beenden     ");
   putline (tools info,"                ESC a        : Auswahl abbrechen (ohne Kreuze !)");
      line (tools info); 
   putline (tools info,""15"             Zum Verlassen des Infos bitte 'ESC q' tippen!                 "14"");
END PROC initialisiere tools info; 
 
END PACKET mpg some;

(****************** DATEI MONITOR ********************************) 

PACKET mpg dm DEFINES dm:                (* Klaus Bovermann   *)  
                                         (* Andreas Dieckmann *) 
                                         (* Thomas Clermont   *) 
                                         (* Version 2.1       *) 
                                         (* EUMEL   1.7.5     *) 
                                         (* Datum   06.05.87  *) 
LET mark ein            = ""15"",
    mark aus            = ""14"",
    trennzeichen        = ""222"",
    type                = "#type (""micron"")#",
    dummy name pos      = 18,
    disk zeichenfolge   = "alnfiqushcvd", 
    mana zeichenfolge   = "al   qush v"; 
 
TASK CONST std manager :: task ("PUBLIC"); 
TASK VAR manager; 
 
BOOL VAR archive ist meins :: archiv angemeldet,
         disk ,
         diskette im schacht :: FALSE; 

TEXT VAR aktueller archivename,
         manager name, 
         t1;

PROC dm: 
  TEXT VAR zeichen, alte lernsequenz :: lernsequenz auf taste ("k");
  REP  aktion 
  UNTIL zeichen = "q" PER; 
  lernsequenz auf taste legen ("k",alte lernsequenz).
  
aktion: 
  manager := std manager; 
  vormonitor; 
  IF zeichen <> "q" AND managername <> "" 
     THEN hauptmonitor 
  FI. 
  
zeige vormonitor: 
      managername := name (manager); 
      page; 
      write(27 * " "); write(mark ein); 
      write("V O R M O N I T O R "); write(mark aus); 
      line(4); 
      zeile ("t","Task einstellen, mit der  kommuniziert werden soll"); 
      zeile ("p","Es soll mit 'PUBLIC'      kommuniziert werden"); 
      zeile ("v","Es soll mit der Vatertask kommuniziert werden"); 
      zeile ("a","Es soll mit dem Archiv    kommuniziert werden"); 
      zeile ("q","Programm beenden").

vormonitor:
  IF NOT eingabe von erlaubtem zeichen ("tvapq")
    THEN zeige vormonitor
  FI; 
  line; 
  write ("Bitte Eingabe : "); 
  inchar (zeichen, "tvapq"); 
  out (zeichen); line;
  IF pos ("a",zeichen) = 0 CAND manager = archive 
    THEN automatische freigabe des archives 
  FI; 
  ausfuehren der vorwahl. 
  
ausfuehren der vorwahl: 
  IF pos ("tvap", zeichen) <> 0 
     THEN neue task einstellen  
  FI. 
  
neue task einstellen: 
  managername := ""; 
  IF   zeichen = "a" THEN managername := "ARCHIVE" 
  ELIF zeichen = "p" THEN managername := "PUBLIC" 
  ELIF zeichen = "v" THEN managername := name (father) 
                     ELSE namen holen 
  FI; 
  TEXT VAR mess; 
  BOOL VAR ok :: managername = ""        COR 
                 managername = "PUBLIC"  COR 
                 task ist kommunikativ (managername, mess); 
  IF NOT ok  
     THEN cursor (1,20); putline (""7""15"FEHLER: " + mess + ""14""); 
          pause; 
          managername := ""; 
  FI; 
  IF   managername = ""        THEN manager := std manager 
  ELIF managername = "ARCHIVE" THEN manager := archive 
                               ELSE manager := task (managername) 
  FI. 
  
namen holen: 
  REP
   cursor (1,14); 
   put ("Neue Task:"); 
   editget (managername); line; 
   IF managername = name (myself)
    THEN putline ("Mit der eigenen Task kann nicht kommuniziert werden.")
   FI;
  UNTIL managername <> name (myself) PER;
   lernsequenz auf taste legen ("k",managername).

END PROC dm;  
                        
BOOL PROC task ist kommunikativ (TEXT CONST taskname, TEXT VAR message): 
  disable stop; 
  TASK VAR t :: task (taskname); 
  IF is error 
     THEN message := errormessage; 
          clear error; 
          enable stop; 
          FALSE 
     ELSE task behandlung 
  FI. 
  
  task behandlung: 
    IF taskname <> "ARCHIVE" 
       THEN task kommunikation 
       ELSE archive behandlung 
    FI. 
  
  task kommunikation: 
    IF status (t) <> 2 
       THEN message := "Task ist nicht im Wartezustand"; 
            enable stop; 
            FALSE 
       ELSE versuchen zuzugreifen 
    FI. 
  
  versuchen zuzugreifen: 
    INT CONST listcode :: 15; 
    DATASPACE VAR dummy :: nilspace; 
    call (listcode, "", dummy, t); 
    forget (dummy); 
    IF is error  
       THEN message := errormessage; 
            clear error; 
            enable stop; 
            FALSE 
       ELSE message := ""; 
            enable stop; 
            TRUE 
    FI. 
  
  archive behandlung: 
    IF status (archive) <> 2 
       THEN message := "ARCHIVE ist nicht im Wartezustand"; 
            LEAVE archive behandlung WITH FALSE
    FI; 
    archive (""); 
    IF is error 
       THEN message := errormessage; 
            clear error; 
            enable stop; 
            FALSE  
       ELSE enable stop; 
            archive ist meins := TRUE; 
            diskette im schacht := FALSE;
            message := ""; 
            TRUE 
    FI 
END PROC task ist kommunikativ; 
 
PROC hauptmonitor:  
  disk := (manager = archive); 
  TEXT VAR zeichenfolge; 
  IF disk 
     THEN zeichenfolge := disk zeichenfolge 
     ELSE zeichenfolge := mana zeichenfolge 
  FI; 
  TEXT VAR   taste; 
  INT VAR    stelle; 
  diskette im schacht   := FALSE; 
  IF disk 
     THEN reservieren des archives 
  FI; 
  disable stop;
  REP 
    IF NOT eingabe von erlaubtem zeichen (zeichenfolge)
      THEN zeige menue 
    FI; 
    line;  
    write ("Bitte Eingabe : "); 
    inchar (taste,zeichenfolge);
    out (taste + "   Bitte warten..."); 
    stelle := pos (disk zeichenfolge, taste); (*!! ACHTUNG !!*) 
    IF         stelle > 6
       AND NOT diskette im schacht 
       AND     disk
     THEN line; 
          putline (" Erst Diskette einlegen !");pause (100) 
     ELIF taste <> " " 
     THEN menue auswerten (stelle)
    FI; 
    IF is error 
      THEN IF disk 
             THEN melde archiveerror (errormessage) 
             ELSE melde error (errormessage)
           FI;
           clear error 
    FI 
   UNTIL taste = "q" PER; 
   IF archiv angemeldet
      THEN automatische freigabe des archives 
   FI.  
 
  zeige menue: 
    page; 
    write(24 * " "); write(mark ein); 
    write("D A T E I M O N I T O R "); write(mark aus); 
    line(3); 
    zeile ("a","Auflisten aller Dateien in dieser Task"); 
    zeile ("l","Loeschen    von Dateien in dieser Task"); 
    line(2); 
    write( 15 * " "); 
    IF disk 
       THEN write("Archiv: ")  
       ELSE write("Task  : ") 
    FI;  
    IF disk 
       THEN IF diskette im schacht 
             THEN IF length(aktueller archivename) > 40  
                   THEN write ("'" + subtext (aktueller archivename,1,40) + " ...")
                   ELSE write (invers(""""+ aktueller archivename + """"))
                  FI  
             FI
       ELSE write (invers("""" + managername + """")) 
    FI; 
    line(2);  
    TEXT VAR zielname 1, zielname 2, zielname 3; 
    IF disk 
       THEN zielname 1 := "des Archivs"; 
            zielname 2 := "zum Archiv"; 
            zielname 3 := "vom Archiv" 
       ELSE zielname 1 := "in  " + managername; 
            zielname 2 := "zu  " + managername; 
            zielname 3 := "von " + managername 
    FI; 
    zeile ("u","Uebersicht ueber alle Dateien " + zielname 1); 
    zeile ("s","Senden von Dateien            " + zielname 2); 
    zeile ("h","Holen von Dateien             " + zielname 3); 
    IF disk 
       THEN zeile ("c","'Checken' von Dateien         " + zielname 1) 
    FI; 
    zeile ("v","Vernichten von Dateien        " + zielname 1); 
    IF disk THEN 
       zeile ("d","Drucken einer Liste der Dateien des Archivs"); 
       zeile ("f","Formatieren einer Diskette"); 
       zeile ("i","Initialisieren/vollstaendiges Loeschen des Archivs"); 
       zeile ("n","Neue Diskette anmelden"); 
    FI;  
    line(1); 
    zeile ("q","Zurueck zum Vormonitor").

END PROC hauptmonitor;  
 
PROC menue auswerten (INT CONST stelle):
    enable stop;
    SELECT stelle OF  
       CASE  1 : auflisten der taskdateien 
       CASE  2 : loeschen von dateien in der task 
       CASE  3 : neue diskette anmelden 
       CASE  4 : formatieren einer diskette 
       CASE  5 : initialisieren des archives 
       CASE  6 : (* nichts *) 
       CASE  7 : auflisten der archivedateinamen 
       CASE  8 : schreiben von dateien aufs archive 
       CASE  9 : holen von dateien vom archive 
       CASE 10 : checken von dateien auf dem archive 
       CASE 11 : loeschen von dateien auf dem archive 
       CASE 12 : ausdruck archivelisting 
    END SELECT 
END PROC menue auswerten;

BOOL PROC eingabe von erlaubtem zeichen (TEXT CONST erlaubte zeichen):
   TEXT VAR char in; 
   char in := getcharety;
   IF pos (erlaubte zeichen,char in) > 0 AND char in <> " "
     THEN push (char in);TRUE 
     ELSE FALSE
   FI. 
END PROC eingabe von erlaubtem zeichen; 
 
PROC zeile (TEXT CONST t,tt): 
  putline (8*" " + ""15"" + t + " "14"" + " ... " + tt) 
END PROC zeile; 
 
PROC formatieren einer diskette: 
   page; 
   putline ("Formatieren einer Diskette."); 
   putline ("==========================="); 
   putline (""15"Achtung: Alle Disketten-Informationen werden gelöscht!"14""); 
   line; 
   putline ("Dies sind die moeglichen Formate:"); 
   zeile ("o","... Ohne Format-Angabe"); 
   zeile ("0","... Standard-Format"); 
   zeile ("1","... 40 Spur -  360 KB"); 
   zeile ("2","... 80 Spur -  720 KB"); 
   zeile ("3","... IBM Std - 1200 KB"); 
   zeile ("q","... Es wird nicht formatiert."); 
   TEXT VAR art; 
   put ("Ihre Wahl:"); 
   inchar (art, "o01234q"); 
   IF art = "q" 
      THEN LEAVE formatieren einer diskette 
   FI; 
   out (art); line; 
   put ("zukünftiger Name des Archives :"); 
   editget (aktueller archivename);line; 
   archive (aktueller archivename); 
   diskette im schacht := TRUE;
   disable stop; 
   IF art = "o" THEN format (archive) 
                ELSE format (int (art), archive) 
   FI; 
   IF is error 
      THEN diskette im schacht := FALSE
      ELSE aktueller archivename := archiv name
   FI
END PROC formatieren einer diskette; 
 
PROC auflisten der taskdateien: 
   DATASPACE VAR dummy ds :: nilspace; 
   FILE VAR f :: sequential file (output,dummy ds); 
   list (f); 
   headline (f,"Liste der eigenen Task"); 
   modify (f); 
   to line (f,1); 
   show (f); 
   forget (dummy ds) 
END PROC auflisten der taskdateien; 
 
PROC loeschen von dateien in der task: 
  t1 := invers ("Loeschen von Dateien ") + "  Info mit <?>" + trennzeichen + 
        "Bitte alle zu loeschenden Dateien ankreuzen" + trennzeichen + 
        invers ("(Ankreuzen mit <RETURN> )"); 
  forget (some (all,t1)) 
END PROC loeschen von dateien in der task; 
 
PROC reservieren des archives: 
   TEXT VAR meldung; 
   page; 
   cursor(1,1); write("Bitte warten..."); 
   line (2); 
   versuche archive zu reservieren (meldung); 
   IF meldung <> "" 
      THEN page; 
           line(10); 
           write (""15"" + meldung + " "14""); 
           weitermachen; 
           diskette im schacht := FALSE;
           archive ist meins := FALSE;  
           LEAVE reservieren des archives 
   FI; 
   archive anmelden (aktueller archive name, meldung); 
   IF meldung <> "" 
    THEN melde archiveerror (meldung)
   FI. 
  
END PROC reservieren des archives;  
   
PROC versuche archive zu reservieren (TEXT VAR fehlermeldung): 
    fehlermeldung := ""; 
    IF archive ist meins 
       THEN LEAVE versuche archive zu reservieren 
    FI; 
    disable stop;  
    archive (""); 
    IF is error  
       THEN fehlermeldung := errormessage; 
            archive ist meins := FALSE;
            clear error; 
            enable stop; 
       ELSE archive ist meins := TRUE;  
            fehlermeldung := "";  
            enable stop 
    FI 
END PROC versuche archive zu reservieren; 
 
PROC archive anmelden (TEXT VAR archivename, fehlermeldung): 
  page; 
  line(3); 
  fehlermeldung := ""; 
  IF NOT archive ist meins 
     THEN archivename   := "";  
          diskette im schacht := FALSE;
          fehlermeldung := "nicht reserviert"; 
          LEAVE archive anmelden  
  FI; 
  IF yes ("Haben Sie die Diskette eingelegt und das Laufwerk geschlossen") 
     THEN line; 
          write ("Bitte warten..."); 
          archive name := archiv name;
          IF archiv error <> ""
           THEN fehlermeldung := archiv error;
                diskette im schacht := FALSE
           ELSE diskette im schacht := TRUE
          FI
     ELSE diskette im schacht := FALSE; 
          archivename := ""
  FI 
END PROC archive anmelden;
 
PROC verlange reservierung des archives: 
   page;
   line(7); 
   write (""15"Sie muessen unbedingt erst das Archiv reservieren, "14""); 
   line(2);  
   write (""15"sonst kann ich nicht darauf zugreifen! "14""); 
   line(2);  
   weitermachen 
END PROC verlange reservierung des archives;  
  
PROC auflisten der archivedateinamen: 
  forget ("Dateiliste", quiet); 
  ueberpruefe reservierung; 
  liste dateien des archivs auf; 
  liste ausgeben; 
  forget ("Dateiliste", quiet). 
  
  ueberpruefe reservierung: 
    IF disk AND diskette im schacht 
            AND NOT archive ist meins 
       THEN verlange reservierung des archives;  
            LEAVE auflisten der archivedateinamen 
    FI. 
 
  liste dateien des archivs auf: 
    FILE VAR f :: sequential file (output,"Dateiliste"); 
    disable stop; 
    list(f,manager); 
    IF is error 
       THEN LEAVE auflisten der archivedateinamen; 
       ELSE enable stop 
    FI. 
  
  liste ausgeben: 
    show (f) 
END PROC auflisten der archivedateinamen;  
 
PROC checken von dateien auf dem archive:  
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und checke.  
  
   ueberpruefe reservierung: 
     IF disk AND diskette im schacht 
             AND NOT archive ist meins 
        THEN verlange reservierung des archives; 
             LEAVE checken von dateien auf dem archive 
     FI. 
  
   lasse dateien auswaehlen und checke: 
     t1 := invers ("'Checken' von Dateien  (auf dem Archiv) ") 
           + trennzeichen + "Bitte alle zu 'checkenden' Dateien ankreuzen"; 
     disable stop; 
     check (some (ALL manager, t1), manager); 
     weitermachen; 
     IF is error 
        THEN LEAVE checken von dateien auf dem archive 
        ELSE enable stop; 
     FI 
END PROC checken von dateien auf dem archive;  
  
PROC schreiben von dateien aufs archive: 
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und schreibe aufs archive. 
    
ueberpruefe reservierung: 
  IF disk AND diskette im schacht 
          AND NOT archive ist meins 
     THEN verlange reservierung des archives; 
          LEAVE schreiben von dateien aufs archive 
  FI. 
 
lasse dateien auswaehlen und schreibe aufs archive: 
  t1 := invers ("Schreiben von Dateien ") + " Info mit <?>" + trennzeichen + 
        "Bitte alle zu schreibenden Dateien ankreuzen." + trennzeichen + 
        invers ("(Ankreuzen mit <RETURN> )"); 
  THESAURUS VAR angekreuzte :: some (ALL myself, t1); 
  disable stop;
  zuerst loeschen; 
  INT VAR zaehler; 
  TEXT VAR dname; 
  page; 
  FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP 
      IF is error 
         THEN LEAVE schreiben von dateien aufs archive 
      FI;  
      dname := name (angekreuzte, zaehler); 
      IF dname <> "" 
         THEN putline (managername + " <--- """ + dname + """"); 
              save (dname, manager) 
      FI; 
  PER.
 
  zuerst loeschen:  
    IF disk CAND (not empty (angekreuzte)) 
       THEN out (center(invers("Bitte Warten"),"-",80)); 
            THESAURUS CONST zu loe :: angekreuzte / ALL manager;  
            IF not empty (zu loe) AND NOT is error
               THEN page; 
                    putline ("Zuerst Dateien auf der Diskette loeschen?"); 
                    erase (zu loe, manager) 
            FI 
    FI  
END PROC schreiben von dateien aufs archive; 
  
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 holen von dateien vom archive: 
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und hole vom archive. 
    
ueberpruefe reservierung: 
  IF disk AND diskette im schacht 
          AND NOT archive ist meins 
     THEN verlange reservierung des archives; 
          LEAVE holen von dateien vom archive 
  FI. 
 
lasse dateien auswaehlen und hole vom archive: 
  t1 := invers ("Holen von Dateien ") + "  Info mit <?>" + 
        trennzeichen + 
        "Bitte alle zu holenden Dateien ankreuzen."; 
  THESAURUS VAR angekreuzte :: some (ALL manager,t1); 
  INT VAR zaehler; 
  TEXT VAR dname; 
  page; 
  FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP 
      dname := name (angekreuzte, zaehler); 
      disable stop; 
      IF dname <> "" 
         THEN putline (managername + " --> """ + dname + """"); 
              fetch (dname, manager) 
      FI; 
      IF is error 
         THEN LEAVE holen von dateien vom archive 
         ELSE enable stop  
      FI   
  PER 
END PROC holen von dateien vom archive; 
 
PROC loeschen von dateien auf dem archive: 
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und loesche. 
    
 ueberpruefe reservierung: 
   IF disk AND diskette im schacht 
           AND NOT archive ist meins 
      THEN verlange reservierung des archives; 
           LEAVE loeschen von dateien auf dem archive 
   FI. 
 
lasse dateien auswaehlen und loesche: 
  t1 := invers ("Vernichten (Loeschen) von Dateien") + " Info mit <?>" + 
        trennzeichen + "Bitte alle zu loeschenden Dateien ankreuzen."; 
  disable stop; 
  erase (some (ALL manager, t1), manager); 
  IF is error 
     THEN LEAVE loeschen von dateien auf dem archive 
     ELSE enable stop; 
  FI 
END PROC loeschen von dateien auf dem archive; 
 
PROC initialisieren des archives: 
     TEXT VAR neuer archivename; 
     page; 
     line(2); 
     write(center (""15"Vollstaendiges Loeschen des Archivs "14"")); 
     line(2); 
     IF archive ist meins AND diskette im schacht
        THEN write("Eingestellter Archivname: " + 
             invers ("""" + aktueller archivename + """")); 
             line(2); 
             IF yes ("Moechten Sie einen anderen Namen fuer das Archiv") 
                THEN line(2); 
                     stelle frage nach neuem namen 
                ELSE neuer archivename := aktueller archivename 
             FI 
        ELSE stelle frage nach neuem namen  
     FI;  
     fuehre initialisierung durch. 
  
     stelle frage nach neuem namen: 
       write("Bitte den Namen fuer das Archiv (maximal 30 Buchstaben):"); 
       line; 
       getline(neuer archivename); 
       neuer archivename := compress(neuer archivename); 
       IF   length (neuer archivename) > 40 
            THEN line(2); 
                 write ("Der neue Archivname ist zu lang!"); 
                 weitermachen; 
                 LEAVE initialisieren des archives 
       FI. 
  
     fuehre initialisierung durch: 
       disable stop; 
       aktueller archivename := neuer archivename; 
       archive (neuer archivename); 
       IF is error 
          THEN diskette im schacht := FALSE;
               archive ist meins := FALSE;
               LEAVE initialisieren des archives 
          ELSE clear(archive); 
               IF is error 
                  THEN diskette im schacht := FALSE;
                       LEAVE initialisieren des archives 
                  ELSE aktueller archivename := archiv name;
                       diskette im schacht := archiv error = ""
               FI
       FI 
END PROC initialisieren des archives; 
   
PROC ausdruck archivelisting: 
   ueberpruefe reservierung; 
   print archive listing; 
   weitermachen. 
  
ueberpruefe reservierung: 
    IF disk AND diskette im schacht 
            AND NOT archive ist meins 
       THEN verlange reservierung des archives;  
            LEAVE ausdruck archivelisting 
    FI. 
   
print archive listing: 
  FILE VAR listfile := sequential file (output , "PLA");
  INT  VAR i;
  TEXT CONST head :: 70 * "=",
             end  :: 70 * "_";
  TEXT VAR   record;
  disable stop;
  list (listfile, archive);
  IF is error 
    THEN diskette im schacht := FALSE;
         LEAVE ausdruck archivelisting
  FI;
  print head;
  erase dummy names;
  print bottom;
  print and erase listing.

print head :
  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); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, "ARCHIVNAME: "+headline (listfile) + "  " +
                time of day  +"  " + date ); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, " "); down (listfile);
  write record (listfile, "Date      Store  Contents").

erase dummy names :
  to line (listfile, 6);
  WHILE NOT eof (listfile) REP
    read record (listfile, record);
    IF (record SUB dummy name pos) = "-"
      THEN delete record (listfile)
      ELSE down (listfile) 
    FI 
  PER.

print bottom :
   output (listfile);
   putline (listfile, end).

print and erase listing :
  modify (listfile);
  edit (listfile);
  line (3);
  IF yes ("Archivlisting drucken")
    THEN print ("PLA")
  FI;
  forget ("PLA", quiet).
 
END PROC ausdruck archivelisting;  
 
PROC neue diskette anmelden: 
   ueberpruefe reservierung; 
   melde neue diskette an. 
  
   ueberpruefe reservierung: 
     IF NOT archive ist meins 
       THEN reservieren des archives;  
             LEAVE neue diskette anmelden 
     FI.  
 
   melde neue diskette an: 
     TEXT VAR meldung;  
     page; 
     cursor(1,1); write("Bitte warten..."); 
     line (2); 
     archive anmelden (aktueller archive name,meldung); 
     IF meldung <> "" 
       THEN melde archiveerror (meldung) 
     FI. 
  
END PROC neue diskette anmelden;  
 
PROC automatische freigabe des archives: 
   archive ist meins := FALSE;  
   diskette im schacht := FALSE; 
   command dialogue (FALSE); 
   release(archive); 
   command dialogue (TRUE) 
END PROC automatische freigabe des archives;  
  
PROC melde archiveerror (TEXT CONST meldung): 
   line(2); 
   IF   meldung = "nicht reserviert" 
        THEN verlange reservierung des archives; 
   ELIF meldung = "keine diskette" 
        THEN write (""15"Ich mache die Reservierung rueckgaengig! "14""); 
             neu reservieren 
   ELIF pos (meldung,"inkonsistent") > 0 
        THEN write(""15"Diskette ist nicht formatiert / initialisiert "14""); 
             neu reservieren; 
   ELIF pos(meldung,"Lesen unmoeglich") > 0 
           COR pos(meldung, "Schreiben unmoeglich") > 0 
        THEN write(""15"Die Diskette ist falsch eingelegt "14"");line (2); 
             write(""15"oder das Laufwerk ist nicht geschlossen "14"");line (2); 
             write(""15"oder die Diskette ist nicht formatiert !"14""); 
             neu reservieren; 
   ELIF pos (meldung, "Archiv heisst") > 0 AND pos(meldung, "?????") > 0 
        THEN write(""15"Diskette nicht lesbar ! (Name: '?????') "14"");line(2); 
             write(""15"Moeglicherweise ist die Diskette defekt ! "14"");  
             neu reservieren; 
   ELIF pos(meldung, "Archiv heisst") > 0 
        THEN write (invers(meldung)); 
             line(2); 
             write (""15"Diskette wurde mit anderem Namen angemeldet!"14"");line(2); 
             write("Bitte neu reservieren!"); 
             weitermachen 
   ELSE write(invers(meldung)); 
        neu reservieren 
   FI 
END PROC melde archiveerror; 
 
PROC neu reservieren: 
  line (2); 
  write ("Bitte den Fehler beseitigen und das Archiv neu reservieren !"); 
  weitermachen; 
  diskette im schacht := FALSE
END PROC neu reservieren; 
 
PROC weitermachen: 
  line (2);
  write("Zum Weitermachen bitte irgendeine Taste tippen!"); 
  pause  
END PROC weitermachen; 

PROC melde error (TEXT CONST meldung): 
  page; 
  line(10); 
  write (invers(meldung)); 
  weitermachen 
END PROC melde error 
  
END PACKET mpg dm; 
 
(**************************** TOOLS  *******************************)

PACKET mpg tools DEFINES put,
                         th,
                         gen :
 

lernsequenz auf taste legen ("E", ""27""2""27"p"27"qedit ("27"g)"13""); 

PROC put (BOOL CONST b) :
  IF b THEN put ("TRUE") ELSE put ("FALSE")  FI
END PROC put;

PROC th (THESAURUS CONST thes) :
  THESAURUS VAR help :: SOME thes;help := empty thesaurus
END PROC th;

(************************ Task - Generierung *******************************)

(* Zum Generieren einer TASK ist folgendes zu beachten:

a) Es muss ein Archiv zur Verfuegung stehen, das einen beliebigen Namen hat.
b) Auf diesem Archiv muss es eine Datei namens <"gen." + taskname> geben.
c) Diese Datei muss folgendermassen aufgebaut sein:
   In jeder Zeile steht genau ein Name einer fuer diese TASK wichtigen Datei.
   Die ersten Namen sind Namen von zu insertierenden Dateien.
   Es folgt "gen." + taskname.
   Alle folgenden Dateinamen werden vom Archiv geholt und bleiben in der
   TASK erhalten. *)

BOOL VAR archive access :: FALSE;

PROC hole (TEXT CONST dateiname):
  IF exists (dateiname) 
     THEN display ("***")
     ELSE IF NOT archive access
            THEN archiv;    (* geaendert BV 10.07.86 *)
                 archive access := TRUE
          FI;
          display ("-->");
          from (dateiname)
  FI;
  display (dateiname + ""13""10"")
END PROC hole;

PROC ins (TEXT CONST dateiname):
  line; 
  out (77 * "=" + ""13""10"");
  out (dateiname + " wird insertiert"13""10"");
  insert (dateiname);
  forget (dateiname, quiet)
END PROC ins;

LET anzahl dateien = 50;

ROW anzahl dateien TEXT VAR datei;

INT VAR anzahl zu insertierender,
        gesamtzahl;

PROC gen:
  TEXT CONST taskname :: name (myself),
             gendateiname :: "gen." + taskname;
  TEXT VAR   record;
  BOOL VAR   zu insertieren :: TRUE;

  archive access := FALSE;
  anzahl zu insertierender := 0;
  gesamtzahl               := 0;
  page;
  putline ("GENERIERUNG VON " + taskname);
  putline ((16 + length (taskname)) * "=");
  hole (gendateiname);

  FILE VAR gendatei := sequential file (input, gendateiname);
  WHILE NOT eof (gendatei) AND gesamtzahl < anzahl dateien REP
     getline (gendatei, record);
     record := compress (record);
     IF record = gendateiname
        THEN zu insertieren := FALSE
     FI;
     IF zu insertieren
        THEN anzahl zu insertierender INCR 1
     FI;
     gesamtzahl INCR 1;
     hole (record);
     datei [gesamtzahl] := record
  PER;
  forget (gendateiname, quiet);
  IF archive access
    THEN release;
         line (2);
         put ("Bitte entfernen Sie Ihre Diskette aus dem Laufwerk!"); 
         line
  FI;
  INT VAR i;
  FOR i FROM 1 UPTO anzahl zu insertierender REP
      ins (datei [i])
  PER;
  IF yes ("global manager")
     THEN do ("global manager")
  FI.
END PROC gen
 
END PACKET mpg tools;
 
(********************* MPG TARGET HANDLING *******************) 
 
PACKET target handling DEFINES TARGET, 
                       initialize target, 
                       complete target, 
                       delete in target, 
                       select target, 
                       actual target name, 
                       actual target set, 
                       target names: 
 
 
TYPE TARGET = STRUCT (INT ind, THESAURUS target name, target set); 
 
LET no target = 0; 
 
PROC initialize target (TARGET VAR tar): 
  tar.target set  := empty thesaurus; 
  tar.target name := empty thesaurus; 
  tar.ind         := no target 
END PROC initialize target; 
 
PROC complete target (TARGET VAR tar, TEXT CONST nam, set): 
  IF NOT (tar.target name CONTAINS nam) 
     THEN insert (tar.target name, nam); 
          insert (tar.target set , set) 
     ELSE errorstop ("Bezeichner bereits vorhanden") 
  FI 
END PROC complete target; 
 
PROC delete in target (TARGET VAR tar, TEXT CONST nam): 
  INT CONST ind :: link (tar.target name, nam); 
  delete (tar.target name, ind); 
  delete (tar.target set , ind); 
  tar.ind := no target 
END PROC delete in target; 
 
PROC select target (TARGET VAR tar, TEXT CONST nam, TEXT VAR set): 
  INT VAR ind :: link (tar.target name, nam); 
  IF ind <> 0 
     THEN set     := name (tar.target set , ind); 
          tar.ind := ind 
     ELSE set     := "" 
  FI 
END PROC select target; 
 
TEXT PROC actual target name (TARGET CONST tar): 
  IF tar.ind = no target 
     THEN "" 
     ELSE name (tar.target name, tar.ind) 
  FI 
END PROC actual target name; 
 
TEXT PROC actual target set (TARGET CONST tar): 
  IF tar.ind = no target 
     THEN "" 
     ELSE name (tar.target set, tar.ind) 
  FI 
END PROC actual target set; 
 
THESAURUS PROC target names (TARGET CONST tar): 
  tar.target name 
END PROC target names 
 
END PACKET target handling;

(*********************** MPG PRINT CMD ***********************)

PACKET mpg print cmd DEFINES print, select printer, 
                             install printers, 
                             list printers,
                             printer, printers: 
 
 
TARGET VAR printer list; 
 
LET std printer name = "PRINTER", 
    titel            = "PRINTER AUSWAHL"; 
 
LET trenner = "\#"; 
 
TARGET PROC printers: 
   printer list
END PROC printers;

PROC install printers (FILE VAR f): 
  initialize target (printer list); 
  TEXT VAR nam, set; 
  TEXT VAR std nam :: "", std set :: ""; 
  WHILE NOT eof (f) REP 
    TEXT VAR zeile; 
    getline (f, zeile); 
    IF zeile <> "" 
       THEN INT CONST po :: pos (zeile, trenner); 
            nam := subtext (zeile, 1, po - 1); 
            set := subtext (zeile, po + 1); 
            complete target (printer list, nam, set); 
            IF int (nam) = station (myself) 
               THEN std nam := nam; 
                    std set := set 
            FI 
    FI
  PER; 
  select target (printer list, std nam, std set); 
  IF std set <> "" 
     THEN fonttable (std set) 
  FI 
END PROC install printers; 
 
PROC select printer: 
  TEXT VAR font; 
  select target (printer list, 
     one (target names (printer list), titel,1,24), font); 
  IF font <> "" 
     THEN fonttable (font) 
  FI 
END PROC select printer; 
 
PROC list printers: 
  th (target names (printer list)) 
END PROC list printers; 
 
PROC print : 
  print (last param) 
END PROC print; 
 
PROC print (TEXT CONST file) : 
  save (file, printer) 
END PROC print; 
 
PROC print (THESAURUS CONST thes) : 
  save (thes, printer) 
END PROC print; 
 
TASK PROC printer: 
  INT VAR stat :: int (actual target name (printer list)); 
  IF stat = 0 
     THEN niltask 
     ELSE stat/std printer name 
  FI 
END PROC printer 
 
END PACKET mpg print cmd;
 
(************************ EDIT MONITOR *************************)

PACKET edit monitor DEFINES  edit monitor,    (* Lutz Prechelt      *)
                             F,               (* Carsten Weinholz   *) 
                             table:           (* Thomas Clermont    *) 
                                              (* EUMEL 1.8          *)
                                              (* Version 4.4.1      *)
                                              (* Multimonitor       *)
                                              (* Alphaeditor        *)
                                              (* 06.07.1987         *)
 
LET   command handling line  = 18,  (* muss > max file + 1 und < 23 sein *)
      max file               = 15,  (* max. 20 *)
      file type              = 1003,
      min lines per segment  = 24,  (* darunter wird reorganisiert *)
      integer is allowed     =  3,
      no command             = 4711,
      gib kommando 1         = "Gib Edit-Monitor ",
      gib kommando 2         = " Kommando :";
 
TEXT CONST command list ::"quitmonitor:1.0edit:2.1run:3.1insert:4.1" + 
                          "forget:5.1rename:6.2copy:7.2fetch:8.1"      + 
                          "save:9.1close:10.1fileinfo:11.0reorganize:12.1";
 
LET EDITTABLE = ROW max file STRUCT (THESAURUS line table, 
                                     TEXT      name, 
                                     FILE      file      );
 
LET nil code = 0, 
    edit code= 1, 
    do code  = 2;

INT  VAR command index, number of params, command indices,
         aufruftiefe :: 0,zeile;
 
TEXT VAR param 1, param 2, old command :: "", command line :: "";
BOOL VAR short command, info :: FALSE,verlasse monitor :: FALSE;
INITFLAG VAR this monitor;
 
EDITTABLE VAR etb;
 
PROC edit monitor :
  TEXT VAR ch, old lernsequenz :: lernsequenz auf taste ("Q");
  INT  VAR i, previous heap size :: heap size;
  disable stop;
  initialize;
  get new table;
  REP
    prepare screen;
    perhaps reorganize and get command;
    execute command;
    collect heap garbage if necessary
  UNTIL verlasse monitor PER;
  lernsequenz auf taste legen ("Q",old lernsequenz);
  close all files if not nested.

initialize :
  lernsequenz auf taste legen ("Q",""1""8""1""12"quitmonitor"13"");
  verlasse monitor := FALSE;
  aufruftiefe INCR 1;
  IF aufruftiefe > max file
     THEN aufruftiefe DECR 1; 
          errorstop ("Editmonitor overflow: Bereits " + text (max file ) + "Monitore geoeffnet") 
     ELSE IF NOT initialized (this monitor) 
             THEN FOR i FROM 1 UPTO max file REP 
                      etb [i].line table := empty thesaurus; 
                      etb [i].name := ""
                  PER
          FI; 
          FOR i FROM 1 UPTO max file REP 
            etb [i].name := name (etb [aufruftiefe].line table,i) 
          PER
  FI.

prepare screen :
  calc command handling line; 
  put file info.
 
calc command handling line: 
  out (""10""); (* down *)
  INT VAR dummy, y; 
  get cursor (dummy, y); 
  FOR dummy FROM 1 UPTO y-22 REP
     out (""10"") 
  PER; 
  zeile := max (command handling line, min (y + 1, 22)). 
 
perhaps reorganize and get command :
  BOOL VAR anything reorganized :: FALSE, 
           was error :: FALSE ;
  IF is error
   THEN command line := old command;
        out (""3""); (* up *)
        put error; clear error; was error := TRUE
   ELSE command line := "" 
  FI;
  out (        "      ");
  out (gib kommando);
  out (""13""10"      ");
  IF NOT was error THEN perhaps reorganize  FI;
  IF anything reorganized
  THEN command index := no command;
       LEAVE perhaps reorganize and get command
  FI;
  editget (command line, "", "fk", ch);
  IF ch = ""27"k"
  THEN out (""13""5"");
       command line := old command;
       out ("      ");
       editget (command line, "", "f", ch) 
  FI;
  line;
  old command := command line;
  command index := cmd index (command line);
  param position (LENGTH command line + 7);
  IF (command index > 0 AND command index <= max file) 
                        AND command indices > 0
  THEN short command := TRUE
  ELSE short command := FALSE;
       analyze command (command list, command line, integer is allowed,
                        command index, number of params,param 1, param 2)
  FI.

perhaps reorganize :
  BOOL VAR interrupt;
  ch := getcharety;
  IF ch <> "" 
   THEN push (ch); LEAVE perhaps reorganize 
  FI;
  ch := incharety (50);
  IF ch <> "" 
   THEN type (ch); LEAVE perhaps reorganize 
  FI;
  FOR i FROM 1 UPTO max file REP
    reorganize (etb [i].name, anything reorganized, interrupt, i);
  UNTIL interrupt OR anything reorganized  PER.

close all files if not nested :
  aufruftiefe DECR 1;
  command index := 0; (* Um die verschachtelten Aufrufe zu schuetzen *)
  verlasse monitor := aufruftiefe = 0;
  IF aufruftiefe > 0 
     THEN FOR i FROM 1 UPTO max file REP 
            etb [i].name := name (etb [aufruftiefe].line table,i)
          PER; 
     ELSE param 1      := "";
          param 2      := "";
          command line := "";
          old command  := ""
   FI.

collect heap garbage if necessary :
  IF heap size > previous heap size + 4
  THEN collect heap garbage;
       previous heap size := heap size
  FI
ENDPROC edit monitor;

PROC put file info: 
  INT VAR i;
    out (""1""); (* home *) 
  FOR i FROM 1 UPTO max file WHILE NOT is incharety REP
    out (text (i, 2));
    out (" : ");
    IF info 
     THEN show file info
    FI;
    IF etb [i].name <> "" 
     THEN out ("""" + etb [i].name + """")
    FI;
    out (""5""10""13"")
  PER;
  out(""5"");
  cursor (1, zeile).
 
show file info :
  (* Falls fileinfo an, werden vor den Dateinamen bei FILEs die Anzahl von
     Zeilen , Segmenten und Speicher angezeigt.                         *)
  IF exists (etb [i].name) 
     THEN IF type (old (etb [i].name)) = file type 
           THEN out (text (lines (etb [i].file), 5));
                out (" ");
                out (text (segments (etb [i].file), 4));
                out (" ")
           ELSE out ( 11 * "=")
          FI; 
          out (text (storage (old (etb [i].name)),5))
     ELIF etb [i].name <> ""
     THEN out ( 16 * "=") 
  FI;
  out ("  ").

END PROC put file info; 
 
PROC execute command :
  enable stop;
  IF command index = no command THEN LEAVE execute command  FI;
  IF short command  THEN do edit monitor command (command index) 
                    ELSE case selection  FI.

case selection :
  SELECT command index OF
    CASE 1 : (* quit *)  verlasse monitor := TRUE
    CASE 2 : edit (name from list (param 1))
    CASE 3 : run (name from list (param 1))
    CASE 4 : insert (name from list (param 1))
    CASE 5 : forget (name from list (param 1)); close (int (param1))
    CASE 6 : rename (name from list (param 1) , name from list (param 2))
    CASE 7 : copy (name from list (param 1), name from list (param 2))
    CASE 8 : fetch (name from list (param 1))
    CASE 9 : save (name from list (param 1))
    CASE 10: close (int (param 1))
    CASE 11: info := NOT info
    CASE 12: reorganize (name from list (param 1))
    OTHERWISE do (command line) 
  END SELECT 
END PROC execute command;

PROC close (INT CONST n) :
  IF (n > 0  AND n <= max file)  CAND  etb [n].name <> ""
  THEN IF exists (etb [n].name) CAND type (old (etb [n].name)) = file type
          THEN close (etb [n].file) 
       FI;
       INT VAR id;
       delete (etb [aufruftiefe].line table,etb [n].name,id); 
       etb [n].name := ""
  FI
END PROC close;

TEXT OP F (INT  CONST nr) :
     IF nr > 0 AND nr <= max file
      THEN etb [nr].name
      ELSE out (""7""); "" 
     FI
END OP F;

OP F (INT CONST nr, TEXT CONST datei) :
    IF nr > 0 AND nr <= max file
     THEN etb [nr].name := datei;
          insert (etb [aufruftiefe].line table,datei);
          IF exists (datei) CAND type (old (datei)) = file type
           THEN etb [nr].file := sequential file(modify, datei) 
          FI
     ELSE out (""7"") 
    FI
END OP F;

PROC get new table: 
 table (some (all + etb [aufruftiefe].line table + vorgaenger)). 
 
 vorgaenger: 
  IF aufruftiefe = 1 
   THEN empty thesaurus 
   ELSE etb [aufruftiefe - 1].line table
  FI
END PROC get new table; 
 
THESAURUS PROC table :
  THESAURUS VAR result :: emptythesaurus;
  INT VAR i;
  FOR i FROM 1 UPTO max file REP
    IF exists (etb [i].name) AND NOT (result CONTAINS etb [i].name)
     THEN insert (result, etb [i].name) 
    FI
  PER;
  result
END PROC table;

PROC table (THESAURUS CONST new) :
  INT VAR i, nr :: 1, dummy;
  TEXT VAR t;
  etb [aufruftiefe].line table := empty thesaurus; 
  FOR i FROM 1 UPTO max file REP
    etb [i].name := ""
  PER;
  FOR i FROM 1 UPTO highest entry (new) REP
    get (new, t, dummy);
    IF t <> ""
     THEN nr F t;nr INCR 1
    FI
  UNTIL nr > max file  PER
END PROC table;

PROC do edit monitor command (INT CONST file nr) :
  enable stop;
  IF command indices = 1 
     THEN try to edit or to execute
     ELSE try alpha editor 
  FI.

try to edit or to execute:
  SELECT prepare edit (file nr) OF
    CASE edit code: last param (etb [file nr].name);
                    edit   (etb [file nr].file);
                    page
    CASE do code  : do (etb[file nr].name)
  END SELECT. 
 
try alpha editor: 
  IF command indices <= 10 
     THEN open sub editors; 
          IF groesster editor > 0 
             THEN edit (1); 
                  WHILE groesster editor > 0 REP
                        quit
                  PER;
                  page
          FI
     ELSE errorstop ("Maximal 10 Parallel-Editoren") 
  FI. 
 
open sub editors: 
  TEXT VAR num, edit cmd :: ""; 
  INT VAR ye :: 1, sub :: file nr, pass;
  WHILE groesster editor > 0 REP
        quit
  PER;
  FOR pass FROM 1 UPTO 2 REP 
     IF pass = 2
        THEN command line := edit cmd
     FI;
     scan (command line);
     next symbol (num);                 (* skip ersten index *)
     REP
        INT VAR op code := prepare edit (sub);
        IF pass = 1
           THEN SELECT op code OF
                  CASE nil code : command indices DECR 1
                  CASE editcode : edit cmd CAT (num + " ")
                  CASE do code  : edit cmd CAT (num + " ");
                                  command indices DECR 1 
                END SELECT
           ELSE SELECT op code OF
                  CASE edit code: neuer editor
                  CASE do   code: do (etb [sub].name); 
                                  IF groesster editor > 0 
                                     THEN bild zeigen;     
                                          ueberschrift zeigen 
                                  FI 
                END SELECT
        FI; 
        next symbol (num);
        sub := int (num)
     UNTIL num = "" PER;
     sub := file nr;
  PER.

  neuer editor: 
    open editor (groesster editor+1,etb [sub].file, TRUE, 1,ye,79,25-ye); 
    ye INCR (24 DIV command indices)

END PROC do edit monitor command;

INT PROC prepare edit (INT CONST file nr): 
  IF file nr > 0 AND file nr <= max file
     THEN IF etb [file nr].name = "" 
             THEN get file name and open;
                  IF etb [file nr].name <> "" 
                     THEN IF exists (etb [file nr].name) 
                             THEN IF type (old (etb [file nr].name)) = file type
                                   THEN edit code
                                   ELSE nil code
                                  FI 
                             ELSE do code
                          FI
                     ELSE nil code
                  FI
          ELIF NOT exists (etb [file nr].name)  
             THEN do code
          ELIF type (old (etb [file nr].name)) <> file type
             THEN nil code
             ELSE modify (etb [file nr].file);
                  edit code
          FI 
     ELSE errorstop ("Undefinierter Index [1;15]");nil code
  FI.
  
get file name and open :
  cursor (4, file nr);
  out (""5"? ");
  editget (etb [file nr].name);
  IF etb [file nr].name <> "" 
     THEN file nr F etb [file nr].name; 
          IF NOT exists (etb [file nr].name)
             THEN out (""13""10"");
                  IF no (5 * ""2"" +"Datei neu einrichten")
                     THEN LEAVE prepare edit WITH nil code
                     ELSE kopple file an
                  FI
           ELIF type (old (etb [file nr].name)) = file type
             THEN kopple file an
          FI
   FI. 
 
 kopple file an: 
   etb [file nr].file := sequential file (output, etb [file nr].name). 
 
END PROC prepare edit; 
 
(***************** Hilfsprozeduren *********************************)

BOOL PROC is incharety :
  TEXT VAR ch :: getcharety; 
  IF ch = "" 
   THEN FALSE
   ELSE push (ch); 
        TRUE 
  FI
END PROC is incharety;

TEXT PROC name from list (TEXT CONST name):
  INT  VAR i :: int (name);
  IF (i > 0  AND  i <= max file)
   THEN etb [i].name
   ELSE name
  FI.
END PROC name from list;
 
PROC reorganize (TEXT CONST datei, BOOL VAR reorganization processed,
                                            interrupted, 
                                   INT CONST file nummer): 
  (* Reorganisiert nur , falls :
     1. Datei ein FILE ist
     2. FILE mindestens "min lines to reorganize" Zeilen hat
     3. FILE nicht im Schnitt "min lines per segment" Zeilen pro Segment hat
     4. kein Tastendruck erfolgt
   *)
  DATASPACE VAR ds;
  FILE VAR in, out;
  TEXT VAR t;
  INT VAR actual line,i,x,y;
  get cursor (x,y);
  interrupted := FALSE;
  IF NOT exists (datei) COR type (old (datei)) <> file type
   THEN LEAVE reorganize 
  FI;
  in := sequential file (modify, datei);
  actual line := line no (in); 
  input (in);
  IF (lines (in) < 120 CAND segments (in) < 6) COR 
     lines (in) DIV segments (in) >= min lines per segment
   THEN modify (in);
        to line (in,actual line); 
        LEAVE reorganize
  FI;
  disable stop;
  ds := nilspace;
  out := sequential file (output, ds);
  IF info 
     THEN FOR i FROM 1 UPTO lines (in) REP
              cursor (4, file nummer); 
              put (i);
              getline (in, t);
              putline (out, t);
              IF is error COR is incharety THEN interrupt  FI
          PER 
     ELSE FOR i FROM 1 UPTO lines (in) REP
              getline (in, t);
              putline (out, t);
              IF is error COR is incharety THEN interrupt  FI
          PER
  FI; 
  copy attributes (in,out);
  modify (out);
  to line (out,actual line);
  forget (datei, quiet);
  copy (ds, datei);
  forget (ds);
  reorganization processed := TRUE.

interrupt :
  cursor (4, lines (in)); 
  forget (ds);
  interrupted := TRUE;
  cursor (x,y);
  enable stop;
  LEAVE reorganize.

END PROC reorganize;

INT PROC cmd index (TEXT CONST command line): 
    INT VAR type, result :: 0; 
    TEXT VAR num;
    command indices := 0; 
    scan (command line); 
    REP 
       next symbol (num, type); 
       IF type = 3                     (* Ziffernfolge *) 
          THEN IF command indices = 0 
                  THEN result := int (num) 
               FI; 
               command indices INCR 1 
       ELIF type <> 7 
          THEN command indices := 0 
       FI 
    UNTIL type = 7 OR command indices = 0 PER; 
    result 
END PROC cmd index;

TEXT PROC gib kommando: 
  gib kommando 1 + text (aufruftiefe) + gib kommando 2 
END PROC gib kommando; 
 
END PACKET edit monitor; 
 
(******************************** MANAGER ******************************)
 
PACKET mpg global manager DEFINES monitor, 
                                  break, 
                                  end global manager, 
                                  begin, 
                                  begin password,
                                  manager message,
                                  manager question,
                                  free manager,
                                  std manager,
                                  mpg manager,
                                  free global manager,
                                  global manager :


LET ack              = 0,
    nak              = 1,
    error nak        = 2,
    message ack      = 3,
    question ack     = 4,
    second phase ack = 5,
    false code       = 6,

    begin code       = 4,
    password code    = 9,
    fetch code       = 11,
    save code        = 12,
    exists code      = 13,
    erase code       = 14,
    list code        = 15,
    all code         = 17,

    killer code      = 24, 

    continue code    = 100,
 
    error pre        = ""7""13""10""5"Fehler : ",
    cr lf            = ""13""10"";

 
DATASPACE VAR ds := nilspace;
 
BOUND STRUCT (TEXT fnam, write pass, read pass) VAR msg;
BOUND TEXT VAR reply msg;
 
TASK VAR order task, last order task;
 
FILE VAR list file;
INT VAR reply, order, last order, phase no;
TEXT VAR error message buffer :: "",
         record,
         fnam,
         create son password :: "",
         save write password,
         save read password,
         save file fnam;
 
TEXT VAR std begin proc :: "checkoff;endglobalmanager(TRUE);" +
                           "warnings off;sysout("""");sysin("""");" +
                           "monitor";
BOOL VAR is global manager, is break manager;

PROC mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
                  manager) :
  IF online
    THEN TEXT VAR dummy;
         put ("Task-Passwort  :");
         getsecretline (dummy);
         IF dummy <> "" THEN taskpassword (dummy) FI;
         put ("Beginn-Passwort:");
         getsecretline (dummy);
         IF dummy <> "" THEN begin password (dummy) FI
  FI;
  is break manager  := FALSE;
  global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
                  manager)
END PROC mpg manager;

PROC global manager :
  mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
               std manager)
END PROC global manager;

PROC global manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
                     TASK CONST) manager) :
   is global manager := TRUE; 
   internal manager (PROC (DATASPACE VAR,INT CONST,INT CONST, 
                     TASK CONST) manager) 
END PROC global manager; 
 
PROC internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
                       TASK CONST) manager) :
  old break;
  set autonom;
  disable stop;
  command dialogue (FALSE);
  last order task := niltask;
  remember heap size;
  REP
    wait (ds, order, order task);
    IF   order <> second phase ack
      THEN prepare first phase;
           manager (ds, order, phase no, order task)
    ELIF order task = last order task
      THEN prepare second phase;
           manager (ds, order, phase no, order task)
      ELSE send nak  FI;
    send error if necessary;
    collect heap garbage if necessary
  UNTIL (NOT is global manager) AND (NOT is break manager)
  PER;
  command dialogue (TRUE);
  reset autonom.

send error if necessary :
  IF is error
    THEN forget (ds);
         ds := nilspace;
         reply msg := ds;
         CONCR (reply msg) := error message;
         clear error;
         send (order task, error nak, ds)
  FI .
 
remember heap size :
  INT VAR old heap size := heap size .

collect heap garbage if necessary :
  IF heap size > old heap size + 2
    THEN collect heap garbage;
         old heap size := heap size
  FI .

prepare first phase :
  phase no := 1;
  last order := order;
  last order task := order task.

prepare second phase :
  phase no INCR 1;
  order := last order.

send nak :
  forget (ds);
  ds := nilspace;
  send (order task, nak, ds)
END PROC internal manager;

PROC free global manager :
  mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
               free manager)
END PROC free global manager;

PROC std manager (DATASPACE VAR ds, INT CONST order, phase, 
                  TASK CONST order task) :
  IF (order = begin code AND task darf beginnen) COR
                             task darf senden
     THEN free manager (ds, order, phase, order task)
     ELSE errorstop ("Kein Zugriffsrecht auf Task """ + name (myself) + """")
  FI.

  task darf beginnen:
    (task ist systemtask OR task ist sohn) AND is global manager.

  task darf senden:
    task ist systemtask OR task ist sohn.

  task ist systemtask:
    ordertask < supervisor OR ordertask = supervisor.

  task ist sohn:
    order task < myself
END PROC std manager;

PROC free manager (DATASPACE VAR ds, INT CONST order, phase,
                   TASK CONST order task) :
  enable stop;
  IF   order > continue code   AND
       order task = supervisor THEN y maintenance
  ELIF order = begin code AND is global manager
    THEN y begin
    ELSE file manager order
  FI .

file manager order :
  get message text if there is one;
  SELECT order OF
    CASE fetch code       : y fetch
    CASE save code        : y save
    CASE exists code      : y exists 
    CASE erase code       : y erase
    CASE list code        : y list
    CASE all code         : y all
    CASE killer code      : y killer
    OTHERWISE errorstop ("Falscher Auftrag fuer Task """ + name (myself) + """")
  ENDSELECT .
 
get message text if there is one :
  IF order >= fetch code AND order <= erase code AND phase = 1 (* 28.6.'86 *)
    THEN msg := ds;
         fnam := msg.fnam
  FI .
 
y begin :
  BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg := ds;
  IF create son password = sv msg.tpass AND create son password <> "-"
    THEN create son task
  ELIF sv msg.tpass = ""
    THEN ask for password
  ELSE   errorstop ("Passwort falsch")
  FI .

create son task :
  begin (ds, PROC std begin, reply);
  send (order task, reply, ds) .

ask for password :
  send (order task, password code, ds) .

y fetch :
  IF read permission (fnam, msg.read pass) COR order task < supervisor
    THEN forget (ds);
         ds := old (fnam);
         send (order task, ack, ds)
    ELSE errorstop ("Passwort falsch")
  FI .
 
y erase :
  msg := ds;
  fnam := msg.fnam;
  IF NOT exists (fnam)
    THEN manager message ("""" + fnam + """ existiert nicht", order task)
  ELIF phase no = 1
    THEN manager question ("""" + fnam + """ loeschen", order task)
  ELIF write permission (fnam, msg.write pass) COR order task < supervisor
    THEN forget (fnam, quiet);
         send (order task, ack, ds)
    ELSE errorstop ("Passwort falsch")  FI .
 
y save :
  IF phase no = 1
    THEN ysave pre
    ELSE y save post  FI.

y save pre :
  IF write permission (fnam, msg.write pass) COR order task < supervisor
    THEN save file fnam := fnam;
         save write password  := msg.write pass;
         save read password   := msg.read pass;
         IF exists (fnam)
           THEN manager question (""""+fnam+""" ueberschreiben", order task)
           ELSE send (order task, second phase ack, ds)
         FI;
    ELSE errorstop ("Passwort falsch")
  FI .
 
y save post :
  forget (save file fnam, quiet);
  copy (ds, save file fnam);
  enter password (save file fnam,
                  save write password, save read password);
  forget (ds);
  ds := nilspace;
  send (order task, ack, ds);
  cover tracks of save passwords.

cover tracks of save passwords :
  replace (save write password, 1, LENGTH save write password * " ");
  replace (save read  password, 1, LENGTH save read  password * " ") .

y exists :
  IF exists (fnam)
    THEN send (order task, ack, ds)
    ELSE send (order task, false code, ds)
  FI.

y list :
  forget (ds);
  ds := nilspace;
  list file := sequential file (output, ds);
  list (list file);
  send (order task, ack, ds) .
 
y all :
  BOUND THESAURUS VAR all fnams := ds;
  all fnams := all;
  send (order task, ack, ds) .
 
y maintenance :
  TEXT VAR  param 1, param 2;
  INT  VAR  c index, nr of params;
  TEXT CONST c list :: "break:1.0end:2.0monitor:3.0stdbeginproc:4.1";
  disable stop;
  call (supervisor, order, ds, reply);
  forget (ds);
  IF reply = ack
    THEN IF is break manager
           THEN end global manager (TRUE);
                LEAVE y maintenance
         FI;
         put error message if there is one;
         REP 
           command dialogue (TRUE);
           get command ("Gib " + name (myself) + "-Kommando :");
           analyze command (c list,0,c index,nr of params,param 1,param 2);
           SELECT c index OF
             CASE 1    : old break
             CASE 2, 3 : is global manager := FALSE;
                         is break manager  := FALSE;
                         LEAVE y maintenance
             CASE 4    : std begin proc := param 1
             OTHERWISE do command
           END SELECT
         UNTIL NOT on line PER;
         command dialogue (FALSE);
         old break;
         set autonom;
         save error message if there is one
  FI;
  enable stop .

put error message if there is one :
  IF error message buffer <> ""
    THEN out (error pre);
         out (error message buffer);
         out (cr lf);
         error message buffer := ""
  FI.

save error message if there is one :
  IF is error
    THEN error message buffer := error message;
         clear error
  FI.

y killer :
  FILE VAR f :: sequential file (input, ds);
  WHILE NOT eof (f) REP
    getline (f, record);
    IF exists (record) THEN forget (record, quiet)  FI
  PER;
  send (order task, ack, ds).
ENDPROC free manager;
 
PROC manager question (TEXT CONST question) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := question;
  send (order task, question ack, ds)
END PROC manager question;

PROC manager question (TEXT CONST question, TASK CONST receiver) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := question;
  send (receiver, question ack, ds)
END PROC manager question;

PROC manager message (TEXT CONST message) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := message;
  send (order task, message ack, ds)
END PROC manager message;

PROC manager message (TEXT CONST message, TASK CONST receiver) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := message;
  send (receiver, message ack, ds)
END PROC manager message;

PROC std begin :
  do (std begin proc)
ENDPROC std begin;

PROC begin (TEXT CONST task name) :
  TASK VAR sohn;
  begin (task name, PROC monitor, sohn)
END PROC begin;

PROC begin password (TEXT CONST password) :
  cover tracks of old create son password;
  create son password := password;
  display (""3""13""5"");
  cover tracks.

cover tracks of old create son password:
  replace (create son password,1,LENGTH create son password * " ")
END PROC begin password;

PROC end global manager (BOOL CONST ende) :
  is global manager := NOT ende;
  is break manager  := NOT ende
ENDPROC end global manager;

PROC old break :
  eumel must advertise;
  supervisor call (6)
END PROC old break;

PROC break :
  IF is global manager 
    THEN old break; LEAVE break
  FI;
  is break manager  := TRUE;
  is global manager := FALSE; 
  internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) 
                    std manager)
END PROC break;

PROC supervisor call (INT CONST nr) :
  DATASPACE VAR sv space :: nilspace;
  INT VAR answer;
  call (supervisor, nr, sv space, answer);
  IF answer = error nak
    THEN BOUND TEXT VAR err msg :: sv space;
         forget (sv space); errorstop (err msg)
  FI;
  forget (sv space)
END PROC supervisor call;

 
 
LET cmd list =
 
"edit:1.01end:3.0run:4.01runagain:6.0insert:7.01forget:9.01rename:11.2copy:12.2
list:13.0storageinfo:14.0taskinfo:15.0fetch:16.1save:17.01saveall:19.0";
 
 
INT VAR cmd index , params , previous heap size ;
TEXT VAR param1, param2 ;
 
 
PROC monitor :
  disable stop ;
  previous heap size := heap size ;
  REP 
    command dialogue (TRUE); 
    sysin (""); 
    sysout (""); 
    cry if not enough storage; 
    get command ("gib kommando :"); 
    analyze command (cmd list, 4, cmd index, params, param1, param2);
    execute command ;
    collect heap garbage if necessary
  PER .
 
collect heap garbage if necessary :
  IF heap size > previous heap size + 4
    THEN collect heap garbage ;
         previous heap size := heap size
  FI.

cry if not enough storage : 
  INT VAR size, used; 
  storage (size, used); 
  IF used > size 
    THEN out (""7"Speicher Engpass! Dateien loeschen!"13""10"") 
  FI. 
ENDPROC monitor ;

PROC execute command :
  enable stop ;
  SELECT cmd index OF
    CASE 1 : edit
    CASE 2 : edit (param1)
    CASE 3 : end
    CASE 4 : run
    CASE 5 : run (param1)
    CASE 6 : run again
    CASE 7 : insert
    CASE 8 : insert (param1)
    CASE 9 : forget
    CASE 10: forget (param1)
    CASE 11: rename (param1, param2)
    CASE 12: copy (param1, param2)
    CASE 13: list
    CASE 14: storage info
    CASE 15: task info
    CASE 16: fetch (param1)
    CASE 17: save
    CASE 18: save (param1)
    CASE 19: save all 
    OTHERWISE do command
  ENDSELECT .
 
ENDPROC  execute command ;

END PACKET mpg global manager